diff --git a/.gitignore b/.gitignore index 42e80e9e98..9d941743c9 100644 --- a/.gitignore +++ b/.gitignore @@ -61,3 +61,4 @@ stream_list.* *.i90 src/core_*/inc +/build-cmake-colm-debug diff --git a/CMakeLists.txt b/CMakeLists.txt index e7e010394d..8c5d7a6079 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -22,6 +22,11 @@ option(MPAS_PROFILE "Enable GPTL profiling" OFF) option(MPAS_OPENMP "Enable OpenMP" OFF) option(BUILD_SHARED_LIBS "Build shared libraries" ON) option(MPAS_USE_PIO "Build with PIO I/O library" OFF) +option(MPAS_COLM2024 "Build atmosphere core with embedded CoLM2024 land-surface physics" OFF) + +if(MPAS_COLM2024 AND NOT DO_PHYSICS) + message(FATAL_ERROR "MPAS_COLM2024 requires DO_PHYSICS=ON because CoLM2024 is built into the atmosphere physics driver.") +endif() message(STATUS "[OPTION] MPAS_CORES: ${MPAS_CORES}") message(STATUS "[OPTION] MPAS_DOUBLE_PRECISION: ${MPAS_DOUBLE_PRECISION}") @@ -29,6 +34,7 @@ message(STATUS "[OPTION] MPAS_PROFILE: ${MPAS_PROFILE}") message(STATUS "[OPTION] MPAS_OPENMP: ${MPAS_OPENMP}") message(STATUS "[OPTION] BUILD_SHARED_LIBS: ${BUILD_SHARED_LIBS}") message(STATUS "[OPTION] MPAS_USE_PIO: ${MPAS_USE_PIO}") +message(STATUS "[OPTION] MPAS_COLM2024: ${MPAS_COLM2024}") # Build product output locations set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) @@ -43,8 +49,11 @@ if(NOT CMAKE_BUILD_TYPE) endif() # Detect MPAS git version +if(DEFINED GIT_EXECUTABLE AND NOT EXISTS "${GIT_EXECUTABLE}") + unset(GIT_EXECUTABLE CACHE) +endif() +find_package(Git QUIET) if(NOT MPAS_GIT_VERSION) - find_package(Git QUIET) if(GIT_FOUND) execute_process(COMMAND ${GIT_EXECUTABLE} describe --dirty WORKING_DIRECTORY "${CMAKE_SOURCE_DIR}" @@ -68,9 +77,11 @@ endif() find_package(MPI REQUIRED COMPONENTS Fortran) find_package(PnetCDF REQUIRED COMPONENTS Fortran) +if(MPAS_USE_PIO OR MPAS_COLM2024) + find_package(NetCDF REQUIRED COMPONENTS Fortran C) +endif() if(MPAS_USE_PIO) find_package(PIO REQUIRED COMPONENTS Fortran C) - find_package(NetCDF REQUIRED COMPONENTS Fortran C) endif() if(MPAS_PROFILE) find_package(GPTL REQUIRED) diff --git a/Makefile b/Makefile index 07ba5f9556..3b9f5277a5 100644 --- a/Makefile +++ b/Makefile @@ -1029,6 +1029,13 @@ endif # END OF GIT DESCRIBE VERSION #################################################### # Section for adding external libraries and includes #################################################### +ifeq "$(COLM2024)" "true" +COLM2024_DIR ?= $(PWD)/src/core_atmosphere/physics/physics_colm2024 +override CPPFLAGS += -DMPAS_COLM2024 +COLM2024_MESSAGE = "MPAS was built with CoLM2024 from $(COLM2024_DIR)." +else +COLM2024_MESSAGE = "MPAS was not built with CoLM2024." +endif ifdef MPAS_EXTERNAL_LIBS override LIBS += $(MPAS_EXTERNAL_LIBS) endif @@ -1573,6 +1580,7 @@ mpas_main: $(MAIN_DEPS) @echo $(OPENMP_OFFLOAD_MESSAGE) @echo $(OPENACC_MESSAGE) @echo $(MUSICA_MESSAGE) + @echo $(COLM2024_MESSAGE) @echo $(SCOTCH_MESSAGE) @echo $(SHAREDLIB_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @@ -1648,4 +1656,3 @@ errmsg: ifdef CORE exit 1 endif - diff --git a/cmake/Functions/MPAS_Functions.cmake b/cmake/Functions/MPAS_Functions.cmake index 15d9f63fc1..db2240f4bd 100644 --- a/cmake/Functions/MPAS_Functions.cmake +++ b/cmake/Functions/MPAS_Functions.cmake @@ -148,7 +148,8 @@ function(mpas_fortran_target target) endfunction() -# mpas_core_target(CORE TARGET INCLUDE ) +# mpas_core_target(CORE TARGET +# INCLUDES REGISTRY_DEPENDS ) # # Common configuration and properties for `MPAS::core::` targets. # * Calls mpas_fortran_target() for common Fortran target configuration. @@ -164,9 +165,10 @@ endfunction() # CORE - Name of core # TARGET - Name of core_target (without namespace) # INCLUDES - List of generated include files +# REGISTRY_DEPENDS - Files included by the core Registry.xml preprocessor input # function(mpas_core_target) - cmake_parse_arguments(ARG "" "CORE;TARGET" "INCLUDES" ${ARGN}) + cmake_parse_arguments(ARG "" "CORE;TARGET" "INCLUDES;REGISTRY_DEPENDS" ${ARGN}) mpas_fortran_target(${ARG_TARGET}) @@ -214,25 +216,26 @@ function(mpas_core_target) if (${DO_PHYSICS}) set(CPP_EXTRA_FLAGS ${CPP_EXTRA_FLAGS} -DDO_PHYSICS) endif() + set(REGISTRY_PROCESSED_XML ${CMAKE_CURRENT_BINARY_DIR}/Registry_processed.xml) -add_custom_command(OUTPUT Registry_processed.xml - COMMAND ${CPP_EXECUTABLE} -E -P ${CPP_EXTRA_FLAGS} ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml > Registry_processed.xml +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) + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml ${ARG_REGISTRY_DEPENDS}) add_custom_command(OUTPUT ${ARG_INCLUDES} - COMMAND mpas_parse_${ARG_CORE} Registry_processed.xml ${CPP_EXTRA_FLAGS} + COMMAND mpas_parse_${ARG_CORE} ${REGISTRY_PROCESSED_XML} ${CPP_EXTRA_FLAGS} COMMENT "CORE ${ARG_CORE}: Parse Registry" - DEPENDS mpas_parse_${ARG_CORE} Registry_processed.xml) + 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 + COMMAND mpas_namelist_gen ${REGISTRY_PROCESSED_XML} namelist.${ARG_CORE} in_defaults=true COMMENT "CORE ${ARG_CORE}: Generate Namelist" - DEPENDS mpas_namelist_gen Registry_processed.xml) + 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 + COMMAND mpas_streams_gen ${REGISTRY_PROCESSED_XML} streams.${ARG_CORE} stream_list.${ARG_CORE}. listed COMMENT "CORE ${ARG_CORE}: Generate Streams" - DEPENDS mpas_streams_gen Registry_processed.xml) + 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}) diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt index 7fdbe66992..b71a0295e2 100644 --- a/src/core_atmosphere/CMakeLists.txt +++ b/src/core_atmosphere/CMakeLists.txt @@ -35,6 +35,7 @@ set(ATMOSPHERE_CORE_PHYSICS_SOURCES mpas_atmphys_driver_sfclayer.F mpas_atmphys_init.F mpas_atmphys_lsm_shared.F + mpas_atmphys_driver_lsm_colm2024.F mpas_atmphys_packages.F mpas_atmphys_todynamics.F mpas_atmphys_vars.F @@ -298,6 +299,146 @@ set(ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES ) list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES PREPEND physics/physics_noahmp/src/) +if(MPAS_COLM2024) + set(COLM2024_SOURCE_ROOT ${CMAKE_CURRENT_SOURCE_DIR}/physics/physics_colm2024) + set_property(DIRECTORY APPEND PROPERTY CMAKE_CONFIGURE_DEPENDS + ${COLM2024_SOURCE_ROOT}/include/define.h) + set(COLM2024_SOURCE_SEARCH_DIRS + share + main + main/HYDRO + main/BGC + main/URBAN + main/DA + main/ParaOpt + drivers/mpas + ) + foreach(_colm2024_dir IN LISTS COLM2024_SOURCE_SEARCH_DIRS) + file(GLOB _colm2024_dir_sources CONFIGURE_DEPENDS + ${COLM2024_SOURCE_ROOT}/${_colm2024_dir}/*.F90) + list(APPEND COLM2024_SOURCE_CANDIDATES ${_colm2024_dir_sources}) + endforeach() + list(REMOVE_DUPLICATES COLM2024_SOURCE_CANDIDATES) + list(SORT COLM2024_SOURCE_CANDIDATES) + foreach(_colm2024_src IN LISTS COLM2024_SOURCE_CANDIDATES) + file(RELATIVE_PATH _colm2024_src_rel ${CMAKE_CURRENT_SOURCE_DIR} ${_colm2024_src}) + execute_process( + COMMAND ${CPP_EXECUTABLE} -traditional-cpp -P -I${COLM2024_SOURCE_ROOT}/include ${_colm2024_src} + OUTPUT_VARIABLE _colm2024_preprocessed_src + ERROR_VARIABLE _colm2024_preprocess_error + RESULT_VARIABLE _colm2024_preprocess_result + ) + if(NOT _colm2024_preprocess_result EQUAL 0) + message(FATAL_ERROR "Could not preprocess CoLM2024 source ${_colm2024_src}: ${_colm2024_preprocess_error}") + endif() + string(TOUPPER "${_colm2024_preprocessed_src}" _colm2024_preprocessed_src_upper) + if(NOT "${_colm2024_preprocessed_src_upper}" MATCHES "(^|\n)[ \t]*(MODULE|SUBROUTINE|FUNCTION|PROGRAM)[ \t]+[A-Z0-9_]+") + list(APPEND ATMOSPHERE_CORE_PHYSICS_COLM2024_SKIPPED_EMPTY_SOURCES ${_colm2024_src_rel}) + continue() + endif() + list(APPEND COLM2024_AVAILABLE_SOURCES ${_colm2024_src_rel}) + string(REGEX MATCHALL "(^|\n)[ \t]*MODULE[ \t]+[A-Z][A-Z0-9_]*" _colm2024_module_lines + "${_colm2024_preprocessed_src_upper}") + foreach(_colm2024_module_line IN LISTS _colm2024_module_lines) + if(_colm2024_module_line MATCHES "MODULE[ \t]+PROCEDURE") + continue() + endif() + string(REGEX REPLACE ".*MODULE[ \t]+([A-Z][A-Z0-9_]*).*" "\\1" _colm2024_module_name + "${_colm2024_module_line}") + set(COLM2024_MODULE_SOURCE_${_colm2024_module_name} ${_colm2024_src_rel}) + endforeach() + string(REGEX MATCHALL "(^|\n)[ \t]*USE[^\n]*" _colm2024_use_lines + "${_colm2024_preprocessed_src_upper}") + set(_colm2024_source_uses) + foreach(_colm2024_use_line IN LISTS _colm2024_use_lines) + if(_colm2024_use_line MATCHES "INTRINSIC") + continue() + endif() + if(_colm2024_use_line MATCHES "USE[ \t]*(,[^:]*)?(::)?[ \t]*([A-Z][A-Z0-9_]*)") + list(APPEND _colm2024_source_uses ${CMAKE_MATCH_3}) + endif() + endforeach() + if(_colm2024_source_uses) + list(REMOVE_DUPLICATES _colm2024_source_uses) + endif() + string(MAKE_C_IDENTIFIER "${_colm2024_src_rel}" _colm2024_src_key) + set(COLM2024_SOURCE_USES_${_colm2024_src_key} ${_colm2024_source_uses}) + endforeach() + set(ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES + physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 + physics/physics_colm2024/main/CoLMDRIVER.F90 + physics/physics_colm2024/main/CoLMMAIN.F90 + physics/physics_colm2024/main/MOD_MonthlyinSituCO2MaunaLoa.F90 + ) + foreach(_colm2024_root IN LISTS ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + if(NOT "${_colm2024_root}" IN_LIST COLM2024_AVAILABLE_SOURCES) + message(FATAL_ERROR "Required embedded CoLM2024 source is unavailable: ${_colm2024_root}") + endif() + endforeach() + + set(_colm2024_previous_source_count -1) + list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES _colm2024_source_count) + while(NOT _colm2024_previous_source_count EQUAL _colm2024_source_count) + set(_colm2024_previous_source_count ${_colm2024_source_count}) + foreach(_colm2024_src IN LISTS ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + string(MAKE_C_IDENTIFIER "${_colm2024_src}" _colm2024_src_key) + foreach(_colm2024_use IN LISTS COLM2024_SOURCE_USES_${_colm2024_src_key}) + if(DEFINED COLM2024_MODULE_SOURCE_${_colm2024_use}) + list(APPEND ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES + ${COLM2024_MODULE_SOURCE_${_colm2024_use}}) + endif() + endforeach() + endforeach() + list(REMOVE_DUPLICATES ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES _colm2024_source_count) + endwhile() + list(SORT ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + + list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SKIPPED_EMPTY_SOURCES _colm2024_skipped_empty_count) + list(LENGTH COLM2024_AVAILABLE_SOURCES _colm2024_available_source_count) + message(STATUS "CoLM2024 embedded CMake sources: ${_colm2024_source_count} of ${_colm2024_available_source_count}") + message(STATUS "CoLM2024 embedded CMake skipped empty sources: ${_colm2024_skipped_empty_count}") + + function(_colm2024_object_path out source) + set(${out} "${CMAKE_CURRENT_BINARY_DIR}/CMakeFiles/core_atmosphere.dir/${source}.o" PARENT_SCOPE) + endfunction() + + function(_colm2024_source_depends source) + if(NOT "${source}" IN_LIST ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + return() + endif() + set(_colm2024_deps) + foreach(_colm2024_dep IN LISTS ARGN) + if(NOT "${_colm2024_dep}" IN_LIST ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + continue() + endif() + _colm2024_object_path(_colm2024_dep_obj ${_colm2024_dep}) + list(APPEND _colm2024_deps ${_colm2024_dep_obj}) + endforeach() + if(_colm2024_deps) + set_property(SOURCE ${source} APPEND PROPERTY OBJECT_DEPENDS "${_colm2024_deps}") + endif() + endfunction() + + foreach(_colm2024_src IN LISTS ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES) + string(MAKE_C_IDENTIFIER "${_colm2024_src}" _colm2024_src_key) + set(_colm2024_dep_sources) + set(_colm2024_source_uses ${COLM2024_SOURCE_USES_${_colm2024_src_key}}) + foreach(_colm2024_use IN LISTS _colm2024_source_uses) + if(DEFINED COLM2024_MODULE_SOURCE_${_colm2024_use}) + set(_colm2024_dep_source ${COLM2024_MODULE_SOURCE_${_colm2024_use}}) + if(NOT _colm2024_dep_source STREQUAL _colm2024_src) + list(APPEND _colm2024_dep_sources ${_colm2024_dep_source}) + endif() + endif() + endforeach() + if(_colm2024_dep_sources) + list(REMOVE_DUPLICATES _colm2024_dep_sources) + _colm2024_source_depends(${_colm2024_src} ${_colm2024_dep_sources}) + endif() + endforeach() +endif() + # diagnostics/ set(ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES mpas_atm_diagnostic_template.F @@ -351,6 +492,7 @@ add_library(core_atmosphere ${ATMOSPHERE_CORE_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_NOAMP_UTILITY_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_NOAMP_MPAS_DRIVER_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES} ${ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES} @@ -365,9 +507,35 @@ set(CORE_ATMOSPHERE_COMPILE_DEFINITIONS if (${DO_PHYSICS}) list(APPEND CORE_ATMOSPHERE_COMPILE_DEFINITIONS DO_PHYSICS) endif () +if (MPAS_COLM2024) + list(APPEND CORE_ATMOSPHERE_COMPILE_DEFINITIONS MPAS_COLM2024) +endif () target_compile_definitions(core_atmosphere PRIVATE ${CORE_ATMOSPHERE_COMPILE_DEFINITIONS}) +if (MPAS_COLM2024) + target_include_directories(core_atmosphere PRIVATE ${COLM2024_SOURCE_ROOT}/include) + target_link_libraries(core_atmosphere PUBLIC NetCDF::NetCDF_Fortran NetCDF::NetCDF_C) + set_property(SOURCE ${ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES} + PROPERTY Fortran_PREPROCESS ON) + if(CMAKE_Fortran_COMPILER_ID MATCHES GNU) + set(_colm2024_compile_options -fdefault-real-8 -ffree-line-length-none) + elseif(CMAKE_Fortran_COMPILER_ID MATCHES Intel) + set(_colm2024_compile_options -real-size 64) + elseif(CMAKE_Fortran_COMPILER_ID MATCHES NVHPC) + set(_colm2024_compile_options -r8) + endif() + if(_colm2024_compile_options) + set_property(SOURCE ${ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES} + APPEND PROPERTY COMPILE_OPTIONS ${_colm2024_compile_options}) + endif() +endif () set_MPAS_DEBUG_flag(core_atmosphere) -mpas_core_target(CORE atmosphere TARGET core_atmosphere INCLUDES ${ATMOSPHERE_CORE_INCLUDES}) +set(ATMOSPHERE_REGISTRY_DEPENDS + ${CMAKE_CURRENT_SOURCE_DIR}/diagnostics/Registry_diagnostics.xml + ${CMAKE_CURRENT_SOURCE_DIR}/physics/Registry_noahmp.xml + ${CMAKE_CURRENT_SOURCE_DIR}/physics/Registry_colm2024.xml) +mpas_core_target(CORE atmosphere TARGET core_atmosphere + INCLUDES ${ATMOSPHERE_CORE_INCLUDES} + REGISTRY_DEPENDS ${ATMOSPHERE_REGISTRY_DEPENDS}) #Get physics_wrf tables from MPAS-Data include(FetchContent) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index bb2bd2c2e7..332823e86c 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -48,6 +48,7 @@ post_build: physcore: mpas_atm_dimensions.o ( cd physics; $(MAKE) all ) + $(RM) -r libphys ( 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* .) @@ -55,6 +56,7 @@ physcore: mpas_atm_dimensions.o chemcore: ( cd chemistry; $(MAKE) all CHEMISTRY="$(CHEMISTRY)" ) + $(RM) -r libchem ( mkdir libchem; cd libchem; ar -x ../chemistry/libchem.a ) dycore: mpas_atm_dimensions.o $(PHYSCORE) $(CHEMCORE) @@ -67,6 +69,7 @@ utilities: $(PHYSCORE) ( cd utils; $(MAKE) all PHYSICS="$(PHYSICS)" ) atmcore: $(PHYSCORE) dycore diagcore $(OBJS) + $(RM) libdycore.a ar -ru libdycore.a $(OBJS) dynamics/*.o $(PHYS_OBJS) $(CHEM_OBJS) diagnostics/*.o mpas_atm_core_interface.o: mpas_atm_core.o diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 425e0349d1..2200b7ed12 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -474,6 +474,7 @@ + @@ -496,9 +497,9 @@ - @@ -599,9 +600,9 @@ - @@ -647,11 +648,11 @@ #endif - @@ -924,9 +925,9 @@ #endif - @@ -997,6 +998,14 @@ + + + + + + + + @@ -1018,19 +1027,25 @@ + + + + + + #endif - @@ -1157,9 +1172,9 @@ #endif - @@ -1170,9 +1185,9 @@ #endif - @@ -1694,7 +1709,7 @@ description="Moist potential temperature: theta*(1+q_v*R_v/R_d)"/> - + #ifndef MPAS_CAM_DYCORE @@ -2024,7 +2039,7 @@ - + @@ -2060,7 +2075,7 @@ description="Tendency of surface pressure"/> - + #ifndef MPAS_CAM_DYCORE @@ -2093,7 +2108,7 @@ description="Tendency of cloud ice number concentration multiplied by dry air density divided by d(zeta)/dz" packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in"/> - @@ -2109,7 +2124,7 @@ description="Tendency of water-friendly aerosol number concentration multiplied by dry air density divided by d(zeta)/dz" packages="mp_thompson_aers_in"/> - @@ -2226,8 +2241,8 @@ + description="number of soil layers in the selected land surface scheme" + possible_values="For Noah and Noah-MP use 4; for CoLM2024 use its 10 native soil layers."/> - + + possible_values="`suite',`sf_noah',`sf_noahmp`, `sf_colm2024`, `off'"/> + + + + @@ -2988,8 +3010,8 @@ description="flag indicating the PBL regime (stable,unstable,...)" packages="sfclayer"/> - + + + + + + + + @@ -3451,8 +3485,8 @@ - + @@ -3543,7 +3577,7 @@ - + #ifdef DO_PHYSICS @@ -3970,7 +4004,7 @@ #endif - + @@ -4017,5 +4051,6 @@ #ifdef DO_PHYSICS #include "physics/Registry_noahmp.xml" +#include "physics/Registry_colm2024.xml" #endif diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index eef1951e36..c7b80f0fe0 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -591,7 +591,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) call physics_run_init(block % configs, mesh, state, clock, stream_manager) !initialization of all physics: - call physics_init(dminfo, stream_manager, clock, block % configs, mesh, diag, tend, tend_physics, state, 1, & + call physics_init(dminfo, stream_manager, clock, block, block % configs, mesh, diag, tend, tend_physics, state, 1, & diag_physics, diag_physics_noahmp, ngw_input, atm_input, sfc_input, output_noahmp) endif #endif @@ -626,6 +626,9 @@ function atm_core_run(domain) result(ierr) use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_atm_boundaries, only : mpas_atm_update_bdy_tend use mpas_atm_diagnostics_manager, only : mpas_atm_diag_update, mpas_atm_diag_compute, mpas_atm_diag_reset +#ifdef DO_PHYSICS + use mpas_atmphys_finalize, only : atmphys_write_restart +#endif implicit none @@ -859,6 +862,12 @@ function atm_core_run(domain) result(ierr) call mpas_timer_start('stream_output') call mpas_dmpar_get_time(output_start_time) +#ifdef DO_PHYSICS + if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='restart', & + direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then + call atmphys_write_restart(domain % blocklist % configs) + end if +#endif call mpas_stream_mgr_write(domain % streamManager, ierr=ierr) call mpas_dmpar_get_time(output_stop_time) call mpas_timer_stop('stream_output') @@ -1850,4 +1859,3 @@ subroutine atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_ end subroutine atm_initialize_deformation_weights end module atm_core - diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 2b7422ddec..c0143db0e0 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -4,9 +4,54 @@ ifeq ($(CORE),atmosphere) COREDEF = -Dmpas endif +ifneq (,$(findstring -DMPAS_COLM2024,$(CPPFLAGS))) +COLM2024_ENABLED = true +COLM2024_CORE = core_physics_colm2024_embedded +COLM2024_BUILD_DIR = physics_colm2024/.mpas_bld +COLM2024_HEADER = physics_colm2024/include/define.h +COLM2024_STAMP = $(COLM2024_BUILD_DIR)/.built +NF_CONFIG ?= nf-config +COLM2024_NETCDF_INC ?= $(shell $(NF_CONFIG) --includedir 2>/dev/null || nc-config --includedir 2>/dev/null) +COLM2024_INCLUDES = -I./physics_colm2024/include -I./$(COLM2024_BUILD_DIR) +ifneq ($(strip $(COLM2024_NETCDF_INC)),) +COLM2024_INCLUDES += -I$(COLM2024_NETCDF_INC) +endif +ifneq ($(strip $(PNETCDF)),) +COLM2024_INCLUDES += -I$(PNETCDF)/include +endif +ifneq ($(strip $(PNETCDF_INC)),) +COLM2024_INCLUDES += -I$(PNETCDF_INC) +endif +COLM2024_FC_NAME := $(notdir $(firstword $(FC))) +COLM2024_FC_VERSION := $(shell $(FC) --version 2>/dev/null | sed -n '1p') +COLM2024_FC_ID_TEXT = $(COLM2024_FC_NAME) $(COLM2024_FC_VERSION) +COLM2024_FOPTS_BASE = $(CPPFLAGS) $(COREDEF) $(FFLAGS) +ifneq (,$(strip $(findstring gfortran,$(COLM2024_FC_ID_TEXT)) $(findstring GNU Fortran,$(COLM2024_FC_ID_TEXT)))) +COLM2024_FOPTS ?= $(COLM2024_FOPTS_BASE) -std=legacy -fno-implicit-none -fdefault-real-8 -fdefault-double-8 -ffree-form -cpp -ffree-line-length-0 +COLM2024_MOD_FLAGS ?= -J$(COLM2024_BUILD_DIR) +else ifneq (,$(strip $(filter ifort ifx mpiifort mpiifx,$(COLM2024_FC_NAME)) $(findstring Intel,$(COLM2024_FC_ID_TEXT)))) +COLM2024_FOPTS ?= $(COLM2024_FOPTS_BASE) -real-size 64 -free -fpp +COLM2024_MOD_FLAGS ?= -module $(COLM2024_BUILD_DIR) +else ifneq (,$(strip $(filter nvfortran pgfortran pgf90,$(COLM2024_FC_NAME)) $(findstring nvfortran,$(COLM2024_FC_ID_TEXT)) $(findstring NVIDIA,$(COLM2024_FC_ID_TEXT)))) +COLM2024_FOPTS ?= $(COLM2024_FOPTS_BASE) -r8 -Mfree -Mpreprocess +COLM2024_MOD_FLAGS ?= -module $(COLM2024_BUILD_DIR) +else +COLM2024_FOPTS ?= $(COLM2024_FOPTS_BASE) +COLM2024_MOD_FLAGS ?= -J$(COLM2024_BUILD_DIR) +endif +COLM2024_SOURCE_DIRS = \ + physics_colm2024/share \ + physics_colm2024/main \ + physics_colm2024/main/HYDRO \ + physics_colm2024/main/ParaOpt \ + physics_colm2024/drivers/mpas +COLM2024_SOURCES = $(foreach dir,$(COLM2024_SOURCE_DIRS),$(wildcard $(dir)/*.F90)) +endif + all: ./../tools/manage_externals/checkout_externals --externals ./../Externals.cfg - $(MAKE) lookup_tables core_physics_init core_physics_mmm core_UGWP core_physics_wrf core_physics_noahmp core_physics + $(RM) libphys.a + $(MAKE) lookup_tables $(COLM2024_CORE) core_physics_init core_physics_mmm core_UGWP core_physics_wrf core_physics_noahmp core_physics dummy: echo "****** compiling physics ******" @@ -27,6 +72,7 @@ OBJS = \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_lsm_noahmp.o \ + mpas_atmphys_driver_lsm_colm2024.o \ mpas_atmphys_driver_microphysics.o \ mpas_atmphys_driver_oml.o \ mpas_atmphys_driver_pbl.o \ @@ -71,9 +117,124 @@ core_physics_noahmp: (cd physics_noahmp/src; $(MAKE) all COREDEF="$(COREDEF)") (cd physics_noahmp/drivers/mpas; $(MAKE) all COREDEF="$(COREDEF)") +ifeq "$(COLM2024_ENABLED)" "true" +COLM2024_OBJS_SHARED_NAMES = \ + MOD_Precision.o \ + MOD_MPAS_MPI.o \ + MOD_Utils.o \ + MOD_Namelist.o \ + MOD_Vars_Global.o \ + MOD_Const_Physical.o \ + MOD_Const_LC.o \ + MOD_IncompleteGamma.o \ + MOD_UserDefFun.o \ + MOD_TimeManager.o \ + MOD_Const_PFT.o \ + MOD_NetCDFSerial.o \ + MOD_Block.o \ + MOD_Grid.o \ + MOD_Pixel.o \ + MOD_DataType.o \ + MOD_NetCDFBlock.o \ + MOD_Mesh.o \ + MOD_Pixelset.o \ + MOD_NetCDFVector.o \ + MOD_SpatialMapping.o \ + MOD_ComputePushData.o \ + MOD_LandElm.o \ + MOD_LandPatch.o \ + MOD_LandPFT.o \ + MOD_LandUrban.o \ + MOD_SrfdataRestart.o + +COLM2024_OBJS_BASIC_NAMES = \ + MOD_Grid_RiverLakeNetwork.o \ + MOD_Grid_Reservoir.o \ + MOD_Grid_RiverLakeTimeVars.o \ + MOD_Vars_TimeInvariants.o \ + MOD_Vars_TimeVariables.o \ + MOD_Vars_1DPFTFluxes.o \ + MOD_Vars_1DFluxes.o \ + MOD_Vars_1DForcing.o \ + MOD_Hydro_SoilFunction.o \ + MOD_Hydro_SoilWater.o \ + MOD_Eroot.o \ + MOD_Qsadv.o \ + MOD_LAIEmpirical.o \ + MOD_LAIReadin.o \ + MOD_OrbCoszen.o \ + MOD_3DCanopyRadiation.o \ + MOD_Aerosol.o \ + MOD_SnowSnicar.o \ + MOD_Albedo.o \ + MOD_SnowFraction.o \ + MOD_MonthlyinSituCO2MaunaLoa.o + +COLM2024_OBJS_MAIN_NAMES = \ + MOD_Opt_Baseflow.o \ + MOD_AssimStomataConductance.o \ + MOD_PlantHydraulic.o \ + MOD_FrictionVelocity.o \ + MOD_TurbulenceLEddy.o \ + MOD_Ozone.o \ + MOD_CanopyLayerProfile.o \ + MOD_LeafTemperature.o \ + MOD_LeafTemperaturePC.o \ + MOD_SoilThermalParameters.o \ + MOD_Hydro_VIC_Variables.o \ + MOD_Hydro_VIC.o \ + MOD_Runoff.o \ + MOD_SoilSnowHydrology.o \ + MOD_SnowLayersCombineDivide.o \ + MOD_PhaseChange.o \ + MOD_Glacier.o \ + MOD_Lake.o \ + MOD_SimpleOcean.o \ + MOD_GroundFluxes.o \ + MOD_GroundTemperature.o \ + MOD_LeafInterception.o \ + MOD_NetSolar.o \ + MOD_WetBulb.o \ + MOD_RainSnowTemp.o \ + MOD_SoilSurfaceResistance.o \ + MOD_NewSnow.o \ + MOD_Thermal.o \ + MOD_Grid_RiverLakeFlow.o \ + CoLMDRIVER.o \ + MOD_CoLM_MPAS_Interface.o \ + CoLMMAIN.o + +COLM2024_OBJ_NAMES = $(COLM2024_OBJS_SHARED_NAMES) $(COLM2024_OBJS_BASIC_NAMES) $(COLM2024_OBJS_MAIN_NAMES) +COLM2024_OBJS = $(addprefix $(COLM2024_BUILD_DIR)/,$(COLM2024_OBJ_NAMES)) + +.PHONY: core_physics_colm2024_embedded +core_physics_colm2024_embedded: $(COLM2024_STAMP) + +$(COLM2024_BUILD_DIR): + mkdir -p $(COLM2024_BUILD_DIR) + +$(COLM2024_STAMP): $(COLM2024_HEADER) $(COLM2024_SOURCES) | $(COLM2024_BUILD_DIR) + @echo 'compiling embedded CoLM2024 physics >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>' + @set -e; \ + for obj in $(COLM2024_OBJ_NAMES); do \ + src=""; \ + stem="$${obj%.o}"; \ + for dir in $(COLM2024_SOURCE_DIRS); do \ + if [ -f "$$dir/$$stem.F90" ]; then src="$$dir/$$stem.F90"; break; fi; \ + done; \ + if [ -z "$$src" ]; then \ + echo "CoLM2024 source not found for $$obj"; \ + exit 1; \ + fi; \ + echo " $$src"; \ + $(FC) -c $(COLM2024_FOPTS) $(COLM2024_INCLUDES) -o "$(COLM2024_BUILD_DIR)/$$obj" "$$src" $(COLM2024_MOD_FLAGS); \ + done; \ + touch $@ +endif + core_physics_init: $(OBJS_init) -core_physics: core_physics_wrf core_physics_noahmp +core_physics: core_physics_wrf core_physics_noahmp $(COLM2024_CORE) ($(MAKE) phys_interface COREDEF="$(COREDEF)") ar -ru libphys.a $(OBJS_init) $(OBJS) ($(MAKE) -C ./physics_mmm -f Makefile.mpas physics_mmm_lib) @@ -81,6 +242,9 @@ core_physics: core_physics_wrf core_physics_noahmp ($(MAKE) -C ./physics_noahmp/drivers/mpas driver_lib) ($(MAKE) -C ./physics_noahmp/src src_lib) ($(MAKE) -C ./physics_noahmp/utility utility_lib) +ifeq "$(COLM2024_ENABLED)" "true" + ar -ru libphys.a $(COLM2024_OBJS) +endif phys_interface: $(OBJS) @@ -99,6 +263,7 @@ mpas_atmphys_driver.o: \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_lsm_noahmp.o \ + mpas_atmphys_driver_lsm_colm2024.o \ mpas_atmphys_driver_pbl.o \ mpas_atmphys_driver_radiation_lw.o \ mpas_atmphys_driver_radiation_sw.o \ @@ -175,7 +340,8 @@ mpas_atmphys_driver_sfclayer.o: \ mpas_atmphys_vars.o mpas_atmphys_finalize.o: \ - mpas_atmphys_lsm_noahmpfinalize.o + mpas_atmphys_lsm_noahmpfinalize.o \ + mpas_atmphys_driver_lsm_colm2024.o mpas_atmphys_init.o: \ mpas_atmphys_driver_convection.o \ @@ -186,6 +352,7 @@ mpas_atmphys_init.o: \ mpas_atmphys_driver_radiation_sw.o \ mpas_atmphys_driver_sfclayer.o \ mpas_atmphys_lsm_noahmpinit.o \ + mpas_atmphys_driver_lsm_colm2024.o \ mpas_atmphys_landuse.o \ mpas_atmphys_o3climatology.o \ mpas_atmphys_vars.o @@ -209,6 +376,8 @@ mpas_atmphys_lsm_noahmpinit.o: \ mpas_atmphys_lsm_noahmpfinalize.o : \ mpas_atmphys_vars.o +mpas_atmphys_driver_lsm_colm2024.o : mpas_atmphys_utilities.o $(COLM2024_STAMP) + mpas_atmphys_manager.o: \ mpas_atmphys_constants.o \ mpas_atmphys_o3climatology.o \ @@ -253,6 +422,7 @@ clean: ( cd physics_noahmp/drivers/mpas; $(MAKE) clean ) ( cd physics_noahmp/src; $(MAKE) clean ) ( cd physics_noahmp/utility; $(MAKE) clean ) + $(RM) -r physics_colm2024/.mpas_bld ( if [ -d physics_noaa/UGWP ]; then cd physics_noaa/UGWP; $(MAKE) clean; fi ) @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process @@ -262,7 +432,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) -I../../framework $< > $*.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./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) $(COLM2024_INCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) else - $(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./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) + $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) $(COLM2024_INCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) endif diff --git a/src/core_atmosphere/physics/Registry_colm2024.xml b/src/core_atmosphere/physics/Registry_colm2024.xml new file mode 100644 index 0000000000..77bbe168b4 --- /dev/null +++ b/src/core_atmosphere/physics/Registry_colm2024.xml @@ -0,0 +1,47 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index b3162019e5..ee18c0c52b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -52,7 +52,7 @@ module mpas_atmphys_control ! * renamed "kain_fritsch" to "cu_kain_fritsch" and "tiedtke" to "cu_tiedtke". ! Laura D. Fowler (laura@ucar.edu) / 2016-03-22. ! * renamed "ysu" to "bl_ysu", "ysu_gwdo" to "bl_gwdo_ysu", and "monin_obukhov" to "sf_monin_obukhov". -! Laura D. Fowler (laura@ucar.edu) / 2016-03-25. +! Laura D. Fowler (laura@ucar.edu) / 2016-03-25. ! * added the option mp_thompson. ! Laura D. Fowler (laura@ucar.edu) / 2016-03-25. ! * added the option cu_grell_freitas. @@ -224,7 +224,7 @@ subroutine physics_namelist_check(configs) if(.not. (config_radt_lw_scheme .eq. 'off' .or. & config_radt_lw_scheme .eq. 'cam_lw' .or. & config_radt_lw_scheme .eq. 'rrtmg_lw')) then - + write(mpas_err_message,'(A,A20)') 'illegal value for longwave radiation scheme: ', & trim(config_radt_lw_scheme) call physics_error_fatal(mpas_err_message) @@ -235,7 +235,7 @@ subroutine physics_namelist_check(configs) if(.not. (config_radt_sw_scheme .eq. 'off' .or. & config_radt_sw_scheme .eq. 'cam_sw' .or. & config_radt_sw_scheme .eq. 'rrtmg_sw')) then - + write(mpas_err_message,'(A,A20)') 'illegal value for shortwave radiation _scheme: ', & trim(config_radt_sw_scheme) call physics_error_fatal(mpas_err_message) @@ -272,7 +272,7 @@ subroutine physics_namelist_check(configs) config_sfclayer_scheme .eq. 'sf_mynn' .or. & config_sfclayer_scheme .eq. 'sf_monin_obukhov' .or. & config_sfclayer_scheme .eq. 'sf_monin_obukhov_rev')) then - + write(mpas_err_message,'(A,A20)') 'illegal value for surface layer scheme: ', & trim(config_sfclayer_scheme) call physics_error_fatal(mpas_err_message) @@ -292,14 +292,15 @@ subroutine physics_namelist_check(configs) !land-surface scheme: note that config_sfclayer_scheme must be defined for the land-surface !scheme to be called: if(config_lsm_scheme .ne. 'off' .and. config_sfclayer_scheme .eq. 'off') then - + 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' .or. & - config_lsm_scheme .eq. 'sf_noahmp')) then - + config_lsm_scheme .eq. 'sf_noahmp' .or. & + config_lsm_scheme .eq. 'sf_colm2024')) then + write(mpas_err_message,'(A,A20)') 'illegal value for land surface scheme: ', & trim(config_lsm_scheme) call physics_error_fatal(mpas_err_message) @@ -308,7 +309,7 @@ subroutine physics_namelist_check(configs) !checks if any physics process is called. if not, return: moist_physics = .true. - + if(config_microp_scheme .eq. 'off' .and. & config_convection_scheme .eq. 'off' .and. & config_lsm_scheme .eq. 'off' .and. & @@ -351,7 +352,9 @@ subroutine physics_registry_init(mesh,configs,sfc_input) real(kind=RKIND),dimension(:,:),pointer:: dzs !local variables: - integer:: iCell + integer,parameter:: colm_soil_levels = 10 + integer:: iCell,iSoil + real(kind=RKIND):: colm_z(colm_soil_levels),colm_dz(colm_soil_levels) !----------------------------------------------------------------------------------------------------------------- @@ -363,25 +366,44 @@ subroutine physics_registry_init(mesh,configs,sfc_input) call mpas_pool_get_array(sfc_input,'landmask',landmask) call mpas_pool_get_array(sfc_input,'dzs' , dzs ) + if(trim(config_lsm_scheme) == "sf_colm2024" .and. size(dzs,1) /= colm_soil_levels) then + call physics_error_fatal("CoLM2024 requires num_soil_layers=10 so MPAS retains the complete native soil column.") + endif + !initialization of input variables, if needed: if(.not. config_do_restart) then lsm_select: select case(trim(config_lsm_scheme)) - 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 - dzs(2,iCell) = 0.30_RKIND - dzs(3,iCell) = 0.60_RKIND - dzs(4,iCell) = 1.00_RKIND - enddo + case("sf_noah","sf_noahmp") + if(size(dzs,1) < 4) then + call physics_error_fatal("Noah/Noah-MP requires at least four MPAS soil layers.") + endif + do iCell = 1, nCells + dzs(1,iCell) = 0.10_RKIND + dzs(2,iCell) = 0.30_RKIND + dzs(3,iCell) = 0.60_RKIND + dzs(4,iCell) = 1.00_RKIND + enddo + + case("sf_colm2024") + do iSoil = 1, colm_soil_levels + colm_z(iSoil) = 0.025_RKIND * (exp(0.5_RKIND * (real(iSoil,RKIND)-0.5_RKIND)) - 1._RKIND) + enddo + colm_dz(1) = 0.5_RKIND * (colm_z(1) + colm_z(2)) + do iSoil = 2, colm_soil_levels-1 + colm_dz(iSoil) = 0.5_RKIND * (colm_z(iSoil+1) - colm_z(iSoil-1)) + enddo + colm_dz(colm_soil_levels) = colm_z(colm_soil_levels) - colm_z(colm_soil_levels-1) + do iCell = 1, nCells + dzs(:,iCell) = colm_dz + enddo case default - + end select lsm_select - + endif !call mpas_log_write('--- enter subroutine physics_namelist_check.') @@ -535,4 +557,3 @@ end subroutine physics_compatibility_check !================================================================================================================= end module mpas_atmphys_control !================================================================================================================= - diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 8e31672657..8020480685 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -15,9 +15,10 @@ module mpas_atmphys_driver use mpas_atmphys_driver_gwdo use mpas_atmphys_driver_lsm use mpas_atmphys_driver_lsm_noahmp + use mpas_atmphys_driver_lsm_colm2024,only: push_lsm_colm2024, step_lsm_colm2024, pull_lsm_colm2024 use mpas_atmphys_driver_pbl use mpas_atmphys_driver_radiation_lw - use mpas_atmphys_driver_radiation_sw + use mpas_atmphys_driver_radiation_sw use mpas_atmphys_driver_seaice,only: allocate_seaice,deallocate_seaice,driver_seaice use mpas_atmphys_driver_sfclayer use mpas_atmphys_driver_oml @@ -122,9 +123,10 @@ subroutine physics_driver(domain,itimestep,xtime_s) type(mpas_pool_type),pointer:: configs, & mesh, & state, & - diag, & - diag_physics, & - diag_physics_noahmp, & + diag, & + diag_physics, & + diag_physics_colm2024, & + diag_physics_noahmp, & output_noahmp, & tend_physics, & atm_input, & @@ -169,18 +171,218 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_config(domain%configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) call mpas_pool_get_config(domain%configs,'config_bucket_radt' ,config_bucket_radt ) call mpas_pool_get_config(domain%configs,'config_bucket_update' ,config_bucket_update ) - call mpas_pool_get_config(domain%configs,'config_frac_seaice' ,config_frac_seaice ) + call mpas_pool_get_config(domain%configs,'config_frac_seaice' ,config_frac_seaice ) call mpas_pool_get_config(domain%configs,'config_oml1d' ,config_oml1d ) - if(config_convection_scheme .ne. 'off' .or. & - config_lsm_scheme .ne. 'off' .or. & - config_pbl_scheme .ne. 'off' .or. & - config_radt_lw_scheme .ne. 'off' .or. & - config_radt_sw_scheme .ne. 'off' .or. & - config_sfclayer_scheme .ne. 'off') then - - block => domain % blocklist - do while(associated(block)) + if(config_convection_scheme .ne. 'off' .or. & + config_lsm_scheme .ne. 'off' .or. & + config_pbl_scheme .ne. 'off' .or. & + config_radt_lw_scheme .ne. 'off' .or. & + config_radt_sw_scheme .ne. 'off' .or. & + config_sfclayer_scheme .ne. 'off') then + + if(config_lsm_scheme == 'sf_colm2024') then + + 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,'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,'ngw_input' ,ngw_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,'cellSolveThreadStart',cellSolveThreadStart) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadEnd',cellSolveThreadEnd) + + call allocate_forall_physics(block%configs) + time_lev = 1 + + !$OMP PARALLEL DO + do thread=1,nThreads + call MPAS_to_physics(block%configs,mesh,state,time_lev,diag,diag_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + + if(l_radtlw .or. l_radtsw) then + call allocate_cloudiness + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_cloudiness(block%configs,mesh,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + endif + + if(l_radtsw) then + time_lev = 1 + call allocate_radiation_sw(block%configs,xtime_s) + !$OMP PARALLEL DO + 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)) + end do + !$OMP END PARALLEL DO + endif + + if(l_radtlw) then + time_lev = 1 + call allocate_radiation_lw(block%configs,xtime_s) + !$OMP PARALLEL DO + 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)) + end do + !$OMP END PARALLEL DO + endif + + if(config_bucket_update /= 'none' .and. config_bucket_radt .gt. 0._RKIND) then + !$OMP PARALLEL DO + do thread=1,nThreads + call update_radiation_diagnostics(block%configs,mesh,diag_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + endif + + if(config_radt_sw_scheme.ne.'off' .or. config_radt_lw_scheme.ne.'off') & + call deallocate_cloudiness + if(config_radt_sw_scheme.ne.'off') call deallocate_radiation_sw(block%configs) + if(config_radt_lw_scheme.ne.'off') call deallocate_radiation_lw(block%configs) + + if(config_sfclayer_scheme .ne. 'off') then + call allocate_sfclayer(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + call deallocate_sfclayer(block%configs) + endif + + if(config_oml1d) call driver_oml1d(block%configs,mesh,diag,diag_physics,sfc_input) + + call push_lsm_colm2024(block,block%configs,mesh,state,time_lev,diag,diag_physics,atm_input, & + sfc_input,cellSolveThreadStart(1),cellSolveThreadEnd(nThreads)) + + call deallocate_forall_physics(block%configs) + block => block % next + end do + + call step_lsm_colm2024() + + 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,'diag_physics_colm2024',diag_physics_colm2024) + 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,'sfc_input' ,sfc_input ) + call mpas_pool_get_subpool(block%structs,'ngw_input' ,ngw_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,'cellSolveThreadStart',cellSolveThreadStart) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadEnd',cellSolveThreadEnd) + + call allocate_forall_physics(block%configs) + time_lev = 1 + + !$OMP PARALLEL DO + do thread=1,nThreads + call MPAS_to_physics(block%configs,mesh,state,time_lev,diag,diag_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + + call pull_lsm_colm2024(block,diag_physics,diag_physics_colm2024,sfc_input, & + cellSolveThreadStart(1),cellSolveThreadEnd(nThreads)) + + call allocate_seaice(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_seaice(block%configs,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + enddo + !$OMP END PARALLEL DO + call deallocate_seaice(block%configs) + + !$OMP PARALLEL DO + do thread=1,nThreads + call atmphys_sfc_diagnostics(block%configs,mesh,diag,diag_physics,sfc_input,output_noahmp, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + enddo + !$OMP END PARALLEL DO + + if(config_pbl_scheme .ne. 'off' .and. config_sfclayer_scheme .ne. 'off') then + call allocate_pbl(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_pbl(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + call deallocate_pbl(block%configs) + endif + + if(config_gwdo_scheme .ne. 'off') then + call allocate_gwdo(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_gwdo(itimestep,block%configs,mesh,sfc_input,ngw_input,diag_physics, & + tend_physics,cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + call deallocate_gwdo(block%configs) + endif + + !$OMP PARALLEL DO + do thread=1,nThreads + call update_convection_step1(block%configs,diag_physics,tend_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + if(l_conv) then + call allocate_convection(block%configs) + !$OMP PARALLEL DO + do thread=1,nThreads + call driver_convection(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + call deallocate_convection(block%configs) + endif + if(config_convection_scheme .ne. 'off') then + !$OMP PARALLEL DO + do thread=1,nThreads + call update_convection_step2(block%configs,diag_physics, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + end do + !$OMP END PARALLEL DO + end if + + call deallocate_forall_physics(block%configs) + block => block % next + end do + + else + + 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 ) @@ -297,7 +499,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) diag_physics_noahmp,output_noahmp,sfc_input,itimestep, & cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) enddo - endif + endif call allocate_seaice(block%configs) !$OMP PARALLEL DO @@ -372,9 +574,10 @@ subroutine physics_driver(domain,itimestep,xtime_s) call deallocate_forall_physics(block%configs) block => block % next - end do + end do + endif - endif + endif call mpas_timer_stop('physics driver') diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F new file mode 100644 index 0000000000..742d6cd16a --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F @@ -0,0 +1,1079 @@ +! 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_colm2024 + use mpas_kind_types + use mpas_derived_types, only: block_type, dm_info + use mpas_pool_routines + use mpas_timekeeping, only: MPAS_Clock_type, MPAS_Time_type, MPAS_START_TIME, MPAS_STOP_TIME, & + mpas_get_clock_time, mpas_get_time + use, intrinsic :: ieee_arithmetic, only: ieee_is_finite + + use mpas_atmphys_constants, only: R_d, R_v, cp + use mpas_atmphys_utilities, only: physics_error_fatal + use mpas_atmphys_vars, only: dt_pbl, xice_threshold + +#ifdef MPAS_COLM2024 + use mpi, only: MPI_COMM_NULL, MPI_SUCCESS, MPI_Comm_dup, MPI_Comm_free + use MOD_Precision, only: colm_r8 => r8 + use MOD_CoLM_MPAS_Interface, only: colm_mpas_initialize_from_namelist, colm_mpas_ready, & + colm_mpas_set_element_forcing, & + colm_mpas_step, colm_mpas_get_element_surface, & + colm_mpas_get_element_boundary_state, & + colm_mpas_get_element_state, & + colm_mpas_get_element_river_state, & + colm_mpas_force_restart, & + colm_mpas_finalize + use MOD_Vars_Global, only: colm_nl_soil => nl_soil, colm_dz_soi => dz_soi, colm_z_soi => z_soi + use MOD_Const_Physical, only: colm_denh2o => denh2o, colm_denice => denice + use MOD_TimeManager, only: colm_ticktime => ticktime, colm_adj2begin => adj2begin, & + colm_adj2end => adj2end, & + colm_julian2monthday => julian2monthday + use MOD_MonthlyinSituCO2MaunaLoa, only: colm_init_monthly_co2_mlo => init_monthly_co2_mlo, & + colm_get_monthly_co2_mlo => get_monthly_co2_mlo + use MOD_Namelist, only: colm_use_ozone_data => DEF_USE_OZONEDATA, & + colm_use_cbl_height => DEF_USE_CBL_HEIGHT +#endif + + implicit none + private + public :: init_lsm_colm2024, push_lsm_colm2024, step_lsm_colm2024, pull_lsm_colm2024 + public :: checkpoint_lsm_colm2024, finalize_lsm_colm2024 + + logical, save :: colm_update_lai_next_step = .true. +#ifdef MPAS_COLM2024 + type colm_block_map_type + integer :: local_block_id = -1 + integer, allocatable :: element_for_cell(:) + type(colm_block_map_type), pointer :: next => null() + end type colm_block_map_type + + type(colm_block_map_type), pointer, save :: colm_block_maps => null() + logical, save :: colm_initialized = .false. + integer, save :: colm_mpas_comm = MPI_COMM_NULL + integer, save :: colm_step_idate(3) = -1 +#endif + + contains + +!================================================================================================================= + subroutine init_lsm_colm2024(dminfo,configs,clock,block) +!================================================================================================================= + + type(dm_info),intent(in):: dminfo + type(mpas_pool_type),intent(in):: configs + type(MPAS_Clock_type),intent(in):: clock + type(block_type),intent(in):: block +#ifdef MPAS_COLM2024 + logical :: colm_ready + logical,pointer:: config_do_restart + integer :: colm_ierr + integer :: mpas_domain_comm + integer :: mpi_ierr + integer :: colm_patch_count + integer :: block_cells + integer :: n_mpas_cells + integer :: offset + integer :: start_year, start_month, start_day, start_doy + integer :: start_hour, start_minute, start_second, start_second_num, start_second_den + integer :: stop_year, stop_doy + integer :: stop_hour, stop_minute, stop_second, stop_second_num, stop_second_den + integer :: mpas_start_idate(3), mpas_stop_idate(3) + character(len=StrKIND),pointer:: config_colm2024_namelist + character(len=StrKIND),pointer:: config_calendar_type + character(len=StrKIND),pointer:: config_pbl_scheme + character(len=StrKIND),pointer:: config_radt_lw_scheme + character(len=StrKIND),pointer:: config_radt_sw_scheme + character(len=StrKIND),pointer:: config_sfclayer_scheme + integer,pointer:: nCellsSolve + integer,dimension(:),pointer:: indexToCellID + integer,allocatable:: cell_to_element(:), mpas_cell_id(:) + real(kind=RKIND),dimension(:),pointer:: latCell, lonCell + real(kind=colm_r8),allocatable:: mpas_cell_lat(:), mpas_cell_lon(:) + real(kind=colm_r8) :: mpas_colm_timestep + type(MPAS_Time_type):: start_time, stop_time + type(block_type),pointer:: block_cursor + type(colm_block_map_type),pointer:: block_map + type(mpas_pool_type),pointer:: block_mesh, block_diag_physics, block_diag_physics_colm2024, block_sfc_input +#endif + +#ifdef MPAS_COLM2024 + call mpas_pool_get_config(configs,'config_colm2024_namelist',config_colm2024_namelist) + call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) + if(trim(config_colm2024_namelist) == 'none' .or. trim(config_colm2024_namelist) == '') then + call physics_error_fatal("config_lsm_scheme='sf_colm2024' requires config_colm2024_namelist.") + endif + + call mpas_pool_get_config(configs,'config_pbl_scheme' ,config_pbl_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_config(configs,'config_sfclayer_scheme',config_sfclayer_scheme) + if(trim(config_radt_lw_scheme) == 'off') then + call physics_error_fatal("CoLM2024 requires an active MPAS longwave-radiation scheme.") + endif + if(trim(config_radt_sw_scheme) /= 'rrtmg_sw') then + call physics_error_fatal("CoLM2024 requires config_radt_sw_scheme='rrtmg_sw' for VIS/NIR direct/diffuse fluxes.") + endif + if(trim(config_sfclayer_scheme) == 'off') then + call physics_error_fatal("CoLM2024 requires an active MPAS surface-layer scheme for PBL coupling.") + endif + + if(colm_initialized) return + if(associated(block % next)) return + if(.not. associated(block % domain)) call physics_error_fatal("CoLM2024 MPAS block is missing its owning domain.") + + call mpas_pool_get_config(configs,'config_calendar_type',config_calendar_type) + if(trim(config_calendar_type) /= 'gregorian') then + call physics_error_fatal("CoLM2024 embedded time management requires config_calendar_type='gregorian'.") + endif + + start_time = mpas_get_clock_time(clock, MPAS_START_TIME, colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("Unable to obtain the MPAS start time for CoLM2024.") + call mpas_get_time(start_time, YYYY=start_year, MM=start_month, DD=start_day, DoY=start_doy, & + H=start_hour, M=start_minute, S=start_second, S_n=start_second_num, & + S_d=start_second_den, ierr=colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("Unable to decode the MPAS start time for CoLM2024.") + if(start_second_num /= 0) then + call physics_error_fatal("CoLM2024 embedded time management requires an integer-second MPAS start time.") + endif + mpas_start_idate = (/start_year, start_doy, start_hour * 3600 + start_minute * 60 + start_second/) + + stop_time = mpas_get_clock_time(clock, MPAS_STOP_TIME, colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("Unable to obtain the MPAS stop time for CoLM2024.") + call mpas_get_time(stop_time, YYYY=stop_year, DoY=stop_doy, H=stop_hour, M=stop_minute, & + S=stop_second, S_n=stop_second_num, S_d=stop_second_den, ierr=colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("Unable to decode the MPAS stop time for CoLM2024.") + if(stop_second_num /= 0) then + call physics_error_fatal("CoLM2024 embedded time management requires an integer-second MPAS stop time.") + endif + mpas_stop_idate = (/stop_year, stop_doy, stop_hour * 3600 + stop_minute * 60 + stop_second/) + call colm_adj2end(mpas_stop_idate) + + mpas_colm_timestep = real(dt_pbl, colm_r8) + if(.not. ieee_is_finite(mpas_colm_timestep) .or. mpas_colm_timestep <= 0._colm_r8 .or. & + mpas_colm_timestep > 3600._colm_r8) then + call physics_error_fatal("CoLM2024 requires an MPAS land-surface timestep in (0, 3600] seconds.") + endif + if(abs(mpas_colm_timestep - real(nint(mpas_colm_timestep), colm_r8)) > 1.e-6_colm_r8) then + call physics_error_fatal("CoLM2024 embedded time management requires an integer-second MPAS timestep.") + endif + + call colm2024_free_block_maps() + + n_mpas_cells = 0 + block_cursor => block % domain % blocklist + do while(associated(block_cursor)) + call mpas_pool_get_subpool(block_cursor % structs,'mesh',block_mesh) + call mpas_pool_get_dimension(block_mesh,'nCellsSolve',nCellsSolve) + n_mpas_cells = n_mpas_cells + nCellsSolve + block_cursor => block_cursor % next + enddo + allocate(mpas_cell_id(n_mpas_cells), mpas_cell_lat(n_mpas_cells), mpas_cell_lon(n_mpas_cells), & + cell_to_element(n_mpas_cells)) + + offset = 0 + block_cursor => block % domain % blocklist + do while(associated(block_cursor)) + call mpas_pool_get_subpool(block_cursor % structs,'mesh',block_mesh) + call mpas_pool_get_dimension(block_mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_array(block_mesh,'indexToCellID',indexToCellID) + call mpas_pool_get_array(block_mesh,'latCell',latCell) + call mpas_pool_get_array(block_mesh,'lonCell',lonCell) + + block_cells = nCellsSolve + if(block_cells > 0) then + mpas_cell_id(offset+1:offset+block_cells) = indexToCellID(1:block_cells) + mpas_cell_lat(offset+1:offset+block_cells) = real(latCell(1:block_cells), colm_r8) + mpas_cell_lon(offset+1:offset+block_cells) = real(lonCell(1:block_cells), colm_r8) + endif + call colm2024_add_block_map(block_cursor % localBlockID, size(indexToCellID)) + offset = offset + block_cells + block_cursor => block_cursor % next + enddo + +#ifdef MPAS_USE_MPI_F08 + mpas_domain_comm = dminfo % comm % mpi_val +#else + mpas_domain_comm = dminfo % comm +#endif + if(colm_mpas_comm /= MPI_COMM_NULL) then + call physics_error_fatal("CoLM2024 MPAS communication context was initialized more than once.") + endif + call MPI_Comm_dup(mpas_domain_comm, colm_mpas_comm, mpi_ierr) + if(mpi_ierr /= MPI_SUCCESS) then + call physics_error_fatal("MPAS could not create the CoLM2024 communication context.") + endif + + call colm_mpas_initialize_from_namelist(trim(config_colm2024_namelist), colm_ierr, & + mpas_comm=colm_mpas_comm, & + mpas_cell_id=mpas_cell_id, & + mpas_cell_lat=mpas_cell_lat, & + mpas_cell_lon=mpas_cell_lon, & + n_mpas_cells=n_mpas_cells, & + cell_to_element=cell_to_element, & + mpas_start_idate=mpas_start_idate, & + mpas_stop_idate=mpas_stop_idate, & + mpas_timestep=mpas_colm_timestep, & + mpas_is_restart=config_do_restart) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 initialization from config_colm2024_namelist failed.") + if(colm_use_cbl_height .and. trim(config_pbl_scheme) == 'off') then + call physics_error_fatal("CoLM2024 DEF_USE_CBL_HEIGHT requires an active MPAS PBL scheme.") + endif + call colm_init_monthly_co2_mlo() + + offset = 0 + block_cursor => block % domain % blocklist + do while(associated(block_cursor)) + call mpas_pool_get_subpool(block_cursor % structs,'mesh',block_mesh) + call mpas_pool_get_dimension(block_mesh,'nCellsSolve',nCellsSolve) + call colm2024_find_block_map(block_cursor % localBlockID, block_map) + if(.not. associated(block_map)) call physics_error_fatal("CoLM2024 MPAS block map was not created.") + block_map % element_for_cell(:) = 0 + block_cells = nCellsSolve + if(block_cells > 0) block_map % element_for_cell(1:block_cells) = cell_to_element(offset+1:offset+block_cells) + offset = offset + block_cells + block_cursor => block_cursor % next + enddo + + call colm_mpas_ready(colm_ready, colm_patch_count) + if(.not. colm_ready) call colm2024_adapter_not_ready + + colm_update_lai_next_step = .true. + colm_step_idate(:) = mpas_start_idate(:) + call colm_adj2end(colm_step_idate) + colm_initialized = .true. + + block_cursor => block % domain % blocklist + do while(associated(block_cursor)) + call mpas_pool_get_subpool(block_cursor % structs,'mesh' ,block_mesh ) + call mpas_pool_get_subpool(block_cursor % structs,'diag_physics' ,block_diag_physics ) + call mpas_pool_get_subpool(block_cursor % structs,'diag_physics_colm2024' ,block_diag_physics_colm2024 ) + call mpas_pool_get_subpool(block_cursor % structs,'sfc_input' ,block_sfc_input ) + call mpas_pool_get_dimension(block_mesh,'nCellsSolve',nCellsSolve) + call colm2024_find_block_map(block_cursor % localBlockID, block_map) + if(.not. associated(block_map)) call physics_error_fatal("CoLM2024 MPAS block map was not created.") + if(nCellsSolve > 0) then + call colm2024_pull_mpas_surface(block_map % element_for_cell, block_diag_physics, & + block_diag_physics_colm2024, block_sfc_input, & + mpas_colm_timestep, 1, nCellsSolve, state_only=.true.) + endif + block_cursor => block_cursor % next + enddo +#else + call colm2024_adapter_not_built +#endif + + end subroutine init_lsm_colm2024 + +!================================================================================================================= + subroutine push_lsm_colm2024(block,configs,mesh,state,time_lev,diag,diag_physics,atm_input,sfc_input,its,ite) +!================================================================================================================= + + type(block_type),intent(in):: block + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(in):: atm_input + type(mpas_pool_type),intent(inout):: sfc_input + integer,intent(in):: time_lev + integer,intent(in):: its,ite +#ifdef MPAS_COLM2024 + logical :: colm_ready + integer :: colm_patch_count + type(colm_block_map_type),pointer:: block_map +#endif + +#ifdef MPAS_COLM2024 + call colm_mpas_ready(colm_ready, colm_patch_count) + if(.not. colm_ready) call colm2024_adapter_not_ready + call colm2024_find_block_map(block % localBlockID, block_map) + if(.not. associated(block_map)) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is not initialized.") + if(size(block_map % element_for_cell) < ite) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is smaller " // & + "than the MPAS cell range.") + + call colm2024_push_mpas_forcing(block_map % element_for_cell, configs, mesh, state, time_lev, diag, diag_physics, & + atm_input, sfc_input, its, ite) +#else + call colm2024_adapter_not_built +#endif + + end subroutine push_lsm_colm2024 + +!================================================================================================================= + subroutine step_lsm_colm2024() +!================================================================================================================= + +#ifdef MPAS_COLM2024 + logical :: colm_ready + logical :: colm_update_daily_lai + integer :: colm_ierr + integer :: colm_patch_count + integer :: colm_previous_date(3) + integer :: colm_current_date(3) + real(kind=colm_r8) :: colm_dt + + call colm_mpas_ready(colm_ready, colm_patch_count) + if(.not. colm_ready) call colm2024_adapter_not_ready + colm_dt = real(dt_pbl, colm_r8) + if(colm_dt <= 0._colm_r8) call physics_error_fatal("CoLM2024 requires a positive land-surface timestep.") + if(abs(colm_dt - real(nint(colm_dt), colm_r8)) > 1.e-6_colm_r8) then + call physics_error_fatal("CoLM2024 embedded time management requires an integer-second land-surface timestep.") + endif + colm_previous_date(:) = colm_step_idate(:) + call colm_adj2begin(colm_previous_date) + call colm_ticktime(colm_dt, colm_step_idate) + colm_current_date(:) = colm_step_idate(:) + call colm_adj2begin(colm_current_date) + colm_update_daily_lai = colm_update_lai_next_step + call colm_mpas_step(colm_step_idate, colm_dt, colm_update_daily_lai, .true., .false., colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 driver returned before completing a land-surface step.") + colm_update_lai_next_step = any(colm_current_date(1:2) /= colm_previous_date(1:2)) +#else + call colm2024_adapter_not_built +#endif + + end subroutine step_lsm_colm2024 + +!================================================================================================================= + subroutine pull_lsm_colm2024(block,diag_physics,diag_physics_colm2024,sfc_input,its,ite) +!================================================================================================================= + + type(block_type),intent(in):: block + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_colm2024 + type(mpas_pool_type),intent(inout):: sfc_input + integer,intent(in):: its,ite +#ifdef MPAS_COLM2024 + logical :: colm_ready + integer :: colm_patch_count + type(colm_block_map_type),pointer:: block_map + + call colm_mpas_ready(colm_ready, colm_patch_count) + if(.not. colm_ready) call colm2024_adapter_not_ready + call colm2024_find_block_map(block % localBlockID, block_map) + if(.not. associated(block_map)) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is not initialized.") + if(size(block_map % element_for_cell) < ite) call physics_error_fatal("CoLM2024 MPAS cell-to-element map is smaller " // & + "than the MPAS cell range.") + + call colm2024_pull_mpas_surface(block_map % element_for_cell, diag_physics, diag_physics_colm2024, & + sfc_input, real(dt_pbl, colm_r8), its, ite) +#else + call colm2024_adapter_not_built +#endif + + end subroutine pull_lsm_colm2024 + +!================================================================================================================= + subroutine checkpoint_lsm_colm2024() +!================================================================================================================= + +#ifdef MPAS_COLM2024 + integer :: colm_ierr + + if(.not. colm_initialized) return + call colm_mpas_force_restart(colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 failed to write a checkpoint with the MPAS restart stream.") +#endif + + end subroutine checkpoint_lsm_colm2024 + +!================================================================================================================= + subroutine finalize_lsm_colm2024() + !================================================================================================================= + +#ifdef MPAS_COLM2024 + integer :: colm_ierr, mpi_ierr + + if(.not. colm_initialized) return + call colm_mpas_finalize(colm_ierr) + if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 finalization failed.") + if(colm_mpas_comm == MPI_COMM_NULL) then + call physics_error_fatal("CoLM2024 MPAS communication context is missing during finalization.") + endif + call MPI_Comm_free(colm_mpas_comm, mpi_ierr) + if(mpi_ierr /= MPI_SUCCESS) then + call physics_error_fatal("MPAS could not release the CoLM2024 communication context.") + endif + colm_mpas_comm = MPI_COMM_NULL + call colm2024_free_block_maps() + colm_update_lai_next_step = .true. + colm_step_idate(:) = -1 + colm_initialized = .false. +#endif + + end subroutine finalize_lsm_colm2024 + +#ifdef MPAS_COLM2024 +!================================================================================================================= + subroutine colm2024_add_block_map(local_block_id, nCells) +!================================================================================================================= + + integer,intent(in):: local_block_id + integer,intent(in):: nCells + type(colm_block_map_type),pointer:: block_map, cursor + + allocate(block_map) + block_map % local_block_id = local_block_id + allocate(block_map % element_for_cell(nCells)) + block_map % element_for_cell(:) = 0 + nullify(block_map % next) + + if(.not. associated(colm_block_maps)) then + colm_block_maps => block_map + else + cursor => colm_block_maps + do while(associated(cursor % next)) + cursor => cursor % next + enddo + cursor % next => block_map + endif + + end subroutine colm2024_add_block_map + +!================================================================================================================= + subroutine colm2024_find_block_map(local_block_id, block_map) +!================================================================================================================= + + integer,intent(in):: local_block_id + type(colm_block_map_type),pointer:: block_map + + block_map => colm_block_maps + do while(associated(block_map)) + if(block_map % local_block_id == local_block_id) return + block_map => block_map % next + enddo + nullify(block_map) + + end subroutine colm2024_find_block_map + +!================================================================================================================= + subroutine colm2024_free_block_maps() +!================================================================================================================= + + type(colm_block_map_type),pointer:: block_map, next_map + + block_map => colm_block_maps + do while(associated(block_map)) + next_map => block_map % next + if(allocated(block_map % element_for_cell)) deallocate(block_map % element_for_cell) + deallocate(block_map) + block_map => next_map + enddo + nullify(colm_block_maps) + + end subroutine colm2024_free_block_maps + +!================================================================================================================= + subroutine colm2024_push_mpas_forcing(element_for_cell,configs,mesh,state,time_lev,diag,diag_physics,atm_input, & + sfc_input,its,ite) +!================================================================================================================= + + integer,dimension(:),intent(in):: element_for_cell + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: atm_input + type(mpas_pool_type),intent(in):: sfc_input + integer,intent(in):: time_lev + integer,intent(in):: its,ite + + logical,pointer:: config_o3climatology + logical:: micro_has_solid + character(len=StrKIND),pointer:: config_convection_scheme, config_microp_scheme + integer,pointer:: index_qv + integer:: i, k + integer:: ierr, ozone_ierr + integer:: forcing_idate(3), forcing_month, forcing_mday + real(kind=colm_r8):: aerdep(14) + real(kind=colm_r8):: co2_mole_fraction, dt, micro_rain, micro_snow, micro_total, precip_tolerance, & + hgt, hpbl_forcing, oro, ozone_ppbv, & + pbot, psrf, prc, prl, qair, & + rain, rhoair, snow, frl_down, & + solld, soll, solsd, sols, spectral_sw, spectral_swdir, spectral_swdif, & + sw_consistency_tolerance, swdir, swdif, solar_cosine, tair, uair, vair + real(kind=RKIND):: qv_cell + real(kind=RKIND),dimension(:),pointer:: coszr, glw, hpbl, swddir, swddif, swvisdir, swvisdif, swnirdir, swnirdif + real(kind=RKIND),dimension(:),pointer:: surface_pressure, xice, xland + real(kind=RKIND),dimension(:),pointer:: pin + real(kind=RKIND),dimension(:),pointer:: raincv, rainncv, snowncv, graupelncv + real(kind=RKIND),dimension(:,:),pointer:: exner, o3clim, pressure_b, pressure_p, theta_m, u, v, zgrid + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) + call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology ) + if(colm_use_ozone_data .and. .not. config_o3climatology) then + call physics_error_fatal("CoLM2024 DEF_USE_OZONEDATA requires MPAS config_o3climatology=true.") + endif + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_array(mesh,'zgrid',zgrid) + 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_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(diag,'surface_pressure',surface_pressure) + if(colm_use_ozone_data) then + call mpas_pool_get_array(atm_input,'pin',pin) + call mpas_pool_get_array(diag_physics,'o3clim',o3clim) + endif + call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'coszr' ,coszr ) + call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) + 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,'swvisdir',swvisdir) + call mpas_pool_get_array(diag_physics,'swvisdif',swvisdif) + call mpas_pool_get_array(diag_physics,'swnirdir',swnirdir) + call mpas_pool_get_array(diag_physics,'swnirdif',swnirdif) + if(config_convection_scheme .ne. 'off') call mpas_pool_get_array(diag_physics,'raincv',raincv) + micro_has_solid = .false. + select case(trim(config_microp_scheme)) + case('off') + case('mp_kessler') + call mpas_pool_get_array(diag_physics,'rainncv',rainncv) + case('mp_thompson','mp_thompson_aerosols','mp_wsm6') + micro_has_solid = .true. + 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) + case default + call physics_error_fatal("CoLM2024 encountered an unsupported MPAS microphysics scheme.") + end select + call mpas_pool_get_array(sfc_input,'xland',xland) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + + dt = real(dt_pbl, colm_r8) + if(.not. ieee_is_finite(dt) .or. dt <= 0._colm_r8) then + call physics_error_fatal("CoLM2024 precipitation forcing requires a positive finite timestep.") + endif + forcing_idate(:) = colm_step_idate(:) + call colm_adj2begin(forcing_idate) + call colm_julian2monthday(forcing_idate(1), forcing_idate(2), forcing_month, forcing_mday) + co2_mole_fraction = 1.e-6_colm_r8 * colm_get_monthly_co2_mlo(forcing_idate(1), forcing_month) + if(.not. ieee_is_finite(co2_mole_fraction) .or. co2_mole_fraction <= 0._colm_r8) then + call physics_error_fatal("CoLM2024 produced an invalid atmospheric CO2 mole fraction.") + endif + aerdep(:) = 0._colm_r8 + + k = lbound(theta_m, 1) + do i = its,ite + if(element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") + + if(.not. ieee_is_finite(xland(i)) .or. .not. ieee_is_finite(xice(i))) then + call physics_error_fatal("MPAS supplied a non-finite land-ocean or sea-ice mask to CoLM2024.") + endif + if(xland(i) < 1._RKIND .or. xland(i) > 2._RKIND .or. xice(i) < 0._RKIND .or. xice(i) > 1._RKIND) then + call physics_error_fatal("MPAS supplied an out-of-range land-ocean or sea-ice mask to CoLM2024.") + endif + if(config_convection_scheme .ne. 'off') then + if(.not. ieee_is_finite(raincv(i))) then + call physics_error_fatal("MPAS supplied non-finite convective precipitation to CoLM2024.") + endif + if(raincv(i) < 0._RKIND) call physics_error_fatal("MPAS supplied negative convective precipitation to CoLM2024.") + endif + if(config_microp_scheme .ne. 'off') then + if(.not. ieee_is_finite(rainncv(i)) .or. rainncv(i) < 0._RKIND) & + call physics_error_fatal("MPAS supplied invalid total microphysics precipitation to CoLM2024.") + if(micro_has_solid) then + if(.not. all(ieee_is_finite((/snowncv(i), graupelncv(i)/))) .or. & + snowncv(i) < 0._RKIND .or. graupelncv(i) < 0._RKIND) & + call physics_error_fatal("MPAS supplied invalid solid microphysics precipitation to CoLM2024.") + endif + endif + + psrf = real(surface_pressure(i), colm_r8) + pbot = real(pressure_b(k,i) + pressure_p(k,i), colm_r8) + if(.not. ieee_is_finite(scalars(index_qv,k,i))) then + call physics_error_fatal("MPAS supplied non-finite lowest-level water vapor to CoLM2024.") + endif + if(scalars(index_qv,k,i) < -1.e-10_RKIND) then + call physics_error_fatal("MPAS supplied negative lowest-level water vapor to CoLM2024.") + endif + qv_cell = max(0._RKIND, scalars(index_qv,k,i)) + tair = real((theta_m(k,i) / (1._RKIND + R_v / R_d * qv_cell)) * exner(k,i), colm_r8) + qair = real(qv_cell / (1._RKIND + qv_cell), colm_r8) + uair = real(u(k,i), colm_r8) + vair = real(v(k,i), colm_r8) + hgt = 2._colm_r8 + if(ubound(zgrid, 1) >= k + 1) hgt = max(2._colm_r8, real(0.5_RKIND * (zgrid(k+1,i) - zgrid(k,i)), colm_r8)) + rhoair = pbot / (real(R_d, colm_r8) * tair * (1._colm_r8 + 0.61_colm_r8 * qair)) + if(.not. ieee_is_finite(rhoair) .or. rhoair <= 0._colm_r8) then + call physics_error_fatal("MPAS atmospheric state produced invalid air density for CoLM2024.") + endif + prc = 0._colm_r8 + prl = 0._colm_r8 + rain = 0._colm_r8 + snow = 0._colm_r8 + + if(config_convection_scheme .ne. 'off') then + prc = max(0._colm_r8, real(raincv(i), colm_r8) / dt) + rain = rain + prc + endif + if(config_microp_scheme .ne. 'off') then + micro_total = real(rainncv(i), colm_r8) + micro_snow = 0._colm_r8 + if(micro_has_solid) micro_snow = real(snowncv(i) + graupelncv(i), colm_r8) + precip_tolerance = max(1.e-10_colm_r8, 1.e-6_colm_r8 * max(1._colm_r8, micro_total)) + if(micro_snow > micro_total + precip_tolerance) then + call physics_error_fatal("MPAS solid grid-scale precipitation exceeds total precipitation for CoLM2024.") + endif + micro_snow = min(micro_total, micro_snow) / dt + micro_rain = max(0._colm_r8, micro_total / dt - micro_snow) + prl = micro_total / dt + rain = rain + micro_rain + snow = snow + micro_snow + endif + + if(.not. all(ieee_is_finite((/real(swddir(i), colm_r8), real(swddif(i), colm_r8), & + real(swvisdir(i), colm_r8), real(swvisdif(i), colm_r8), & + real(swnirdir(i), colm_r8), real(swnirdif(i), colm_r8)/)))) then + call physics_error_fatal("MPAS supplied non-finite shortwave forcing to CoLM2024.") + endif + if(any((/real(swddir(i), colm_r8), real(swddif(i), colm_r8), & + real(swvisdir(i), colm_r8), real(swvisdif(i), colm_r8), & + real(swnirdir(i), colm_r8), real(swnirdif(i), colm_r8)/) < -1.e-6_colm_r8)) then + call physics_error_fatal("MPAS supplied negative shortwave forcing to CoLM2024.") + endif + swdir = max(0._colm_r8, real(swddir(i), colm_r8)) + swdif = max(0._colm_r8, real(swddif(i), colm_r8)) + sols = max(0._colm_r8, real(swvisdir(i), colm_r8)) + solsd = max(0._colm_r8, real(swvisdif(i), colm_r8)) + soll = max(0._colm_r8, real(swnirdir(i), colm_r8)) + solld = max(0._colm_r8, real(swnirdif(i), colm_r8)) + spectral_swdir = sols + soll + spectral_swdif = solsd + solld + spectral_sw = spectral_swdir + spectral_swdif + solar_cosine = real(coszr(i), colm_r8) + if(.not. ieee_is_finite(solar_cosine) .or. solar_cosine < -1._colm_r8 .or. & + solar_cosine > 1._colm_r8) then + call physics_error_fatal("MPAS supplied an invalid solar-zenith cosine to CoLM2024.") + endif + if(spectral_sw <= 0._colm_r8 .and. swdir + swdif > 0._colm_r8) then + call physics_error_fatal("MPAS shortwave forcing lacks the VIS/NIR direct/diffuse components required by CoLM2024.") + endif + sw_consistency_tolerance = max(1._colm_r8, 1.e-3_colm_r8 * max(swdir, spectral_swdir)) + if(abs(swdir - spectral_swdir) > sw_consistency_tolerance) then + call physics_error_fatal("MPAS broadband and VIS/NIR direct shortwave forcing are inconsistent for CoLM2024.") + endif + sw_consistency_tolerance = max(1._colm_r8, 1.e-3_colm_r8 * max(swdif, spectral_swdif)) + if(abs(swdif - spectral_swdif) > sw_consistency_tolerance) then + call physics_error_fatal("MPAS broadband and VIS/NIR diffuse shortwave forcing are inconsistent for CoLM2024.") + endif + oro = 1._colm_r8 + if(xland(i) >= 1.5_RKIND) oro = 0._colm_r8 + if(xice(i) >= xice_threshold) oro = 2._colm_r8 + hpbl_forcing = real(hpbl(i), colm_r8) + if(.not. ieee_is_finite(hpbl_forcing) .or. hpbl_forcing < 0._colm_r8) then + call physics_error_fatal("MPAS supplied an invalid boundary-layer height to CoLM2024.") + endif + + frl_down = real(glw(i), colm_r8) + if(.not. all(ieee_is_finite((/psrf, pbot, tair, qair, uair, vair, prc, prl, rain, snow, & + sols, soll, solsd, solld, frl_down, hgt, rhoair/)))) then + call physics_error_fatal("MPAS supplied non-finite atmospheric forcing to CoLM2024.") + endif + if(frl_down < -1.e-6_colm_r8) then + call physics_error_fatal("MPAS supplied negative downward longwave forcing to CoLM2024.") + endif + frl_down = max(0._colm_r8, frl_down) + if(psrf <= 0._colm_r8 .or. pbot <= 0._colm_r8 .or. tair <= 0._colm_r8 .or. & + qair < 0._colm_r8 .or. qair >= 1._colm_r8) then + call physics_error_fatal("MPAS supplied out-of-range pressure, temperature, or humidity to CoLM2024.") + endif + ozone_ppbv = 100._colm_r8 + if(colm_use_ozone_data) then + call colm2024_interpolate_ozone(pbot, pin, o3clim(:,i), ozone_ppbv, ozone_ierr) + if(ozone_ierr /= 0) call physics_error_fatal("Failed to interpolate MPAS ozone forcing for CoLM2024.") + endif + + call colm_mpas_set_element_forcing(element_for_cell(i), pbot * co2_mole_fraction, & + pbot * 0.209_colm_r8, uair, vair, tair, qair, & + prc, prl, rain, snow, solar_cosine, psrf, pbot, & + sols, soll, solsd, solld, & + frl_down, hgt, hgt, hgt, rhoair, hpbl_forcing, & + aerdep, oro=oro, ozone=ozone_ppbv, ierr=ierr) + if(ierr /= 0) call physics_error_fatal("Failed to pass MPAS forcing into CoLM2024.") + enddo + + end subroutine colm2024_push_mpas_forcing + +!================================================================================================================= + subroutine colm2024_interpolate_ozone(target_pressure,pressure_levels,ozone_profile,ozone_ppbv,ierr) +!================================================================================================================= + + real(kind=colm_r8),intent(in):: target_pressure + real(kind=RKIND),dimension(:),intent(in):: pressure_levels, ozone_profile + real(kind=colm_r8),intent(out):: ozone_ppbv + integer,intent(out):: ierr + + integer:: i, lower_index, upper_index + real(kind=colm_r8):: lower_pressure, upper_pressure, weight + + ierr = 1 + ozone_ppbv = -1._colm_r8 + if(size(pressure_levels) /= size(ozone_profile) .or. size(pressure_levels) < 1) return + if(.not. ieee_is_finite(target_pressure) .or. target_pressure <= 0._colm_r8) return + + lower_index = 0 + upper_index = 0 + lower_pressure = -huge(1._colm_r8) + upper_pressure = huge(1._colm_r8) + do i = 1,size(pressure_levels) + if(.not. ieee_is_finite(pressure_levels(i)) .or. pressure_levels(i) <= 0._RKIND) cycle + if(.not. ieee_is_finite(ozone_profile(i)) .or. ozone_profile(i) < 0._RKIND) cycle + if(real(pressure_levels(i),colm_r8) <= target_pressure .and. & + real(pressure_levels(i),colm_r8) > lower_pressure) then + lower_pressure = real(pressure_levels(i),colm_r8) + lower_index = i + endif + if(real(pressure_levels(i),colm_r8) >= target_pressure .and. & + real(pressure_levels(i),colm_r8) < upper_pressure) then + upper_pressure = real(pressure_levels(i),colm_r8) + upper_index = i + endif + enddo + + if(lower_index == 0 .and. upper_index == 0) return + if(lower_index == 0) lower_index = upper_index + if(upper_index == 0) upper_index = lower_index + if(lower_index == upper_index) then + ozone_ppbv = 1.e9_colm_r8 * real(ozone_profile(lower_index),colm_r8) + else + weight = (log(target_pressure) - log(lower_pressure)) / (log(upper_pressure) - log(lower_pressure)) + ozone_ppbv = 1.e9_colm_r8 * ((1._colm_r8 - weight) * real(ozone_profile(lower_index),colm_r8) + & + weight * real(ozone_profile(upper_index),colm_r8)) + endif + if(.not. ieee_is_finite(ozone_ppbv) .or. ozone_ppbv < 0._colm_r8) return + ierr = 0 + + end subroutine colm2024_interpolate_ozone + +!================================================================================================================= +subroutine colm2024_pull_mpas_surface(element_for_cell,diag_physics,diag_physics_colm2024,sfc_input,dt,its,ite,state_only) +!================================================================================================================= + + integer,dimension(:),intent(in):: element_for_cell + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_colm2024 + type(mpas_pool_type),intent(inout):: sfc_input + real(kind=colm_r8),intent(in):: dt + integer,intent(in):: its,ite + logical,intent(in),optional:: state_only + + integer:: i, ns, nlev, nvalid_soil + integer:: ierr + logical:: pull_fluxes + real(kind=colm_r8):: sensible, latent, evaporation, ground_heat, runoff + real(kind=colm_r8):: surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, u10m_colm, v10m_colm, qsfc_colm + real(kind=colm_r8):: emissivity, roughness, albedo + real(kind=colm_r8):: friction_velocity, stability_zeta, bulk_richardson, momentum_profile, heat_profile + real(kind=colm_r8):: moisture_profile, air_density, heat_exchange_velocity, moisture_exchange_velocity + real(kind=colm_r8):: momentum_coefficient, enthalpy_coefficient, inverse_monin_obukhov + real(kind=colm_r8):: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index, ground_temperature + real(kind=colm_r8):: vegetation_fraction, soil_availability + real(kind=colm_r8):: river_water_depth, river_velocity, river_discharge + real(kind=colm_r8):: soil_moisture_sum + real(kind=colm_r8),parameter:: colm_state_bad_value = 1.e30_colm_r8 + real(kind=colm_r8),dimension(:),allocatable:: soil_liquid, soil_ice, soil_moisture, soil_temperature + real(kind=colm_r8),dimension(:),allocatable:: soil_water_equivalent + + real(kind=RKIND),dimension(:),pointer:: hfx, lh, qfx, grdflx, sfcrunoff, udrunoff + real(kind=RKIND),dimension(:),pointer:: sfc_albedo, sfc_emiss, z0, znt, qsfc, t2m, q2, u10, v10 + real(kind=RKIND),dimension(:),pointer:: ust, ustm, zol, br, fm, fh, rmol, ch, chs, cda, cka, flhc, flqc + real(kind=RKIND),dimension(:),pointer:: skintemp, canwat, smstav, smstot, snow, snowc, snowh, lai, vegfra, xland + real(kind=RKIND),dimension(:,:),pointer:: dzs, sh2o, smois, tslb + real(kind=RKIND),dimension(:,:),pointer:: colm_soil_liquid, colm_soil_ice, colm_soil_moisture + real(kind=RKIND),dimension(:,:),pointer:: colm_soil_temperature, colm_soil_layer_thickness, colm_soil_layer_depth + real(kind=RKIND),dimension(:),pointer:: colm_river_water_depth, colm_river_velocity, colm_river_discharge + + pull_fluxes = .true. + if(present(state_only)) pull_fluxes = .not. state_only + + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) + 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,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'t2m' ,t2m ) + call mpas_pool_get_array(diag_physics,'q2' ,q2 ) + call mpas_pool_get_array(diag_physics,'u10' ,u10 ) + call mpas_pool_get_array(diag_physics,'v10' ,v10 ) + call mpas_pool_get_array(diag_physics,'ust' ,ust ) + call mpas_pool_get_array(diag_physics,'ustm' ,ustm ) + call mpas_pool_get_array(diag_physics,'zol' ,zol ) + call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'fm' ,fm ) + call mpas_pool_get_array(diag_physics,'fh' ,fh ) + call mpas_pool_get_array(diag_physics,'rmol' ,rmol ) + call mpas_pool_get_array(diag_physics,'ch' ,ch ) + call mpas_pool_get_array(diag_physics,'chs' ,chs ) + call mpas_pool_get_array(diag_physics,'cda' ,cda ) + call mpas_pool_get_array(diag_physics,'cka' ,cka ) + call mpas_pool_get_array(diag_physics,'flhc' ,flhc ) + call mpas_pool_get_array(diag_physics,'flqc' ,flqc ) + call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) + 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,'lai' ,lai ) + 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,'vegfra' ,vegfra ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + call mpas_pool_get_array(sfc_input,'dzs' ,dzs ) + 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_colm2024,'colm_soil_liquid' ,colm_soil_liquid ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_ice' ,colm_soil_ice ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_moisture' ,colm_soil_moisture ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_temperature' ,colm_soil_temperature ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_layer_thickness',colm_soil_layer_thickness) + call mpas_pool_get_array(diag_physics_colm2024,'colm_soil_layer_depth' ,colm_soil_layer_depth ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_river_water_depth' ,colm_river_water_depth ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_river_velocity' ,colm_river_velocity ) + call mpas_pool_get_array(diag_physics_colm2024,'colm_river_discharge' ,colm_river_discharge ) + + nlev = size(tslb, 1) + if(size(sh2o,1) /= nlev .or. size(smois,1) /= nlev .or. size(dzs,1) /= nlev) then + call physics_error_fatal("MPAS generic soil arrays have inconsistent vertical dimensions.") + endif + if(nlev /= colm_nl_soil) then + call physics_error_fatal("CoLM2024 requires all MPAS soil arrays to retain its 10 native layers.") + endif + if(size(colm_soil_liquid,1) /= colm_nl_soil .or. size(colm_soil_ice,1) /= colm_nl_soil .or. & + size(colm_soil_moisture,1) /= colm_nl_soil .or. size(colm_soil_temperature,1) /= colm_nl_soil .or. & + size(colm_soil_layer_thickness,1) /= colm_nl_soil .or. size(colm_soil_layer_depth,1) /= colm_nl_soil) then + call physics_error_fatal("MPAS CoLM2024 registry fields must retain all 10 native soil layers.") + endif + allocate(soil_liquid(colm_nl_soil), soil_ice(colm_nl_soil), soil_moisture(colm_nl_soil), & + soil_temperature(colm_nl_soil), soil_water_equivalent(colm_nl_soil)) + + do i = its,ite + if(element_for_cell(i) <= 0) call physics_error_fatal("CoLM2024 MPAS cell-to-element map has an invalid element index.") + if(.not. ieee_is_finite(xland(i))) call physics_error_fatal("MPAS supplied a non-finite land-ocean mask to CoLM2024.") + if(xland(i) >= 1.5_RKIND) then + colm_soil_liquid(:,i) = -9999._RKIND + colm_soil_ice(:,i) = -9999._RKIND + colm_soil_moisture(:,i) = -9999._RKIND + colm_soil_temperature(:,i) = -9999._RKIND + colm_soil_layer_thickness(:,i) = -9999._RKIND + colm_soil_layer_depth(:,i) = -9999._RKIND + colm_river_water_depth(i) = -9999._RKIND + colm_river_velocity(i) = -9999._RKIND + colm_river_discharge(i) = -9999._RKIND + cycle + endif + + if(pull_fluxes) then + call colm_mpas_get_element_surface(element_for_cell(i), sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, & + u10m_colm, v10m_colm, qsfc_colm, emissivity, roughness, albedo, & + friction_velocity, & + stability_zeta, bulk_richardson, momentum_profile, heat_profile, & + moisture_profile, air_density, heat_exchange_velocity, & + moisture_exchange_velocity, momentum_coefficient, enthalpy_coefficient, & + inverse_monin_obukhov, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface fluxes.") + else + call colm_mpas_get_element_boundary_state(element_for_cell(i), skin_temp, qsfc_colm, emissivity, & + roughness, albedo, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve the initial CoLM2024 surface boundary state.") + endif + call colm_mpas_get_element_state(element_for_cell(i), canopy_water, snow_water, snow_depth, snow_cover, & + leaf_area_index, vegetation_fraction, soil_availability, ground_temperature, & + soil_liquid, soil_ice, soil_moisture, soil_temperature, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface state.") + call colm_mpas_get_element_river_state(element_for_cell(i), river_water_depth, river_velocity, & + river_discharge, ierr) + if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 river-routing diagnostics.") + colm_river_water_depth(i) = -9999._RKIND + colm_river_velocity(i) = -9999._RKIND + colm_river_discharge(i) = -9999._RKIND + if(ieee_is_finite(river_water_depth) .and. abs(river_water_depth) < colm_state_bad_value) & + colm_river_water_depth(i) = real(river_water_depth, RKIND) + if(ieee_is_finite(river_velocity) .and. abs(river_velocity) < colm_state_bad_value) & + colm_river_velocity(i) = real(river_velocity, RKIND) + if(ieee_is_finite(river_discharge) .and. abs(river_discharge) < colm_state_bad_value) & + colm_river_discharge(i) = real(river_discharge, RKIND) + if(.not. all(ieee_is_finite((/canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index, & + ground_temperature/))) .or. & + any(abs((/canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index, & + ground_temperature/)) >= colm_state_bad_value)) then + call physics_error_fatal("CoLM2024 returned a non-finite or missing required surface state.") + endif + if(pull_fluxes) then + if(.not. all(ieee_is_finite((/sensible, latent, evaporation, ground_heat, runoff, surface_runoff, & + subsurface_runoff, skin_temp, t2m_colm, q2m_colm, u10m_colm, v10m_colm, & + qsfc_colm, emissivity, & + roughness, albedo/))) .or. & + any(abs((/sensible, latent, evaporation, ground_heat, runoff, surface_runoff, subsurface_runoff, & + skin_temp, t2m_colm, q2m_colm, u10m_colm, v10m_colm, qsfc_colm, emissivity, roughness, & + albedo/)) >= colm_state_bad_value)) then + call physics_error_fatal("CoLM2024 returned a non-finite or missing required surface field.") + endif + if(.not. all(ieee_is_finite((/friction_velocity, stability_zeta, bulk_richardson, momentum_profile, & + heat_profile, moisture_profile, air_density, heat_exchange_velocity, & + moisture_exchange_velocity, momentum_coefficient, enthalpy_coefficient, & + inverse_monin_obukhov/))) .or. & + any(abs((/friction_velocity, stability_zeta, bulk_richardson, momentum_profile, heat_profile, & + moisture_profile, air_density, heat_exchange_velocity, moisture_exchange_velocity, & + momentum_coefficient, enthalpy_coefficient, inverse_monin_obukhov/)) >= colm_state_bad_value)) then + call physics_error_fatal("CoLM2024 returned a non-finite or missing surface-exchange field.") + endif + if(q2m_colm < 0._colm_r8 .or. q2m_colm >= 1._colm_r8 .or. qsfc_colm < 0._colm_r8 .or. & + qsfc_colm >= 1._colm_r8 .or. emissivity < 0._colm_r8 .or. emissivity > 1._colm_r8 .or. & + albedo < 0._colm_r8 .or. albedo > 1._colm_r8 .or. & + roughness < 0._colm_r8 .or. friction_velocity < 0._colm_r8 .or. air_density <= 0._colm_r8 .or. & + momentum_profile <= 0._colm_r8 .or. heat_profile <= 0._colm_r8 .or. moisture_profile <= 0._colm_r8 .or. & + heat_exchange_velocity < 0._colm_r8 .or. moisture_exchange_velocity < 0._colm_r8 .or. & + momentum_coefficient < 0._colm_r8 .or. enthalpy_coefficient < 0._colm_r8) then + call physics_error_fatal("CoLM2024 returned an out-of-range surface state or exchange field.") + endif + + hfx(i) = real(sensible, RKIND) + lh(i) = real(latent, RKIND) + qfx(i) = real(evaporation, RKIND) + ! CoLM fgrnd and MPAS/Noah-MP grdflx are positive into soil/snow. + grdflx(i) = real(ground_heat, RKIND) + ! MPAS runoff diagnostics are accumulated depths, matching Noah/Noah-MP. + sfcrunoff(i) = sfcrunoff(i) + real(surface_runoff * dt, RKIND) + udrunoff(i) = udrunoff(i) + real(subsurface_runoff * dt, RKIND) + skintemp(i) = real(skin_temp, RKIND) + t2m(i) = real(t2m_colm, RKIND) + u10(i) = real(u10m_colm, RKIND) + v10(i) = real(v10m_colm, RKIND) + ! CoLM qref and MPAS q2/qsfc are specific humidity. + qsfc(i) = real(qsfc_colm, RKIND) + q2(i) = real(q2m_colm, RKIND) + sfc_emiss(i) = real(emissivity, RKIND) + z0(i) = real(roughness, RKIND) + znt(i) = real(roughness, RKIND) + sfc_albedo(i) = real(albedo, RKIND) + ust(i) = real(friction_velocity, RKIND) + ustm(i) = real(friction_velocity, RKIND) + zol(i) = real(stability_zeta, RKIND) + br(i) = real(bulk_richardson, RKIND) + fm(i) = real(momentum_profile, RKIND) + fh(i) = real(heat_profile, RKIND) + rmol(i) = real(inverse_monin_obukhov, RKIND) + ch(i) = real(heat_exchange_velocity, RKIND) + chs(i) = real(heat_exchange_velocity, RKIND) + flhc(i) = real(air_density * real(cp,colm_r8) * heat_exchange_velocity, RKIND) + flqc(i) = real(air_density * moisture_exchange_velocity, RKIND) + cda(i) = real(momentum_coefficient, RKIND) + cka(i) = real(enthalpy_coefficient, RKIND) + else + if(.not. all(ieee_is_finite((/skin_temp, qsfc_colm, emissivity, roughness, albedo/))) .or. & + any(abs((/skin_temp, qsfc_colm, emissivity, roughness, albedo/)) >= colm_state_bad_value) .or. & + skin_temp <= 0._colm_r8 .or. qsfc_colm < 0._colm_r8 .or. qsfc_colm >= 1._colm_r8 .or. & + emissivity <= 0._colm_r8 .or. emissivity > 1._colm_r8 .or. roughness < 0._colm_r8 .or. & + albedo < 0._colm_r8 .or. albedo > 1._colm_r8) then + call physics_error_fatal("CoLM2024 returned an invalid initial surface boundary state.") + endif + skintemp(i) = real(skin_temp, RKIND) + qsfc(i) = real(qsfc_colm, RKIND) + sfc_emiss(i) = real(emissivity, RKIND) + z0(i) = real(roughness, RKIND) + znt(i) = real(roughness, RKIND) + sfc_albedo(i) = real(albedo, RKIND) + endif + canwat(i) = real(canopy_water, RKIND) + snow(i) = real(snow_water, RKIND) + snowh(i) = real(snow_depth, RKIND) + snowc(i) = real(max(0._colm_r8, min(1._colm_r8, snow_cover)), RKIND) + lai(i) = real(max(0._colm_r8, leaf_area_index), RKIND) + if(ieee_is_finite(vegetation_fraction) .and. abs(vegetation_fraction) < colm_state_bad_value) & + vegfra(i) = real(100._colm_r8 * max(0._colm_r8, min(1._colm_r8, vegetation_fraction)), RKIND) + if(ieee_is_finite(soil_availability) .and. abs(soil_availability) < colm_state_bad_value) & + smstav(i) = real(max(0._colm_r8, min(1._colm_r8, soil_availability)), RKIND) + + soil_moisture_sum = 0._colm_r8 + nvalid_soil = 0 + smstot(i) = -9999._RKIND + sh2o(:,i) = -9999._RKIND + smois(:,i) = -9999._RKIND + tslb(:,i) = -9999._RKIND + colm_soil_liquid(:,i) = -9999._RKIND + colm_soil_ice(:,i) = -9999._RKIND + colm_soil_moisture(:,i) = -9999._RKIND + colm_soil_temperature(:,i) = -9999._RKIND + soil_water_equivalent(:) = -1._colm_r8 + do ns = 1,colm_nl_soil + colm_soil_layer_thickness(ns,i) = real(colm_dz_soi(ns), RKIND) + colm_soil_layer_depth(ns,i) = real(colm_z_soi(ns), RKIND) + if(ieee_is_finite(soil_liquid(ns)) .and. ieee_is_finite(soil_ice(ns)) .and. & + ieee_is_finite(soil_moisture(ns)) .and. ieee_is_finite(soil_temperature(ns)) .and. & + soil_liquid(ns) >= 0._colm_r8 .and. soil_ice(ns) >= 0._colm_r8 .and. & + soil_moisture(ns) >= 0._colm_r8 .and. soil_temperature(ns) > 0._colm_r8 .and. & + abs(soil_liquid(ns)) < colm_state_bad_value .and. & + abs(soil_ice(ns)) < colm_state_bad_value .and. & + abs(soil_moisture(ns)) < colm_state_bad_value .and. & + abs(soil_temperature(ns)) < colm_state_bad_value) then + colm_soil_liquid(ns,i) = real(soil_liquid(ns), RKIND) + colm_soil_ice(ns,i) = real(soil_ice(ns), RKIND) + colm_soil_moisture(ns,i) = real(soil_moisture(ns), RKIND) + colm_soil_temperature(ns,i) = real(soil_temperature(ns), RKIND) + soil_water_equivalent(ns) = soil_liquid(ns) + soil_ice(ns) * colm_denice / colm_denh2o + soil_moisture_sum = soil_moisture_sum + soil_water_equivalent(ns) * colm_dz_soi(ns) + nvalid_soil = nvalid_soil + 1 + endif + enddo + if(nvalid_soil == colm_nl_soil) then + smstot(i) = real(1000._colm_r8 * soil_moisture_sum, RKIND) + sh2o(:,i) = real(soil_liquid(:), RKIND) + smois(:,i) = real(soil_water_equivalent(:), RKIND) + tslb(:,i) = real(soil_temperature(:), RKIND) + else + colm_soil_liquid(:,i) = -9999._RKIND + colm_soil_ice(:,i) = -9999._RKIND + colm_soil_moisture(:,i) = -9999._RKIND + colm_soil_temperature(:,i) = -9999._RKIND + endif + enddo + + deallocate(soil_liquid, soil_ice, soil_moisture, soil_temperature, soil_water_equivalent) + + end subroutine colm2024_pull_mpas_surface +#endif + +!================================================================================================================= + subroutine colm2024_adapter_not_ready() +!================================================================================================================= + + call physics_error_fatal("CoLM2024 is linked, but CoLM landpatch/restart state has not been initialized " // & + "for this MPAS run.") + + end subroutine colm2024_adapter_not_ready + +!================================================================================================================= + subroutine colm2024_adapter_not_built() +!================================================================================================================= + + call physics_error_fatal("CoLM2024 requires building MPAS with COLM2024=true.") + + end subroutine colm2024_adapter_not_built + +!================================================================================================================= + end module mpas_atmphys_driver_lsm_colm2024 +!================================================================================================================= 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 3a14275826..777260259d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -16,7 +16,7 @@ module mpas_atmphys_driver_radiation_sw use mpas_atmphys_camrad_init use mpas_atmphys_rrtmg_swinit use mpas_atmphys_vars - + !wrf physics: use module_mp_thompson_aerosols use module_ra_rrtmg_sw_aerosols @@ -142,7 +142,7 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(swupbc_p) ) allocate(swupbc_p(ims:ime,jms:jme) ) if(.not.allocated(swupt_p) ) allocate(swupt_p(ims:ime,jms:jme) ) if(.not.allocated(swuptc_p) ) allocate(swuptc_p(ims:ime,jms:jme) ) - + if(.not.allocated(rthratensw_p) ) allocate(rthratensw_p(ims:ime,kms:kme,jms:jme) ) radiation_sw_select: select case (trim(radt_sw_scheme)) @@ -208,7 +208,7 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(pin_p) ) allocate(pin_p(num_oznlevels) ) if(.not.allocated(ozmixm_p) ) & allocate(ozmixm_p(ims:ime,1:num_oznlevels,jms:jme,num_months) ) - + if(.not.allocated(m_hybi_p) ) allocate(m_hybi_p(num_aerlevels) ) if(.not.allocated(m_psn_p) ) allocate(m_psn_p(ims:ime,jms:jme) ) if(.not.allocated(m_psp_p) ) allocate(m_psp_p(ims:ime,jms:jme) ) @@ -270,7 +270,7 @@ subroutine deallocate_radiation_sw(configs) if(allocated(swupbc_p) ) deallocate(swupbc_p ) if(allocated(swupt_p) ) deallocate(swupt_p ) if(allocated(swuptc_p) ) deallocate(swuptc_p ) - + if(allocated(rthratensw_p) ) deallocate(rthratensw_p ) radiation_sw_select: select case (trim(radt_sw_scheme)) @@ -478,6 +478,10 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i swddir_p(i,j) = 0.0_RKIND swddni_p(i,j) = 0.0_RKIND swddif_p(i,j) = 0.0_RKIND + swvisdir_p(i,j) = 0.0_RKIND + swvisdif_p(i,j) = 0.0_RKIND + swnirdir_p(i,j) = 0.0_RKIND + swnirdif_p(i,j) = 0.0_RKIND enddo enddo @@ -525,7 +529,7 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i enddo endif - case default + case default end select microp_select aerosol_select: select case(microp_scheme) @@ -717,9 +721,9 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !input arguments: type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: tend_physics - type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: configs !local pointers: - character(len=StrKIND),pointer:: radt_sw_scheme + character(len=StrKIND),pointer:: radt_sw_scheme integer,intent(in):: its,ite @@ -729,7 +733,7 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !local pointers: real(kind=RKIND),dimension(:),pointer :: coszr,gsw,swcf,swdnb,swdnbc,swdnt,swdntc, & swupb,swupbc,swupt,swuptc,swddir,swddni, & - swddif + swddif,swvisdir,swvisdif,swnirdir,swnirdif real(kind=RKIND),dimension(:,:),pointer:: rthratensw !----------------------------------------------------------------------------------------------------------------- @@ -750,9 +754,13 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) call mpas_pool_get_array(diag_physics,'swddir' ,swddir ) call mpas_pool_get_array(diag_physics,'swddni' ,swddni ) call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) + call mpas_pool_get_array(diag_physics,'swvisdir' ,swvisdir ) + call mpas_pool_get_array(diag_physics,'swvisdif' ,swvisdif ) + call mpas_pool_get_array(diag_physics,'swnirdir' ,swnirdir ) + call mpas_pool_get_array(diag_physics,'swnirdif' ,swnirdif ) call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) - call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) do j = jts,jte @@ -768,6 +776,10 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) swupbc(i) = swupbc_p(i,j) swupt(i) = swupt_p(i,j) swuptc(i) = swuptc_p(i,j) + swvisdir(i) = 0.0_RKIND + swvisdif(i) = 0.0_RKIND + swnirdir(i) = 0.0_RKIND + swnirdif(i) = 0.0_RKIND enddo radiation_sw_select: select case (trim(radt_sw_scheme)) @@ -776,6 +788,10 @@ subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) swddir(i) = swddir_p(i,j) swddni(i) = swddni_p(i,j) swddif(i) = swddif_p(i,j) + swvisdir(i) = swvisdir_p(i,j) + swvisdif(i) = swvisdif_p(i,j) + swnirdir(i) = swnirdir_p(i,j) + swnirdif(i) = swnirdif_p(i,j) enddo case default end select radiation_sw_select @@ -894,7 +910,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic !... convert the radiation time_step to minutes: radt = dt_radtsw/60. - + !call to shortwave radiation scheme: radiation_sw_select: select case (trim(radt_sw_scheme)) case ("rrtmg_sw") @@ -938,6 +954,8 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic 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 , & + swvisdir = swvisdir_p , swvisdif = swvisdif_p , swnirdir = swnirdir_p , & + swnirdif = swnirdif_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 & @@ -949,7 +967,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic call camrad( dolw = .false. , dosw = .true. , & p_phy = pres_hyd_p , p8w = pres2_hyd_p , & pi_phy = pi_p , t_phy = t_p , & - z = zmid_p , dz8w = dz_p , & + z = zmid_p , dz8w = dz_p , & rthratenlw = rthratenlw_p , rthratensw = rthratensw_p , & swupt = swupt_p , swuptc = swuptc_p , & swdnt = swdnt_p , swdntc = swdntc_p , & @@ -962,11 +980,11 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic swcf = swcf_p , lwcf = lwcf_p , & gsw = gsw_p , glw = glw_p , & olr = olrtoa_p , cemiss = cemiss_p , & - taucldc = taucldc_p , taucldi = taucldi_p , & - coszr = coszr_p , albedo = sfc_albedo_p , & - emiss = sfc_emiss_p , tsk = tsk_p , & + taucldc = taucldc_p , taucldi = taucldi_p , & + coszr = coszr_p , albedo = sfc_albedo_p , & + emiss = sfc_emiss_p , tsk = tsk_p , & xlat = xlat_p , xlong = xlon_p , & - rho_phy = rho_p , qv3d = qv_p , & + rho_phy = rho_p , qv3d = qv_p , & qc3d = qc_p , qr3d = qr_p , & qi3d = qi_p , qs3d = qs_p , & qg3d = qg_p , f_qc = f_qc , & @@ -974,7 +992,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic f_qs = f_qs , f_ice_phy = f_ice , & f_rain_phy = f_rain , cldfra = cldfrac_p , & xland = xland_p , xice = xice_p , & - num_months = num_months , levsiz = num_oznlevels , & + num_months = num_months , levsiz = num_oznlevels , & pin0 = pin_p , ozmixm = ozmixm_p , & paerlev = num_aerlevels , naer_c = num_aerosols , & m_psp = m_psp_p , m_psn = m_psn_p , & @@ -1026,11 +1044,11 @@ subroutine radconst(declin,solcon,julian,degrad,dpd) solcon=0. !obecl : obliquity = 23.5 degree. - + obecl=23.5*degrad sinob=sin(obecl) - -!calculate longitude of the sun from vernal equinox: + +!calculate longitude of the sun from vernal equinox: if(julian.ge.80.)sxlong=dpd*(julian-80.) if(julian.lt.80.)sxlong=dpd*(julian+285.) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F b/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F index 4bf3c39591..6dcea74995 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F @@ -516,7 +516,7 @@ subroutine driver_seaice(configs,diag_physics,sfc_input,its,ite) ) - case("sf_noahmp") + case("sf_noahmp", "sf_colm2024") call seaice_noah( & dz8w = dz_p , p8w3d = pres2_hyd_p , t3d = t_p , & qv3d = qv_p , xice = xice_p , snoalb2d = snoalb_p , & diff --git a/src/core_atmosphere/physics/mpas_atmphys_finalize.F b/src/core_atmosphere/physics/mpas_atmphys_finalize.F index 5367d83286..55b8d7bdaa 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_finalize.F +++ b/src/core_atmosphere/physics/mpas_atmphys_finalize.F @@ -10,12 +10,13 @@ module mpas_atmphys_finalize use mpas_pool_routines use mpas_atmphys_lsm_noahmpfinalize,only: sf_noahmp_deallocate + use mpas_atmphys_driver_lsm_colm2024,only: checkpoint_lsm_colm2024, finalize_lsm_colm2024 use module_mp_thompson use cires_ugwpv1_module implicit none private - public:: atmphys_finalize + public:: atmphys_write_restart, atmphys_finalize !mpas_atmphys_finalize contains subroutines that deallocate arrays used in physics parameterizations, i.e. arrays !that need to remain allocated as long as MPAS runs and are not properly deallocated in the sourcecode itself. @@ -32,6 +33,18 @@ module mpas_atmphys_finalize contains +!================================================================================================================= + subroutine atmphys_write_restart(configs) +!================================================================================================================= + + type(mpas_pool_type),intent(in):: configs + character(len=StrKIND),pointer:: config_lsm_scheme + + call mpas_pool_get_config(configs,'config_lsm_scheme',config_lsm_scheme) + if(trim(config_lsm_scheme) == 'sf_colm2024') call checkpoint_lsm_colm2024 + + end subroutine atmphys_write_restart + !================================================================================================================= subroutine atmphys_finalize(configs) @@ -46,7 +59,7 @@ subroutine atmphys_finalize(configs) character(len=StrKIND),pointer:: config_gwdo_scheme logical,pointer:: config_ngw_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) @@ -55,6 +68,8 @@ subroutine atmphys_finalize(configs) if(trim(config_lsm_scheme) == 'sf_noahmp') & call sf_noahmp_deallocate + if(trim(config_lsm_scheme) == 'sf_colm2024') & + call finalize_lsm_colm2024 if(trim(config_microp_scheme) == 'mp_thompson' .or. & trim(config_microp_scheme) == 'mp_thompson_aerosols') then @@ -72,7 +87,7 @@ subroutine mp_thompson_deallocate !call mpas_log_write('') !call mpas_log_write('--- enter subroutine mp_thompson_deallocate:') - if(allocated(tcg_racg) ) deallocate(tcg_racg ) + if(allocated(tcg_racg) ) deallocate(tcg_racg ) if(allocated(tmr_racg) ) deallocate(tmr_racg ) if(allocated(tcr_gacr) ) deallocate(tcr_gacr ) if(allocated(tmg_gacr) ) deallocate(tmg_gacr ) diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 5183f5a974..b8a2dbc14a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -23,6 +23,7 @@ module mpas_atmphys_init use mpas_atmphys_landuse use mpas_atmphys_o3climatology use mpas_atmphys_lsm_noahmpinit,only: init_lsm_noahmp + use mpas_atmphys_driver_lsm_colm2024,only: init_lsm_colm2024 use bl_ugwpv1_ngw, only: ugwpv1_ngw_init @@ -74,21 +75,23 @@ module mpas_atmphys_init ! * added call to subroutine init_lsm_noahmp to initialize the Noah-MP land surface scheme. ! Laura D. Fowler (laura@ucar.edu) / 2024-03-11. ! * added initialization of the integer variable mp_top_level to the physics_init code. -! Bill Skamarock / 2025-10-17 +! Bill Skamarock / 2025-10-17 contains !================================================================================================================= - subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_physics,state,time_lev,diag_physics, & + subroutine physics_init(dminfo,stream_manager,clock,block,configs,mesh,diag,tend,tend_physics,state,time_lev,diag_physics, & diag_physics_noahmp,ngw_input,atm_input,sfc_input,output_noahmp) !================================================================================================================= use mpas_stream_manager +use mpas_derived_types, only: block_type !input arguments: type(dm_info),intent(in):: dminfo type(MPAS_streamManager_type),intent(inout):: stream_manager + type(block_type),intent(in):: block type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: configs type(MPAS_Clock_type),intent(in):: clock @@ -158,7 +161,7 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_ type(MPAS_Time_Type):: currTime logical:: init_done - integer:: ierr,julday + integer:: ierr,julday integer:: iCell,iLag,k real(kind=RKIND):: layer_height @@ -420,6 +423,8 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_ call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) elseif(config_lsm_scheme .eq. 'sf_noahmp') then call init_lsm_noahmp(configs,mesh,clock,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) + elseif(config_lsm_scheme .eq. 'sf_colm2024') then + call init_lsm_colm2024(dminfo,configs,clock,block) endif endif @@ -437,7 +442,7 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_ !initialization of longwave radiation processes: if we run the CAM radiation codes, the initia !lization of the longwave and shortwave parameterizations is the same, and needs to be called !only once: - if(config_radt_lw_scheme.ne.'off') then + if(config_radt_lw_scheme.ne.'off') then if(trim(config_radt_lw_scheme) .eq. 'cam_lw') then if(.not. init_done) then call init_radiation_lw(dminfo,configs,mesh,atm_input,diag,diag_physics,state,time_lev) diff --git a/src/core_atmosphere/physics/mpas_atmphys_packages.F b/src/core_atmosphere/physics/mpas_atmphys_packages.F index 5d32cb297e..e24907b8c5 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_packages.F +++ b/src/core_atmosphere/physics/mpas_atmphys_packages.F @@ -41,6 +41,7 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) 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 + logical,pointer:: sf_colm2024_in integer :: ierr @@ -178,8 +179,11 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) nullify(sf_noahmp_in) call mpas_pool_get_package(packages,'sf_noahmp_inActive',sf_noahmp_in) + nullify(sf_colm2024_in) + call mpas_pool_get_package(packages,'sf_colm2024_inActive',sf_colm2024_in) - if(.not.associated(sf_noahmp_in)) then + if(.not.associated(sf_noahmp_in) .or. & + .not.associated(sf_colm2024_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) @@ -187,11 +191,18 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) return endif + sf_noahmp_in = .false. + sf_colm2024_in = .false. + if(config_lsm_scheme=='sf_noahmp') then sf_noahmp_in = .true. endif + if(config_lsm_scheme=='sf_colm2024') then + sf_colm2024_in = .true. + endif call mpas_log_write(' sf_noahmp_in = $l', logicArgs=(/sf_noahmp_in/)) + call mpas_log_write(' sf_colm2024_in = $l', logicArgs=(/sf_colm2024_in/)) call mpas_log_write('') @@ -200,6 +211,3 @@ end function atmphys_setup_packages !================================================================================================================= end module mpas_atmphys_packages !================================================================================================================= - - - diff --git a/src/core_atmosphere/physics/mpas_atmphys_sfc_diagnostics.F b/src/core_atmosphere/physics/mpas_atmphys_sfc_diagnostics.F index 6e3a84c394..bf830df049 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_sfc_diagnostics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_sfc_diagnostics.F @@ -115,6 +115,11 @@ subroutine atmphys_sfc_diagnostics(configs,mesh,diag,diag_physics,sfc_input,outp th2m(i) = t2m(i)*(P0/psfc(i))**rcp enddo + case("sf_colm2024") + do i = 1,nCellsSolve + th2m(i) = t2m(i)*(P0/psfc(i))**rcp + enddo + case default end select sf_select @@ -125,4 +130,3 @@ end subroutine atmphys_sfc_diagnostics !================================================================================================================= end module mpas_atmphys_sfc_diagnostics !================================================================================================================= - diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 134009f537..a64e18b2aa 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -579,7 +579,7 @@ module mpas_atmphys_vars qgh_p, &! qsfc_p, &!specific humidity at lower boundary [kg/kg] regime_p, &!flag indicating PBL regime (stable_p,unstable_p,etc...) [-] - rmol_p, &!1 / Monin Ob length [-] + rmol_p, &!1 / Monin Ob length [m-1] t2m_p, &!temperature at 2m [K] th2m_p, &!potential temperature at 2m [K] u10_p, &!u at 10 m [m/s] @@ -867,7 +867,7 @@ module mpas_atmphys_vars shdmin_p, &!minimum areal fractional coverage of annual green vegetation [-] shdmax_p, &!maximum areal fractional coverage of annual green vegetation [-] smstav_p, &!moisture availability [-] - smstot_p, &!total moisture [m3 m-3] + smstot_p, &!total frozen and unfrozen soil-column water [mm] snopcx_p, &!snow phase change heat flux [W m-2] snotime_p, &! snowc_p, &!snow water equivalent [kg m-2] diff --git a/src/core_atmosphere/physics/physics_colm2024/.gitignore b/src/core_atmosphere/physics/physics_colm2024/.gitignore new file mode 100644 index 0000000000..62b6d29223 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/.gitignore @@ -0,0 +1,13 @@ + +.DS_Store +*.pyc +__pycache__ +*.o +*.mod +.vscode +.bld +.mpas +lib +*.a +*.x +*.log diff --git a/src/core_atmosphere/physics/physics_colm2024/README.md b/src/core_atmosphere/physics/physics_colm2024/README.md new file mode 100644 index 0000000000..f3df9c9d74 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/README.md @@ -0,0 +1,22 @@ +# MPAS-Embedded CoLM2024 + +This directory contains the CoLM2024 land-surface physics used by +MPAS-Atmosphere when `config_lsm_scheme = 'sf_colm2024'`. + +Build CoLM2024 through MPAS: + +- CMake: configure with `-DMPAS_COLM2024=ON`. +- Make: build atmosphere with `COLM2024=true`. + +Run with `config_num_soil_layers = 10`. CoLM keeps its native 10-layer soil +column and its patch/PFT state; MPAS cells map one-to-one to CoLM elements. + +MPAS initializes MPI and passes its domain communicator to CoLM. CoLM does not +start a separate process pool or require extra ranks. The MPAS LSM driver owns a +duplicated communicator context that isolates CoLM river-routing, remapping, and +restart messages while using the same MPAS processes. Distributed CoLM code still +issues the collectives and point-to-point exchanges required by those algorithms, +but only on this borrowed MPAS-owned context; it never owns an MPI runtime. + +Standalone CoLM run cases, forcing namelist examples, and evaluation scripts +are intentionally not kept in this embedded source tree. diff --git a/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 new file mode 100644 index 0000000000..a5c6a42a2a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90 @@ -0,0 +1,2297 @@ +#include + +MODULE MOD_CoLM_MPAS_Interface + + USE MOD_Precision + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + USE MOD_LandPatch, only: numpatch, landpatch, elm_patch + USE MOD_Vars_Global, only: spval, nl_soil, dz_soi, pi + USE MOD_Vars_1DForcing, only: forc_pco2m, forc_po2m, forc_us, forc_vs, forc_t, forc_q, & + forc_prc, forc_prl, forc_rain, forc_snow, forc_psrf, forc_pbot, forc_sols, forc_soll, & + forc_solsd, forc_solld, forc_frl, forc_swrad, forc_hgt_u, forc_hgt_t, forc_hgt_q, & + forc_rhoair, forc_ozone, forc_hpbl, forc_aerdep +#ifdef HYPERSPECTRAL + USE MOD_Vars_1DForcing, only: forc_solarin +#endif + USE MOD_Vars_1DFluxes, only: oroflag, fsena, lfevpa, fevpa, fgrnd, rnof, rsur, rsub + USE MOD_Vars_TimeInvariants, only: patchmask, patchtype, htop +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeInvariants, only: htop_p, pftfrac + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e +#endif + USE MOD_Vars_TimeVariables, only: t_grnd, trad, tref, qref, qsfc, emis, z0m, displa, alb, & + ldew, scv, snowdp, fsno, lai, fveg, rstfacsun_out, rstfacsha_out, & + t_soisno, wliq_soisno, wice_soisno, coszen, zol, rib, ustar, fm, fh, fq + USE MOD_Const_Physical, only: vonkar, denh2o, denice + USE MOD_FrictionVelocity, only: moninobuk + USE MOD_TurbulenceLEddy, only: moninobuk_leddy + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT + USE MOD_TimeManager, only: timestamp + + IMPLICIT NONE + PRIVATE + + PUBLIC :: colm_mpas_initialize_from_namelist + PUBLIC :: colm_mpas_finalize + PUBLIC :: colm_mpas_ready + PUBLIC :: colm_mpas_set_element_forcing + PUBLIC :: colm_mpas_step + PUBLIC :: colm_mpas_force_restart + PUBLIC :: colm_mpas_get_surface + PUBLIC :: colm_mpas_get_element_surface + PUBLIC :: colm_mpas_get_element_boundary_state + PUBLIC :: colm_mpas_get_element_state + PUBLIC :: colm_mpas_get_element_river_state + + logical, save :: colm_mpas_initialized = .false. + character(len=256), save :: colm_mpas_casename = '' + character(len=256), save :: colm_mpas_dir_landdata = '' + character(len=256), save :: colm_mpas_dir_restart = '' + integer, save :: colm_mpas_lc_year = -1 + integer, save :: colm_mpas_last_lai_year = -1 + integer, save :: colm_mpas_last_lai_period = -1 + integer, save :: colm_mpas_last_idate(3) = -1 + integer, save :: colm_mpas_last_restart_idate(3) = -1 + type(timestamp), save :: colm_mpas_ptstamp + type(timestamp), save :: colm_mpas_etstamp + logical, save :: colm_mpas_restart_ready = .false. + + INTERFACE + SUBROUTINE CoLMDRIVER(idate,deltim,dolai,doalb,dosst,oro) + USE MOD_Precision + USE MOD_LandPatch, only: numpatch + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: dolai, doalb, dosst + real(r8), intent(inout) :: oro(numpatch) + END SUBROUTINE CoLMDRIVER + END INTERFACE + +CONTAINS + + SUBROUTINE colm_mpas_initialize_from_namelist(nlfile, ierr, mpas_comm, mpas_cell_id, & + mpas_cell_lat, mpas_cell_lon, & + n_mpas_cells, cell_to_element, mpas_start_idate, & + mpas_stop_idate, mpas_timestep, mpas_is_restart) + USE MOD_Namelist, only: read_namelist, DEF_CASE_NAME, DEF_dir_landdata, & + DEF_dir_restart, DEF_LC_YEAR, DEF_simulation_time, DEF_USE_SNICAR, & + DEF_file_snowoptics, DEF_file_snowaging, DEF_Reservoir_Method, & + DEF_WRST_FREQ, DEF_HIST_FREQ, DEF_HIST_WriteBack, DEF_LAI_MONTHLY, & + DEF_LAI_CHANGE_YEARLY + USE MOD_Vars_Global, only: Init_GlobalVars + USE MOD_MPAS_MPI, only: mpas_mpi_attach, mpas_is_root + USE MOD_Const_LC, only: Init_LC_Const +#ifdef HYPERSPECTRAL + USE MOD_Const_PFT, only: Init_PFT_Const, rho_p, tau_p +#else + USE MOD_Const_PFT, only: Init_PFT_Const +#endif + USE MOD_TimeManager, only: initimetype, monthday2julian, julian2monthday, adj2begin, adj2end + USE MOD_Block, only: gblock + USE MOD_Pixel, only: pixel + USE MOD_Mesh, only: numelm + USE MOD_LandElm, only: landelm +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: landpft, numpft, map_patch_to_pft +#endif + USE MOD_SrfdataRestart, only: mesh_load_from_file, pixelset_load_from_file + USE MOD_Vars_TimeInvariants, only: allocate_TimeInvariants, READ_TimeInvariants + USE MOD_Vars_TimeVariables, only: allocate_TimeVariables, READ_TimeVariables + USE MOD_Opt_Baseflow, only: Opt_Baseflow_init + USE MOD_Vars_1DForcing, only: allocate_1D_Forcing + USE MOD_Vars_1DFluxes, only: allocate_1D_Fluxes +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeNetwork, only: build_riverlake_network + USE MOD_Grid_Reservoir, only: reservoir_init + USE MOD_Grid_RiverLakeFlow, only: grid_riverlake_flow_init +#endif +#ifdef HYPERSPECTRAL + USE MOD_SnowSnicar_HiRes, only: SnowAge_init, SnowOptics_init + USE MOD_HighRes_Parameters, only: flux_frac_init, leaf_property_init, & + get_water_optical_properties +#else + USE MOD_SnowSnicar, only: SnowAge_init, SnowOptics_init +#endif + character(len=*), intent(in) :: nlfile + integer, intent(out) :: ierr + integer, intent(in) :: mpas_comm + integer, intent(in) :: mpas_cell_id(:) + real(r8), intent(in) :: mpas_cell_lat(:) + real(r8), intent(in) :: mpas_cell_lon(:) + integer, intent(in) :: n_mpas_cells + integer, intent(out) :: cell_to_element(:) + integer, intent(in) :: mpas_start_idate(3) + integer, intent(in) :: mpas_stop_idate(3) + real(r8), intent(in) :: mpas_timestep + logical, intent(in) :: mpas_is_restart + + character(len=256) :: casename + character(len=256) :: dir_landdata + character(len=256) :: dir_restart + integer :: lc_year + integer :: sdate(3) + integer :: jdate(3) + integer :: s_julian + integer :: p_julian + integer :: n_mpas + integer :: i + integer :: lai_month + integer :: lai_mday + integer*8, allocatable :: mpas_cell_id_i8(:) + + ierr = 1 + IF (colm_mpas_initialized) THEN + ierr = 0 + RETURN + ENDIF + + CALL mpas_mpi_attach(mpas_comm) + + CALL read_namelist(trim(nlfile)) + IF (.not. ieee_is_finite(mpas_timestep) .or. mpas_timestep <= 0._r8 .or. mpas_timestep > 3600._r8) THEN + IF (mpas_is_root) write(*,'(A)') 'CoLM2024 MPAS timestep must be finite and in (0, 3600] seconds.' + RETURN + ENDIF + DEF_simulation_time%timestep = mpas_timestep + DEF_WRST_FREQ = 'none' + CALL colm_mpas_check_embedded_io(ierr) + IF (ierr /= 0) RETURN + + casename = DEF_CASE_NAME + dir_landdata = DEF_dir_landdata + dir_restart = DEF_dir_restart + lc_year = DEF_LC_YEAR + + CALL initimetype(DEF_simulation_time%greenwich) + CALL monthday2julian(DEF_simulation_time%start_year, DEF_simulation_time%start_month, & + DEF_simulation_time%start_day, s_julian) + CALL monthday2julian(DEF_simulation_time%spinup_year, DEF_simulation_time%spinup_month, & + DEF_simulation_time%spinup_day, p_julian) + sdate(1) = DEF_simulation_time%start_year + sdate(2) = s_julian + sdate(3) = DEF_simulation_time%start_sec + + IF (mpas_is_restart) THEN + sdate(:) = mpas_start_idate(:) + ELSEIF (any(sdate /= mpas_start_idate)) THEN + IF (mpas_is_root) THEN + write(*,'(A,3(I0,1X))') 'CoLM2024 namelist start timestamp (year, day-of-year, second): ', sdate + write(*,'(A,3(I0,1X))') 'MPAS start timestamp (year, day-of-year, second): ', mpas_start_idate + write(*,'(A)') 'Set DEF_simulation_time start values to the MPAS cold-start time.' + ENDIF + RETURN + ENDIF + IF (DEF_simulation_time%spinup_repeat /= 1 .or. & + DEF_simulation_time%spinup_year > sdate(1) .or. & + (DEF_simulation_time%spinup_year == sdate(1) .and. p_julian > sdate(2)) .or. & + (DEF_simulation_time%spinup_year == sdate(1) .and. p_julian == sdate(2) .and. & + DEF_simulation_time%spinup_sec > sdate(3))) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 standalone spinup cycles cannot be embedded inside the MPAS atmosphere clock.' + write(*,'(A)') 'Use spinup_repeat = 1 and a spinup endpoint no later than the MPAS start timestamp.' + ENDIF + RETURN + ENDIF + + colm_mpas_casename = casename + colm_mpas_dir_landdata = dir_landdata + colm_mpas_dir_restart = dir_restart + colm_mpas_lc_year = lc_year + colm_mpas_last_lai_year = -1 + colm_mpas_last_lai_period = -1 + colm_mpas_ptstamp%year = DEF_simulation_time%spinup_year + colm_mpas_ptstamp%day = p_julian + colm_mpas_ptstamp%sec = DEF_simulation_time%spinup_sec + colm_mpas_etstamp%year = mpas_stop_idate(1) + colm_mpas_etstamp%day = mpas_stop_idate(2) + colm_mpas_etstamp%sec = mpas_stop_idate(3) + colm_mpas_last_idate(:) = -1 + colm_mpas_last_restart_idate(:) = -1 + + CALL Init_GlobalVars + CALL Init_LC_Const + CALL Init_PFT_Const + + n_mpas = 0 + n_mpas = n_mpas_cells + IF (n_mpas < 0) RETURN + IF (size(mpas_cell_id) < n_mpas) RETURN + IF (size(mpas_cell_lat) < n_mpas) RETURN + IF (size(mpas_cell_lon) < n_mpas) RETURN + IF (size(cell_to_element) < n_mpas) RETURN + + allocate(mpas_cell_id_i8(n_mpas)) + DO i = 1, n_mpas + mpas_cell_id_i8(i) = int(mpas_cell_id(i), 8) + ENDDO + + CALL pixel%load_from_file(dir_landdata) + CALL gblock%load_from_file(dir_landdata) + + CALL colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id_i8, mpas_cell_lat, & + mpas_cell_lon, n_mpas, ierr) + IF (ierr /= 0) RETURN + + CALL mesh_load_from_file(dir_landdata, lc_year, subset_eindex=mpas_cell_id_i8) + CALL pixelset_load_from_file(dir_landdata, 'landelm', landelm, numelm, lc_year, & + subset_eindex=mpas_cell_id_i8) + CALL pixelset_load_from_file(dir_landdata, 'landpatch', landpatch, numpatch, lc_year, & + subset_eindex=mpas_cell_id_i8) + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year, & + subset_eindex=mpas_cell_id_i8) +#endif + + IF (n_mpas > 0) THEN + CALL colm_mpas_restrict_to_mpas_cells(mpas_cell_id, n_mpas, cell_to_element, ierr) + IF (ierr /= 0) RETURN + CALL colm_mpas_validate_cell_geometry(mpas_cell_id, mpas_cell_lat, mpas_cell_lon, & + n_mpas, cell_to_element, ierr) + IF (ierr /= 0) RETURN + ENDIF + + CALL elm_patch%build(landelm, landpatch, use_frac = .true.) + CALL colm_mpas_validate_element_patch_map(.false., ierr) + IF (ierr /= 0) RETURN + +#ifdef GridRiverLakeFlow + CALL colm_mpas_check_embedded_riverlake(ierr) + IF (ierr /= 0) RETURN + CALL build_riverlake_network() + IF (DEF_Reservoir_Method > 0) CALL reservoir_init() +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL map_patch_to_pft +#endif + + CALL adj2end(sdate) + jdate = sdate + CALL adj2begin(jdate) + + CALL allocate_TimeInvariants() + CALL READ_TimeInvariants(lc_year, casename, dir_restart) + CALL colm_mpas_validate_element_patch_map(.true., ierr) + IF (ierr /= 0) RETURN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL colm_mpas_validate_pft_fractions(ierr) + IF (ierr /= 0) RETURN +#endif + CALL allocate_TimeVariables() + CALL READ_TimeVariables(jdate, lc_year, casename, dir_restart, mpas_is_restart) + ! Soil hydrology always applies this factor. The embedded path reads a + ! calibrated vector when present and otherwise initializes every patch to 1. + CALL Opt_Baseflow_init() + + IF (DEF_LAI_CHANGE_YEARLY) THEN + colm_mpas_last_lai_year = jdate(1) + ELSE + colm_mpas_last_lai_year = lc_year + ENDIF + IF (DEF_LAI_MONTHLY) THEN + CALL julian2monthday(jdate(1), jdate(2), lai_month, lai_mday) + colm_mpas_last_lai_period = lai_month + ELSE + colm_mpas_last_lai_period = 1 + (jdate(2) - 1) / 8 + ENDIF + + IF (DEF_USE_SNICAR) THEN + CALL SnowOptics_init(DEF_file_snowoptics) + CALL SnowAge_init(DEF_file_snowaging) + ENDIF + +#ifdef HYPERSPECTRAL + CALL flux_frac_init() + CALL leaf_property_init(rho_p, tau_p) + CALL get_water_optical_properties() +#endif + + CALL allocate_1D_Forcing() + CALL allocate_1D_Fluxes() + +#ifdef GridRiverLakeFlow + CALL grid_riverlake_flow_init() +#endif + + colm_mpas_last_idate(:) = sdate(:) + colm_mpas_restart_ready = .true. + colm_mpas_initialized = .true. + ierr = 0 + END SUBROUTINE colm_mpas_initialize_from_namelist + +#ifdef GridRiverLakeFlow + SUBROUTINE colm_mpas_check_embedded_riverlake(ierr) + USE MOD_Namelist, only: DEF_USE_SEDIMENT, DEF_Reservoir_Method + USE MOD_MPAS_MPI, only: mpas_size, mpas_is_root + integer, intent(out) :: ierr + + ierr = 0 + IF (DEF_USE_SEDIMENT) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode does not support GridRiverLakeSediment yet.' + write(*,'(A)') 'Set DEF_USE_SEDIMENT = .false. until sediment routing is migrated to MPAS-owned rank decomposition.' + ENDIF + ierr = 1 + RETURN + ENDIF + IF (DEF_Reservoir_Method < 0 .or. DEF_Reservoir_Method > 1) THEN + IF (mpas_is_root) THEN + write(*,'(A,I0)') 'Unsupported CoLM2024 embedded reservoir method: ', DEF_Reservoir_Method + write(*,'(A)') 'Use DEF_Reservoir_Method = 0 (off) or 1.' + ENDIF + ierr = 1 + RETURN + ENDIF + IF (mpas_size > 1 .and. mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded GridRiverLakeFlow uses MPAS communicator ranks for distributed routing.' + write(*,'(A)') 'No replicated full-river-network fallback is used.' + ENDIF + END SUBROUTINE colm_mpas_check_embedded_riverlake +#endif + + SUBROUTINE colm_mpas_check_embedded_io(ierr) + USE MOD_Namelist, only: DEF_HIST_FREQ, DEF_HIST_WriteBack, USE_SITE_HistWriteBack, & + DEF_USE_SNICAR, DEF_Aerosol_Readin, DEF_USE_Forcing_Downscaling, & + DEF_USE_Forcing_Downscaling_Simple, DEF_USE_ClimForcing_for_Spinup, & + DEF_Optimize_Baseflow, DEF_CheckEquilibrium, DEF_DA_TWS, DEF_DA_SM, & + DEF_DA_ENS_SM, DEF_DA_TWS_GRACE, DEF_DA_SM_SMAP, DEF_DA_SM_FY, & + DEF_DA_SM_SYNOP + USE MOD_MPAS_MPI, only: mpas_is_root + integer, intent(out) :: ierr + + ierr = 0 + USE_SITE_HistWriteBack = .false. + IF ((trim(adjustl(DEF_HIST_FREQ)) /= 'none' .and. trim(adjustl(DEF_HIST_FREQ)) /= 'NONE') .or. & + DEF_HIST_WriteBack) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode currently writes fluxes through MPAS streams.' + write(*,'(A)') 'Disable CoLM DEF_HIST_FREQ/DEF_HIST_WriteBack; CoLM restart files remain supported for patch/PFT state.' + write(*,'(A)') 'CoLM USE_SITE_HistWriteBack is forced off in MPAS embedded mode.' + ENDIF + ierr = 1 + ENDIF + IF (DEF_USE_SNICAR .and. DEF_Aerosol_Readin) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode does not yet receive the 14-component aerosol deposition forcing.' + write(*,'(A)') 'Set DEF_Aerosol_Readin = .false., or add an MPAS aerosol-deposition source before enabling it.' + ENDIF + ierr = 1 + ENDIF + IF (DEF_USE_Forcing_Downscaling .or. DEF_USE_Forcing_Downscaling_Simple .or. & + DEF_USE_ClimForcing_for_Spinup) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode receives forcing directly from MPAS.' + write(*,'(A)') 'Disable CoLM forcing downscaling and climatological-forcing spinup options.' + ENDIF + ierr = 1 + ENDIF + IF (DEF_Optimize_Baseflow) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 MPAS embedded mode does not run the standalone annual baseflow optimizer.' + write(*,'(A)') 'Set DEF_Optimize_Baseflow = .false.; an existing scale_baseflow vector is still honored.' + ENDIF + ierr = 1 + ENDIF + IF (DEF_CheckEquilibrium) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 standalone spinup-equilibrium checking is unavailable under the MPAS clock.' + write(*,'(A)') 'Set DEF_CheckEquilibrium = .false. for MPAS embedded runs.' + ENDIF + ierr = 1 + ENDIF + IF (DEF_DA_TWS .or. DEF_DA_SM .or. DEF_DA_ENS_SM .or. DEF_DA_TWS_GRACE .or. & + DEF_DA_SM_SMAP .or. DEF_DA_SM_FY .or. DEF_DA_SM_SYNOP) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM2024 standalone data-assimilation drivers are not part of the MPAS embedded coupling.' + write(*,'(A)') 'Disable all DEF_DA_* switches and perform atmospheric/land analysis through MPAS.' + ENDIF + ierr = 1 + ENDIF + END SUBROUTINE colm_mpas_check_embedded_io + + SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, mpas_cell_lat, & + mpas_cell_lon, n_mpas_cells, ierr) + USE MOD_Block, only: gblock, get_filename_block + USE MOD_MPAS_MPI, only: mpas_rank + USE MOD_NetCDFSerial, only: ncio_read_serial + USE MOD_Utils, only: quicksort, find_in_sorted_list1, find_nearest_south, & + find_nearest_west, normalize_longitude + character(len=*), intent(in) :: dir_landdata + integer, intent(in) :: lc_year + integer*8, intent(in) :: mpas_cell_id(:) + real(r8), intent(in) :: mpas_cell_lat(:) + real(r8), intent(in) :: mpas_cell_lon(:) + integer, intent(in) :: n_mpas_cells + integer, intent(out) :: ierr + + logical, allocatable :: candidate_block(:,:) + logical, allocatable :: keep_block(:,:) + logical, allocatable :: found_element(:) + logical :: fexists + integer :: i + integer :: ie + integer :: iblk + integer :: jblk + integer :: iblkme + integer :: match + integer :: scan_pass + real(r8) :: lat_deg + real(r8) :: lon_deg + character(len=256) :: filename + character(len=256) :: fileblock + character(len=256) :: cyear + integer, allocatable :: order(:) + integer*8, allocatable :: elmindx(:) + integer*8, allocatable :: sorted_cell_id(:) + + ierr = 1 + IF (n_mpas_cells < 0) RETURN + IF (.not. allocated(gblock%owner_rank)) RETURN + IF (.not. allocated(gblock%lon_w)) RETURN + IF (.not. allocated(gblock%lat_s)) RETURN + IF (size(mpas_cell_id) < n_mpas_cells) RETURN + IF (size(mpas_cell_lat) < n_mpas_cells) RETURN + IF (size(mpas_cell_lon) < n_mpas_cells) RETURN + + allocate(candidate_block(gblock%nxblk, gblock%nyblk)) + allocate(keep_block(gblock%nxblk, gblock%nyblk)) + candidate_block = .false. + keep_block = .false. + + IF (n_mpas_cells == 0) THEN + gblock%owner_rank(:,:) = -1 + IF (allocated(gblock%xblkme)) deallocate(gblock%xblkme) + IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme) + gblock%nblkme = 0 + deallocate(candidate_block, keep_block) + ierr = 0 + RETURN + ENDIF + + allocate(found_element(n_mpas_cells)) + allocate(sorted_cell_id(n_mpas_cells)) + found_element = .false. + sorted_cell_id = mpas_cell_id(1:n_mpas_cells) + DO i = 1, n_mpas_cells + IF (.not. ieee_is_finite(mpas_cell_lat(i)) .or. .not. ieee_is_finite(mpas_cell_lon(i))) THEN + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + IF (abs(mpas_cell_lat(i)) > 0.5_r8 * pi + 1.e-12_r8 .or. & + abs(mpas_cell_lon(i)) > 4._r8 * pi) THEN + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + lat_deg = mpas_cell_lat(i) * 180._r8 / pi + lon_deg = mpas_cell_lon(i) * 180._r8 / pi + CALL normalize_longitude(lon_deg) + iblk = find_nearest_west(lon_deg, gblock%nxblk, gblock%lon_w) + jblk = find_nearest_south(lat_deg, gblock%nyblk, gblock%lat_s) + candidate_block(iblk,jblk) = .true. + ENDDO + + IF (n_mpas_cells > 1) THEN + allocate(order(n_mpas_cells)) + order = (/ (i, i = 1, n_mpas_cells) /) + CALL quicksort(n_mpas_cells, sorted_cell_id, order) + deallocate(order) + + DO i = 2, n_mpas_cells + IF (sorted_cell_id(i) == sorted_cell_id(i-1)) THEN + write(*,'(A,I0,A,I0)') 'CoLM2024 MPAS embedded duplicate cell/eindex on rank ', & + mpas_rank, ': ', sorted_cell_id(i) + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + ENDDO + ENDIF + + write(cyear,'(i4.4)') lc_year + filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc' + + ! CoLM writes an element to the block containing most of its pixels, which + ! is usually the block containing the MPAS cell center but is not guaranteed + ! to be. Probe center blocks first, verify by exact eindex, then scan only + ! the remaining blocks when an irregular or boundary cell was not found. + DO scan_pass = 1, 2 + IF (scan_pass == 2 .and. all(found_element)) EXIT + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (scan_pass == 1 .and. .not. candidate_block(iblk,jblk)) CYCLE + IF (scan_pass == 2 .and. candidate_block(iblk,jblk)) CYCLE + CALL get_filename_block(filename, iblk, jblk, fileblock) + inquire(file=trim(fileblock), exist=fexists) + IF (.not. fexists) CYCLE + + CALL ncio_read_serial(fileblock, 'elmindex', elmindx) + DO ie = 1, size(elmindx) + match = find_in_sorted_list1(elmindx(ie), n_mpas_cells, sorted_cell_id) + IF (match > 0) THEN + IF (found_element(match)) THEN + write(*,'(A,I0,A,I0)') 'CoLM2024 MPAS embedded mesh contains duplicate eindex on rank ', & + mpas_rank, ': ', sorted_cell_id(match) + deallocate(elmindx, candidate_block, keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + keep_block(iblk,jblk) = .true. + found_element(match) = .true. + ENDIF + ENDDO + IF (allocated(elmindx)) deallocate(elmindx) + ENDDO + ENDDO + ENDDO + + IF (count(found_element) /= n_mpas_cells) THEN + DO i = 1, n_mpas_cells + IF (.not. found_element(i)) THEN + write(*,'(A,I0,A,I0)') 'CoLM2024 MPAS embedded mesh is missing cell/eindex on rank ', & + mpas_rank, ': ', sorted_cell_id(i) + EXIT + ENDIF + ENDDO + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + + gblock%owner_rank(:,:) = -1 + WHERE (keep_block) + gblock%owner_rank = mpas_rank + END WHERE + + IF (allocated(gblock%xblkme)) deallocate(gblock%xblkme) + IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme) + gblock%nblkme = count(keep_block) + IF (gblock%nblkme < 1) THEN + write(*,'(A,I0)') 'CoLM2024 MPAS embedded found no local mesh blocks for rank ', mpas_rank + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) + RETURN + ENDIF + + allocate(gblock%xblkme(gblock%nblkme)) + allocate(gblock%yblkme(gblock%nblkme)) + iblkme = 0 + DO iblk = 1, gblock%nxblk + DO jblk = 1, gblock%nyblk + IF (keep_block(iblk,jblk)) THEN + iblkme = iblkme + 1 + gblock%xblkme(iblkme) = iblk + gblock%yblkme(iblkme) = jblk + ENDIF + ENDDO + ENDDO + + deallocate(candidate_block, keep_block, found_element, sorted_cell_id) + ierr = 0 + END SUBROUTINE colm_mpas_claim_owned_blocks + + SUBROUTINE colm_mpas_finalize(ierr) +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeFlow, only: grid_riverlake_flow_final +#endif + USE MOD_Vars_1DForcing, only: deallocate_1D_Forcing + USE MOD_Vars_1DFluxes, only: deallocate_1D_Fluxes + USE MOD_Vars_TimeVariables, only: deallocate_TimeVariables + USE MOD_Vars_TimeInvariants, only: deallocate_TimeInvariants + USE MOD_Opt_Baseflow, only: Opt_Baseflow_final + USE MOD_NetCDFVector, only: ncio_reset_distributed_validation + USE MOD_MPAS_MPI, only: mpas_mpi_detach + USE MOD_LandElm, only: landelm + USE MOD_LandPatch, only: patch2elm, grid_patch + USE MOD_Mesh, only: mesh_free_mem + USE MOD_Grid, only: grid_free_mem + USE MOD_Pixel, only: pixel + USE MOD_Block, only: gblock +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: landpft, numpft, pft2patch +#endif + integer, intent(out) :: ierr + + ierr = 0 + IF (.not. colm_mpas_initialized) RETURN + + IF (colm_mpas_last_idate(1) > 0) THEN + CALL colm_mpas_write_restart_if_due(colm_mpas_last_idate, 0._r8, .true., ierr) + IF (ierr /= 0) RETURN + ENDIF + +#ifdef GridRiverLakeFlow + CALL grid_riverlake_flow_final() +#endif + CALL Opt_Baseflow_final() + CALL deallocate_1D_Fluxes() + CALL deallocate_1D_Forcing() + CALL deallocate_TimeVariables() + CALL deallocate_TimeInvariants() + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL landpft%forc_free_mem() + IF (allocated(patch_pft_s)) deallocate(patch_pft_s) + IF (allocated(patch_pft_e)) deallocate(patch_pft_e) + IF (allocated(pft2patch)) deallocate(pft2patch) + numpft = 0 +#endif + IF (allocated(elm_patch%substt)) deallocate(elm_patch%substt) + IF (allocated(elm_patch%subend)) deallocate(elm_patch%subend) + IF (allocated(elm_patch%subfrc)) deallocate(elm_patch%subfrc) + IF (allocated(patch2elm%sup)) deallocate(patch2elm%sup) + CALL landpatch%forc_free_mem() + CALL landelm%forc_free_mem() + CALL grid_free_mem(grid_patch) + numpatch = 0 + CALL mesh_free_mem() + + IF (allocated(pixel%lat_s)) deallocate(pixel%lat_s) + IF (allocated(pixel%lat_n)) deallocate(pixel%lat_n) + IF (allocated(pixel%lon_w)) deallocate(pixel%lon_w) + IF (allocated(pixel%lon_e)) deallocate(pixel%lon_e) + pixel%nlon = 0 + pixel%nlat = 0 + + IF (allocated(gblock%lat_s)) deallocate(gblock%lat_s) + IF (allocated(gblock%lat_n)) deallocate(gblock%lat_n) + IF (allocated(gblock%lon_w)) deallocate(gblock%lon_w) + IF (allocated(gblock%lon_e)) deallocate(gblock%lon_e) + IF (allocated(gblock%owner_rank)) deallocate(gblock%owner_rank) + IF (allocated(gblock%xblkme)) deallocate(gblock%xblkme) + IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme) + gblock%nxblk = 0 + gblock%nyblk = 0 + gblock%nblkme = 0 + CALL ncio_reset_distributed_validation() + + CALL mpas_mpi_detach() + colm_mpas_initialized = .false. + colm_mpas_restart_ready = .false. + colm_mpas_casename = '' + colm_mpas_dir_landdata = '' + colm_mpas_dir_restart = '' + colm_mpas_lc_year = -1 + colm_mpas_last_lai_year = -1 + colm_mpas_last_lai_period = -1 + colm_mpas_last_idate(:) = -1 + colm_mpas_last_restart_idate(:) = -1 + END SUBROUTINE colm_mpas_finalize + + SUBROUTINE colm_mpas_restrict_to_mpas_cells(mpas_cell_id, n_mpas_cells, cell_to_element, ierr) + USE MOD_LandElm, only: landelm + USE MOD_LandPatch, only: landpatch, numpatch + USE MOD_Mesh, only: mesh, numelm + USE MOD_Utils, only: quicksort, find_in_sorted_list1 +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: landpft, numpft +#endif + integer, intent(in) :: mpas_cell_id(:) + integer, intent(in) :: n_mpas_cells + integer, intent(out) :: cell_to_element(:) + integer, intent(out) :: ierr + + logical, allocatable :: seen_element(:) + integer, allocatable :: element_order(:) + integer*8, allocatable :: sorted_eindex(:) + integer :: i + integer :: match + integer :: element + + ierr = 1 + IF (n_mpas_cells < 1) RETURN + IF (numelm /= n_mpas_cells) RETURN + IF (size(mpas_cell_id) < n_mpas_cells) RETURN + IF (size(cell_to_element) < n_mpas_cells) RETURN + IF (.not. allocated(mesh)) RETURN + IF (size(mesh) /= numelm) RETURN + IF (.not. allocated(landelm%ipxstt) .or. .not. allocated(landelm%ipxend)) RETURN + IF (size(landelm%ipxstt) /= landelm%nset .or. size(landelm%ipxend) /= landelm%nset) RETURN + + CALL colm_mpas_validate_pixelset_element_map(landelm, numelm, ierr) + IF (ierr /= 0 .or. landelm%nset /= numelm) RETURN + IF (numpatch /= landpatch%nset) RETURN + CALL colm_mpas_validate_pixelset_element_map(landpatch, numelm, ierr) + IF (ierr /= 0) RETURN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (numpft /= landpft%nset) RETURN + CALL colm_mpas_validate_pixelset_element_map(landpft, numelm, ierr) + IF (ierr /= 0) RETURN +#endif + + allocate(seen_element(numelm)) + allocate(sorted_eindex(numelm)) + allocate(element_order(numelm)) + + seen_element = .false. + DO i = 1, landelm%nset + element = landelm%ielm(i) + IF (seen_element(element)) RETURN + IF (landelm%ipxstt(i) /= 1 .or. landelm%ipxend(i) /= mesh(element)%npxl) RETURN + seen_element(element) = .true. + ENDDO + IF (.not. all(seen_element)) RETURN + seen_element = .false. + DO i = 1, numelm + sorted_eindex(i) = mesh(i)%indx + ENDDO + element_order = (/ (i, i = 1, numelm) /) + IF (numelm > 1) CALL quicksort(numelm, sorted_eindex, element_order) + IF (numelm > 1) THEN + IF (any(sorted_eindex(2:numelm) == sorted_eindex(1:numelm-1))) RETURN + ENDIF + + DO i = 1, n_mpas_cells + match = find_in_sorted_list1(int(mpas_cell_id(i), kind=8), numelm, sorted_eindex) + IF (match < 1) RETURN + element = element_order(match) + IF (seen_element(element)) RETURN + seen_element(element) = .true. + cell_to_element(i) = element + ENDDO + IF (.not. all(seen_element)) RETURN + + ierr = 0 + END SUBROUTINE colm_mpas_restrict_to_mpas_cells + + SUBROUTINE colm_mpas_validate_cell_geometry(mpas_cell_id, mpas_cell_lat, mpas_cell_lon, & + n_mpas_cells, cell_to_element, ierr) + USE MOD_Mesh, only: mesh, numelm + USE MOD_Pixel, only: pixel + USE MOD_Utils, only: normalize_longitude, lon_between_floor + USE MOD_MPAS_MPI, only: mpas_rank + integer, intent(in) :: mpas_cell_id(:) + real(r8), intent(in) :: mpas_cell_lat(:) + real(r8), intent(in) :: mpas_cell_lon(:) + integer, intent(in) :: n_mpas_cells + integer, intent(in) :: cell_to_element(:) + integer, intent(out) :: ierr + + integer :: i + integer :: element + integer :: ipxl + integer :: ilat + integer :: ilon + real(r8) :: lat_deg + real(r8) :: lon_deg + real(r8) :: lon_east_delta + logical :: contains_center + real(r8), parameter :: angular_tolerance = 1.e-8_r8 + + ierr = 1 + IF (n_mpas_cells < 1) RETURN + IF (size(mpas_cell_id) < n_mpas_cells .or. size(mpas_cell_lat) < n_mpas_cells .or. & + size(mpas_cell_lon) < n_mpas_cells .or. size(cell_to_element) < n_mpas_cells) RETURN + IF (.not. allocated(mesh)) RETURN + IF (size(mesh) /= numelm) RETURN + IF (.not. allocated(pixel%lat_s) .or. .not. allocated(pixel%lat_n) .or. & + .not. allocated(pixel%lon_w) .or. .not. allocated(pixel%lon_e)) RETURN + + DO i = 1, n_mpas_cells + IF (.not. ieee_is_finite(mpas_cell_lat(i)) .or. .not. ieee_is_finite(mpas_cell_lon(i))) RETURN + IF (abs(mpas_cell_lat(i)) > 0.5_r8 * pi + 1.e-12_r8 .or. & + abs(mpas_cell_lon(i)) > 4._r8 * pi) RETURN + + element = cell_to_element(i) + IF (element < 1 .or. element > numelm) RETURN + IF (mesh(element)%indx /= int(mpas_cell_id(i), kind=8)) RETURN + IF (mesh(element)%npxl < 1) RETURN + IF (.not. allocated(mesh(element)%ilat) .or. .not. allocated(mesh(element)%ilon)) RETURN + IF (size(mesh(element)%ilat) /= mesh(element)%npxl .or. & + size(mesh(element)%ilon) /= mesh(element)%npxl) RETURN + + lat_deg = mpas_cell_lat(i) * 180._r8 / pi + lon_deg = mpas_cell_lon(i) * 180._r8 / pi + CALL normalize_longitude(lon_deg) + contains_center = .false. + + DO ipxl = 1, mesh(element)%npxl + ilat = mesh(element)%ilat(ipxl) + ilon = mesh(element)%ilon(ipxl) + IF (ilat < 1 .or. ilat > pixel%nlat .or. ilon < 1 .or. ilon > pixel%nlon) RETURN + IF (.not. all(ieee_is_finite((/pixel%lat_s(ilat), pixel%lat_n(ilat), & + pixel%lon_w(ilon), pixel%lon_e(ilon)/)))) RETURN + + lon_east_delta = abs(modulo(lon_deg - pixel%lon_e(ilon) + 180._r8, 360._r8) - 180._r8) + IF (lat_deg >= pixel%lat_s(ilat) - angular_tolerance .and. & + lat_deg <= pixel%lat_n(ilat) + angular_tolerance .and. & + (lon_between_floor(lon_deg, pixel%lon_w(ilon), pixel%lon_e(ilon)) .or. & + lon_east_delta <= angular_tolerance)) THEN + contains_center = .true. + EXIT + ENDIF + ENDDO + + IF (.not. contains_center) THEN + write(*,'(A,I0,A,I0,A,I0,A,2(F13.7,1X))') & + 'CoLM2024 MPAS mesh mismatch on rank ', mpas_rank, ': local cell ', i, & + ', eindex ', mpas_cell_id(i), ', center lon/lat (degrees) ', lon_deg, lat_deg + RETURN + ENDIF + ENDDO + + ierr = 0 + END SUBROUTINE colm_mpas_validate_cell_geometry + + SUBROUTINE colm_mpas_validate_pixelset_element_map(pixelset, num_elements, ierr) + USE MOD_Pixelset, only: pixelset_type + USE MOD_Mesh, only: mesh + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: num_elements + integer, intent(out) :: ierr + + integer :: iset + integer :: element + + ierr = 1 + IF (pixelset%nset < 0) RETURN + IF (pixelset%nset == 0) THEN + ierr = 0 + RETURN + ENDIF + IF (.not. allocated(pixelset%eindex) .or. .not. allocated(pixelset%ielm)) RETURN + IF (size(pixelset%eindex) /= pixelset%nset .or. size(pixelset%ielm) /= pixelset%nset) RETURN + DO iset = 1, pixelset%nset + element = pixelset%ielm(iset) + IF (element < 1 .or. element > num_elements) RETURN + IF (pixelset%eindex(iset) /= mesh(element)%indx) RETURN + ENDDO + + ierr = 0 + END SUBROUTINE colm_mpas_validate_pixelset_element_map + + SUBROUTINE colm_mpas_validate_element_patch_map(require_active_patch, ierr) + USE MOD_LandElm, only: landelm + USE MOD_MPAS_MPI, only: mpas_rank + logical, intent(in) :: require_active_patch + integer, intent(out) :: ierr + + integer :: element + integer :: patch + integer :: istt + integer :: iend + integer :: local_missing + integer :: first_missing + logical :: valid_coverage + real(r8) :: fraction + real(r8) :: total_fraction + real(r8) :: active_fraction + real(r8), parameter :: fraction_tolerance = 1.e-10_r8 + + ierr = 1 + IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subend)) RETURN + IF (.not. allocated(elm_patch%subfrc)) RETURN + IF (size(elm_patch%substt) < landelm%nset) RETURN + IF (size(elm_patch%subend) < landelm%nset) RETURN + IF (size(elm_patch%subfrc) < numpatch) RETURN + IF (require_active_patch .and. numpatch > 0 .and. .not. allocated(patchmask)) RETURN + IF (require_active_patch .and. numpatch > 0) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + + local_missing = 0 + first_missing = -1 + + DO element = 1, landelm%nset + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + valid_coverage = istt >= 1 .and. iend >= istt .and. iend <= numpatch + total_fraction = 0._r8 + active_fraction = 0._r8 + + IF (valid_coverage) THEN + DO patch = istt, iend + fraction = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(fraction) .or. fraction < 0._r8) THEN + valid_coverage = .false. + EXIT + ENDIF + total_fraction = total_fraction + fraction + IF (.not. require_active_patch) THEN + active_fraction = active_fraction + fraction + ELSEIF (patchmask(patch)) THEN + active_fraction = active_fraction + fraction + ENDIF + ENDDO + ENDIF + IF (.not. ieee_is_finite(total_fraction) .or. & + abs(total_fraction - 1._r8) > fraction_tolerance) valid_coverage = .false. + IF (require_active_patch) THEN + IF (.not. ieee_is_finite(active_fraction) .or. & + abs(active_fraction - total_fraction) > fraction_tolerance) valid_coverage = .false. + ENDIF + + IF (.not. valid_coverage) THEN + local_missing = local_missing + 1 + IF (first_missing < 0) first_missing = element + ENDIF + ENDDO + + IF (local_missing > 0) THEN + IF (first_missing > 0 .and. first_missing <= landelm%nset) THEN + write(*,'(A,I0,A,I0,A,I0,A,I0)') & + 'CoLM2024 MPAS embedded landdata has incomplete patch coverage on rank ', & + mpas_rank, ': ', local_missing, ' element(s); first local element ', & + first_missing, ', eindex ', landelm%eindex(first_missing) + ELSE + write(*,'(A,I0,A,I0)') & + 'CoLM2024 MPAS embedded landdata has incomplete patch coverage on rank ', & + mpas_rank, ': ', local_missing + ENDIF + RETURN + ENDIF + + ierr = 0 + END SUBROUTINE colm_mpas_validate_element_patch_map + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE colm_mpas_validate_pft_fractions(ierr) + USE MOD_LandPFT, only: numpft + USE MOD_MPAS_MPI, only: mpas_rank + integer, intent(out) :: ierr + + integer :: patch + integer :: pft_start + integer :: pft_end + real(r8) :: fraction_sum + real(r8), parameter :: fraction_tolerance = 1.e-10_r8 + + ierr = 1 + IF (numpatch == 0) THEN + IF (numpft /= 0) RETURN + ierr = 0 + RETURN + ENDIF + IF (.not. allocated(patch_pft_s) .or. .not. allocated(patch_pft_e)) RETURN + IF (size(patch_pft_s) /= numpatch .or. size(patch_pft_e) /= numpatch) RETURN + IF (numpft > 0) THEN + IF (.not. allocated(pftfrac)) RETURN + IF (size(pftfrac) /= numpft) RETURN + ENDIF + + DO patch = 1, numpatch + pft_start = patch_pft_s(patch) + pft_end = patch_pft_e(patch) + IF (pft_start == -1 .or. pft_end == -1) THEN + IF (pft_start /= -1 .or. pft_end /= -1) EXIT + ELSE + IF (pft_start < 1 .or. pft_end < pft_start .or. pft_end > numpft) EXIT + IF (.not. all(ieee_is_finite(pftfrac(pft_start:pft_end)))) EXIT + IF (any(pftfrac(pft_start:pft_end) < 0._r8)) EXIT + fraction_sum = sum(pftfrac(pft_start:pft_end)) + IF (.not. ieee_is_finite(fraction_sum) .or. & + abs(fraction_sum - 1._r8) > fraction_tolerance) EXIT + ENDIF + ENDDO + + IF (patch <= numpatch) THEN + write(*,'(A,I0,A,I0,A,I0)') 'CoLM2024 MPAS embedded landdata has invalid PFT fractions on rank ', & + mpas_rank, ': local patch ', patch, ', eindex ', landpatch%eindex(patch) + RETURN + ENDIF + + ierr = 0 + END SUBROUTINE colm_mpas_validate_pft_fractions +#endif + + SUBROUTINE colm_mpas_ready(ready, patch_count) + logical, intent(out) :: ready + integer, intent(out), optional :: patch_count + + IF (numpatch == 0) THEN + ready = colm_mpas_initialized .and. allocated(elm_patch%substt) .and. & + allocated(elm_patch%subend) .and. allocated(elm_patch%subfrc) + ELSE + ready = colm_mpas_initialized .and. allocated(forc_t) .and. allocated(oroflag) .and. & + allocated(fsena) .and. allocated(t_grnd) .and. allocated(patchmask) & + .and. allocated(elm_patch%substt) .and. allocated(elm_patch%subend) .and. allocated(elm_patch%subfrc) + ENDIF + IF (present(patch_count)) THEN + IF (allocated(oroflag)) THEN + patch_count = size(oroflag) + ELSE + patch_count = 0 + ENDIF + ENDIF + END SUBROUTINE colm_mpas_ready + + SUBROUTINE colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, oro, ozone, ierr) + integer, intent(in) :: patch + real(r8), intent(in) :: pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine + real(r8), intent(in) :: psrf, pbot, sols, soll, solsd, solld, frl + real(r8), intent(in) :: hgt_u, hgt_t, hgt_q, rhoair, hpbl + real(r8), intent(in) :: aerdep(14) + real(r8), intent(in), optional :: oro + real(r8), intent(in), optional :: ozone + integer, intent(out) :: ierr + real(r8) :: patch_oro + + ierr = 1 + IF (.not. allocated(forc_t)) RETURN + IF (.not. allocated(coszen)) RETURN + IF (patch < 1 .or. patch > size(forc_t)) RETURN + IF (patch > size(coszen)) RETURN + IF (.not. ieee_is_finite(solar_cosine) .or. solar_cosine < -1._r8 .or. solar_cosine > 1._r8) RETURN + IF (present(oro)) THEN + IF (.not. allocated(oroflag) .or. .not. allocated(patchtype)) RETURN + IF (patch > size(oroflag) .or. patch > size(patchtype)) RETURN + ENDIF + + forc_pco2m(patch) = pco2m + forc_po2m (patch) = po2m + forc_us (patch) = us + forc_vs (patch) = vs + forc_t (patch) = tair + forc_q (patch) = qair + forc_prc (patch) = prc + forc_prl (patch) = prl + forc_rain (patch) = rain + forc_snow (patch) = snow + coszen (patch) = solar_cosine + forc_psrf (patch) = psrf + forc_pbot (patch) = pbot + forc_sols (patch) = sols + forc_soll (patch) = soll + forc_solsd(patch) = solsd + forc_solld(patch) = solld + forc_frl (patch) = frl + forc_swrad(patch) = sols + soll + solsd + solld +#ifdef HYPERSPECTRAL + forc_solarin(patch) = forc_swrad(patch) +#endif + forc_hgt_u(patch) = hgt_u + forc_hgt_t(patch) = hgt_t + forc_hgt_q(patch) = hgt_q + forc_rhoair(patch) = rhoair + forc_hpbl (patch) = hpbl + forc_aerdep(:,patch) = aerdep(:) + IF (present(oro)) THEN + patch_oro = 1._r8 + IF (patchtype(patch) >= 99) THEN + patch_oro = 0._r8 + IF (nint(oro) == 2) patch_oro = 2._r8 + ENDIF + oroflag(patch) = patch_oro + ENDIF + IF (present(ozone)) THEN + forc_ozone(patch) = ozone + ELSE + forc_ozone(patch) = 0._r8 + ENDIF + ierr = 0 + END SUBROUTINE colm_mpas_set_forcing + + SUBROUTINE colm_mpas_set_element_forcing(element, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, & + solar_cosine, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, oro, ozone, ierr) + integer, intent(in) :: element + real(r8), intent(in) :: pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine + real(r8), intent(in) :: psrf, pbot, sols, soll, solsd, solld, frl + real(r8), intent(in) :: hgt_u, hgt_t, hgt_q, rhoair, hpbl + real(r8), intent(in) :: aerdep(14) + real(r8), intent(in), optional :: oro + real(r8), intent(in), optional :: ozone + integer, intent(out) :: ierr + + integer :: patch + integer :: patch_ierr + integer :: istt + integer :: iend + logical :: did_set + + ierr = 1 + IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subend)) RETURN + IF (.not. allocated(elm_patch%subfrc)) RETURN + IF (numpatch < 1) RETURN + IF (size(elm_patch%subfrc) < numpatch) RETURN + IF (allocated(patchmask)) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + IF (element < 1 .or. element > size(elm_patch%substt) .or. & + element > size(elm_patch%subend)) RETURN + + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + IF (istt < 1 .or. iend < istt .or. iend > numpatch .or. & + iend > size(elm_patch%subfrc)) RETURN + + did_set = .false. + DO patch = istt, iend + IF (patch < 1 .or. patch > numpatch) RETURN + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF + IF (present(oro) .and. present(ozone)) THEN + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, oro=oro, ozone=ozone, ierr=patch_ierr) + ELSEIF (present(oro)) THEN + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, oro=oro, ierr=patch_ierr) + ELSEIF (present(ozone)) THEN + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, ozone=ozone, ierr=patch_ierr) + ELSE + CALL colm_mpas_set_forcing(patch, pco2m, po2m, us, vs, tair, qair, prc, prl, rain, snow, solar_cosine, & + psrf, pbot, sols, soll, solsd, solld, frl, hgt_u, hgt_t, hgt_q, & + rhoair, hpbl, aerdep, ierr=patch_ierr) + ENDIF + IF (patch_ierr /= 0) RETURN + did_set = .true. + ENDDO + + IF (did_set) ierr = 0 + END SUBROUTINE colm_mpas_set_element_forcing + + SUBROUTINE colm_mpas_step(idate, deltim, dolai, doalb, dosst, ierr) + USE MOD_LAIReadin, only: LAI_readin + USE MOD_Namelist, only: DEF_LAI_MONTHLY, DEF_LAI_CHANGE_YEARLY + USE MOD_TimeManager, only: julian2monthday +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeFlow, only: grid_riverlake_flow +#endif + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: dolai, doalb, dosst + integer, intent(out) :: ierr + + integer :: lai_month + integer :: lai_mday + integer :: lai_period + integer :: lai_time + integer :: lai_year + logical :: ready + + CALL colm_mpas_ready(ready) + ierr = 1 + IF (.not. ready) RETURN + + IF (DEF_LAI_MONTHLY) THEN + CALL julian2monthday(idate(1), idate(2), lai_month, lai_mday) + lai_period = lai_month + lai_time = lai_month + ELSE + lai_period = 1 + (idate(2) - 1) / 8 + lai_time = 1 + 8 * (lai_period - 1) + ENDIF + IF (DEF_LAI_CHANGE_YEARLY) THEN + lai_year = idate(1) + ELSE + lai_year = colm_mpas_lc_year + ENDIF + IF (numpatch > 0) CALL CoLMDRIVER(idate, deltim, dolai, doalb, dosst, oroflag) +#ifdef GridRiverLakeFlow + CALL grid_riverlake_flow(idate(1), deltim) +#endif + ! CoLM updates prescribed LAI/SAI after a period-boundary step so that + ! the new vegetation data are used by the following step. + IF (lai_year /= colm_mpas_last_lai_year .or. lai_period /= colm_mpas_last_lai_period) THEN + CALL LAI_readin(lai_year, lai_time, colm_mpas_dir_landdata) + colm_mpas_last_lai_year = lai_year + colm_mpas_last_lai_period = lai_period + ENDIF + colm_mpas_last_idate(:) = idate(:) + CALL colm_mpas_write_restart_if_due(idate, deltim, .false., ierr) + IF (ierr /= 0) RETURN + ierr = 0 + END SUBROUTINE colm_mpas_step + + SUBROUTINE colm_mpas_force_restart(ierr) + integer, intent(out) :: ierr + + ierr = 1 + IF (.not. colm_mpas_initialized) RETURN + IF (colm_mpas_last_idate(1) <= 0) RETURN + CALL colm_mpas_write_restart_if_due(colm_mpas_last_idate, 0._r8, .true., ierr) + END SUBROUTINE colm_mpas_force_restart + + SUBROUTINE colm_mpas_write_restart_if_due(idate, deltim, force, ierr) + USE MOD_Namelist, only: DEF_WRST_FREQ + USE MOD_TimeManager, only: adj2begin + USE MOD_Vars_TimeVariables, only: save_to_restart, WRITE_TimeVariables + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: force + integer, intent(out) :: ierr + + type(timestamp) :: itstamp + integer :: write_idate(3) + integer :: write_lc_year + logical :: should_write + character(len=256) :: wrst_freq + + ierr = 0 + IF (.not. colm_mpas_restart_ready) RETURN + + write_idate(:) = idate(:) + CALL adj2begin(write_idate) + + IF (all(write_idate == colm_mpas_last_restart_idate)) RETURN + + itstamp%year = idate(1) + itstamp%day = idate(2) + itstamp%sec = idate(3) + + wrst_freq = trim(adjustl(DEF_WRST_FREQ)) + IF (wrst_freq == '' .or. wrst_freq == 'none' .or. wrst_freq == 'NONE') THEN + should_write = force .or. colm_mpas_timestamp_reached(itstamp, colm_mpas_etstamp) + ELSEIF (force) THEN + should_write = .true. + ELSE + should_write = save_to_restart(idate, deltim, itstamp, colm_mpas_ptstamp, colm_mpas_etstamp) + ENDIF + IF (.not. should_write) RETURN + +#ifdef LULCC + IF (write_idate(1) >= 2000) THEN + write_lc_year = write_idate(1) + ELSE + write_lc_year = (write_idate(1) / 5) * 5 + ENDIF +#else + write_lc_year = colm_mpas_lc_year +#endif + + CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart) + colm_mpas_last_restart_idate(:) = write_idate(:) + END SUBROUTINE colm_mpas_write_restart_if_due + + LOGICAL FUNCTION colm_mpas_timestamp_reached(tstamp, target) + type(timestamp), intent(in) :: tstamp + type(timestamp), intent(in) :: target + + colm_mpas_timestamp_reached = .false. + IF (tstamp%year > target%year) THEN + colm_mpas_timestamp_reached = .true. + ELSEIF (tstamp%year == target%year .and. tstamp%day > target%day) THEN + colm_mpas_timestamp_reached = .true. + ELSEIF (tstamp%year == target%year .and. tstamp%day == target%day .and. tstamp%sec >= target%sec) THEN + colm_mpas_timestamp_reached = .true. + ENDIF + END FUNCTION colm_mpas_timestamp_reached + + SUBROUTINE colm_mpas_get_surface(patch, sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & + u10m, v10m, & + surface_humidity, emissivity, roughness, albedo, friction_velocity, & + stability_zeta, bulk_richardson, momentum_profile, heat_profile, & + moisture_profile, air_density, heat_exchange_velocity, & + moisture_exchange_velocity, momentum_coefficient, enthalpy_coefficient, & + inverse_monin_obukhov, ierr) + integer, intent(in) :: patch + real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff + real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m + real(r8), intent(out) :: u10m, v10m + real(r8), intent(out) :: surface_humidity + real(r8), intent(out) :: emissivity, roughness, albedo + real(r8), intent(out) :: friction_velocity, stability_zeta, bulk_richardson + real(r8), intent(out) :: momentum_profile, heat_profile + real(r8), intent(out) :: moisture_profile, air_density + real(r8), intent(out) :: heat_exchange_velocity, moisture_exchange_velocity + real(r8), intent(out) :: momentum_coefficient, enthalpy_coefficient, inverse_monin_obukhov + integer, intent(out) :: ierr + real(r8) :: incoming_shortwave + real(r8) :: bad_value + real(r8) :: reference_height_u + real(r8) :: reference_height_t + real(r8) :: reference_height_q + + ierr = 1 + sensible = spval + latent = spval + evaporation = spval + ground_heat = spval + runoff = spval + surface_runoff = spval + subsurface_runoff = spval + skin_temp = spval + t2m = spval + q2m = spval + u10m = spval + v10m = spval + surface_humidity = spval + emissivity = spval + roughness = spval + albedo = spval + friction_velocity = spval + stability_zeta = spval + bulk_richardson = spval + momentum_profile = spval + heat_profile = spval + moisture_profile = spval + air_density = spval + heat_exchange_velocity = spval + moisture_exchange_velocity = spval + momentum_coefficient = spval + enthalpy_coefficient = spval + inverse_monin_obukhov = spval + + IF (.not. allocated(fsena)) RETURN + IF (.not. allocated(lfevpa)) RETURN + IF (.not. allocated(fevpa)) RETURN + IF (.not. allocated(fgrnd)) RETURN + IF (.not. allocated(rnof)) RETURN + IF (.not. allocated(rsur)) RETURN + IF (.not. allocated(rsub)) RETURN + IF (.not. allocated(trad)) RETURN + IF (.not. allocated(tref)) RETURN + IF (.not. allocated(qref)) RETURN + IF (.not. allocated(emis)) RETURN + IF (.not. allocated(z0m)) RETURN + IF (patch < 1) RETURN + IF (patch > size(fsena)) RETURN + IF (patch > size(lfevpa)) RETURN + IF (patch > size(fevpa)) RETURN + IF (patch > size(fgrnd)) RETURN + IF (patch > size(rnof)) RETURN + IF (patch > size(rsur)) RETURN + IF (patch > size(rsub)) RETURN + IF (patch > size(trad)) RETURN + IF (patch > size(tref)) RETURN + IF (patch > size(qref)) RETURN + IF (patch > size(emis)) RETURN + IF (patch > size(z0m)) RETURN + + sensible = fsena(patch) + latent = lfevpa(patch) + evaporation = fevpa(patch) + ground_heat = fgrnd(patch) + runoff = rnof(patch) + surface_runoff = rsur(patch) + subsurface_runoff = rsub(patch) + skin_temp = trad(patch) + t2m = tref(patch) + q2m = qref(patch) + surface_humidity = qref(patch) + IF (allocated(qsfc)) THEN + IF (patch <= size(qsfc)) THEN + IF (qsfc(patch) >= 0._r8 .and. qsfc(patch) < 1._r8) surface_humidity = qsfc(patch) + ENDIF + ENDIF + emissivity = emis(patch) + roughness = z0m(patch) + bad_value = 0.5_r8 * abs(spval) + IF (allocated(alb)) THEN + IF (patch <= size(alb,3)) THEN + IF (all(abs(alb(:,:,patch)) < bad_value)) THEN + incoming_shortwave = forc_sols(patch) + forc_soll(patch) + forc_solsd(patch) + forc_solld(patch) + IF (incoming_shortwave > tiny(1._r8)) THEN + albedo = (alb(1,1,patch) * forc_sols(patch) + alb(2,1,patch) * forc_soll(patch) + & + alb(1,2,patch) * forc_solsd(patch) + alb(2,2,patch) * forc_solld(patch)) / & + incoming_shortwave + ELSE + albedo = sum(alb(:,:,patch)) / real(size(alb(:,:,patch)), r8) + ENDIF + ENDIF + ENDIF + ENDIF + IF (allocated(ustar)) THEN + IF (patch <= size(ustar)) friction_velocity = ustar(patch) + ENDIF + IF (allocated(zol)) THEN + IF (patch <= size(zol)) stability_zeta = zol(patch) + ENDIF + IF (allocated(rib)) THEN + IF (patch <= size(rib)) bulk_richardson = rib(patch) + ENDIF + IF (allocated(fm)) THEN + IF (patch <= size(fm)) momentum_profile = fm(patch) + ENDIF + IF (allocated(fh)) THEN + IF (patch <= size(fh)) heat_profile = fh(patch) + ENDIF + IF (allocated(fq)) THEN + IF (patch <= size(fq)) moisture_profile = fq(patch) + ENDIF + IF (allocated(forc_rhoair)) THEN + IF (patch <= size(forc_rhoair)) air_density = forc_rhoair(patch) + ENDIF + IF (abs(friction_velocity) < bad_value .and. friction_velocity >= 0._r8) THEN + IF (abs(heat_profile) < bad_value .and. heat_profile > tiny(1._r8)) & + heat_exchange_velocity = vonkar * friction_velocity / heat_profile + IF (abs(moisture_profile) < bad_value .and. moisture_profile > tiny(1._r8)) & + moisture_exchange_velocity = vonkar * friction_velocity / moisture_profile + ENDIF + IF (abs(air_density) < bad_value .and. air_density > 0._r8 .and. & + abs(moisture_exchange_velocity) < bad_value .and. & + moisture_exchange_velocity > tiny(1._r8)) THEN + IF (.not. allocated(forc_q)) RETURN + IF (patch > size(forc_q)) RETURN + IF (.not. ieee_is_finite(forc_q(patch)) .or. forc_q(patch) < 0._r8 .or. & + forc_q(patch) >= 1._r8) RETURN + ! The atmospheric boundary sees canopy-air humidity, not ground qg. + ! Reconstruct the effective bulk value from CoLM's total vapor flux. + surface_humidity = forc_q(patch) + evaporation / & + (air_density * moisture_exchange_velocity) + IF (.not. ieee_is_finite(surface_humidity) .or. surface_humidity < 0._r8 .or. & + surface_humidity >= 1._r8) RETURN + ENDIF + IF (abs(momentum_profile) < bad_value .and. momentum_profile > tiny(1._r8)) THEN + momentum_coefficient = (vonkar / momentum_profile)**2 + IF (abs(moisture_profile) < bad_value .and. moisture_profile > tiny(1._r8)) & + enthalpy_coefficient = vonkar**2 / (momentum_profile * moisture_profile) + ENDIF + CALL colm_mpas_get_patch_reference_heights(patch, reference_height_u, reference_height_t, & + reference_height_q, ierr) + IF (ierr /= 0) RETURN + IF (abs(stability_zeta) < bad_value .and. allocated(displa)) THEN + IF (patch <= size(forc_hgt_u) .and. patch <= size(displa)) THEN + IF (reference_height_u - displa(patch) > tiny(1._r8)) & + inverse_monin_obukhov = stability_zeta / (reference_height_u - displa(patch)) + ENDIF + ENDIF + CALL colm_mpas_get_patch_10m_wind(patch, u10m, v10m, ierr) + IF (ierr /= 0) RETURN + ierr = 0 + END SUBROUTINE colm_mpas_get_surface + + SUBROUTINE colm_mpas_get_patch_reference_heights(patch, height_u, height_t, height_q, ierr) + integer, intent(in) :: patch + real(r8), intent(out) :: height_u + real(r8), intent(out) :: height_t + real(r8), intent(out) :: height_q + integer, intent(out) :: ierr + + real(r8) :: canopy_top +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + integer :: pft_start + integer :: pft_end +#endif + + ierr = 1 + height_u = spval + height_t = spval + height_q = spval + IF (.not. allocated(forc_hgt_u) .or. .not. allocated(forc_hgt_t) .or. & + .not. allocated(forc_hgt_q) .or. .not. allocated(htop)) RETURN + IF (patch < 1 .or. patch > size(forc_hgt_u) .or. patch > size(forc_hgt_t) .or. & + patch > size(forc_hgt_q) .or. patch > size(htop)) RETURN + IF (.not. all(ieee_is_finite((/forc_hgt_u(patch), forc_hgt_t(patch), & + forc_hgt_q(patch), htop(patch)/)))) RETURN + IF (forc_hgt_u(patch) <= 0._r8 .or. forc_hgt_t(patch) <= 0._r8 .or. & + forc_hgt_q(patch) <= 0._r8 .or. htop(patch) < 0._r8) RETURN + + canopy_top = htop(patch) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (allocated(patch_pft_s) .and. allocated(patch_pft_e) .and. allocated(htop_p)) THEN + IF (patch <= size(patch_pft_s) .and. patch <= size(patch_pft_e)) THEN + pft_start = patch_pft_s(patch) + pft_end = patch_pft_e(patch) + IF (pft_start >= 1 .and. pft_end >= pft_start .and. pft_end <= size(htop_p)) THEN + IF (.not. all(ieee_is_finite(htop_p(pft_start:pft_end))) .or. & + any(htop_p(pft_start:pft_end) < 0._r8)) RETURN + canopy_top = max(canopy_top, maxval(htop_p(pft_start:pft_end))) + ENDIF + ENDIF + ENDIF +#endif + + height_u = max(forc_hgt_u(patch), canopy_top + 1._r8) + height_t = max(forc_hgt_t(patch), canopy_top + 1._r8) + height_q = max(forc_hgt_q(patch), canopy_top + 1._r8) + ierr = 0 + END SUBROUTINE colm_mpas_get_patch_reference_heights + + SUBROUTINE colm_mpas_get_patch_10m_wind(patch, u10m, v10m, ierr) + integer, intent(in) :: patch + real(r8), intent(out) :: u10m + real(r8), intent(out) :: v10m + integer, intent(out) :: ierr + + real(r8) :: zldis + real(r8) :: obu + real(r8) :: effective_wind + real(r8) :: calculated_ustar + real(r8) :: fh2m + real(r8) :: fq2m + real(r8) :: fm10m + real(r8) :: calculated_fm + real(r8) :: calculated_fh + real(r8) :: calculated_fq + real(r8) :: reference_height_u + real(r8) :: reference_height_t + real(r8) :: reference_height_q + + ierr = 1 + u10m = spval + v10m = spval + IF (.not. allocated(forc_us) .or. .not. allocated(forc_vs) .or. & + .not. allocated(forc_hgt_u) .or. .not. allocated(forc_hgt_t) .or. & + .not. allocated(forc_hgt_q) .or. .not. allocated(forc_hpbl) .or. & + .not. allocated(displa) .or. .not. allocated(z0m) .or. & + .not. allocated(zol) .or. .not. allocated(ustar) .or. .not. allocated(fm)) RETURN + IF (patch < 1 .or. patch > size(forc_us) .or. patch > size(forc_vs) .or. & + patch > size(forc_hgt_u) .or. patch > size(forc_hgt_t) .or. & + patch > size(forc_hgt_q) .or. patch > size(forc_hpbl) .or. & + patch > size(displa) .or. patch > size(z0m) .or. patch > size(zol) .or. & + patch > size(ustar) .or. patch > size(fm)) RETURN + IF (.not. all(ieee_is_finite((/forc_us(patch), forc_vs(patch), forc_hgt_u(patch), & + forc_hgt_t(patch), forc_hgt_q(patch), forc_hpbl(patch), & + displa(patch), z0m(patch), zol(patch), ustar(patch), fm(patch)/)))) RETURN + + CALL colm_mpas_get_patch_reference_heights(patch, reference_height_u, reference_height_t, & + reference_height_q, ierr) + IF (ierr /= 0) RETURN + zldis = reference_height_u - displa(patch) + IF (zldis <= 0._r8 .or. reference_height_t <= displa(patch) .or. & + reference_height_q <= displa(patch) .or. z0m(patch) <= 0._r8 .or. & + ustar(patch) < 0._r8 .or. fm(patch) <= 0._r8) RETURN + IF (DEF_USE_CBL_HEIGHT .and. forc_hpbl(patch) < 0._r8) RETURN + + IF (abs(zol(patch)) > tiny(1._r8)) THEN + obu = zldis / zol(patch) + ELSE + obu = huge(1._r8) + ENDIF + effective_wind = ustar(patch) * fm(patch) / vonkar + IF (.not. ieee_is_finite(obu) .or. .not. ieee_is_finite(effective_wind) .or. & + effective_wind < 0._r8) RETURN + + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(reference_height_u, reference_height_t, reference_height_q, & + displa(patch), z0m(patch), z0m(patch), z0m(patch), obu, & + effective_wind, forc_hpbl(patch), calculated_ustar, fh2m, fq2m, & + fm10m, calculated_fm, calculated_fh, calculated_fq) + ELSE + CALL moninobuk(reference_height_u, reference_height_t, reference_height_q, & + displa(patch), z0m(patch), z0m(patch), z0m(patch), obu, & + effective_wind, calculated_ustar, fh2m, fq2m, fm10m, & + calculated_fm, calculated_fh, calculated_fq) + ENDIF + IF (.not. ieee_is_finite(fm10m) .or. fm10m <= 0._r8) RETURN + + u10m = forc_us(patch) * fm10m / fm(patch) + v10m = forc_vs(patch) * fm10m / fm(patch) + IF (.not. ieee_is_finite(u10m) .or. .not. ieee_is_finite(v10m)) RETURN + ierr = 0 + END SUBROUTINE colm_mpas_get_patch_10m_wind + + SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, ground_heat, runoff, & + surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, & + u10m, v10m, & + surface_humidity, emissivity, roughness, albedo, friction_velocity, & + stability_zeta, bulk_richardson, momentum_profile, heat_profile, & + moisture_profile, air_density, heat_exchange_velocity, & + moisture_exchange_velocity, momentum_coefficient, enthalpy_coefficient, & + inverse_monin_obukhov, ierr) + integer, intent(in) :: element + real(r8), intent(out) :: sensible, latent, evaporation, ground_heat, runoff + real(r8), intent(out) :: surface_runoff, subsurface_runoff, skin_temp, t2m, q2m + real(r8), intent(out) :: u10m, v10m + real(r8), intent(out) :: surface_humidity + real(r8), intent(out) :: emissivity, roughness, albedo + real(r8), intent(out) :: friction_velocity, stability_zeta, bulk_richardson + real(r8), intent(out) :: momentum_profile, heat_profile + real(r8), intent(out) :: moisture_profile, air_density + real(r8), intent(out) :: heat_exchange_velocity, moisture_exchange_velocity + real(r8), intent(out) :: momentum_coefficient, enthalpy_coefficient, inverse_monin_obukhov + integer, intent(out) :: ierr + + integer :: patch + integer :: patch_ierr + integer :: istt + integer :: iend + real(r8) :: wt + real(r8) :: sumwt + real(r8) :: albedo_sum + real(r8) :: albedo_wt + real(r8) :: radiative_wt + real(r8) :: heat_conductance_sum + real(r8) :: moisture_conductance_sum + real(r8) :: humidity_conductance_sum + real(r8) :: exchange_wt(12) + real(r8) :: bad_value + real(r8) :: patch_sensible, patch_latent, patch_evaporation, patch_ground_heat + real(r8) :: patch_runoff, patch_surface_runoff, patch_subsurface_runoff + real(r8) :: patch_skin_temp, patch_t2m, patch_q2m, patch_u10m, patch_v10m, patch_surface_humidity + real(r8) :: patch_emissivity, patch_roughness, patch_albedo + real(r8) :: patch_friction_velocity, patch_stability_zeta, patch_bulk_richardson + real(r8) :: patch_momentum_profile, patch_heat_profile + real(r8) :: patch_moisture_profile, patch_air_density + real(r8) :: patch_heat_exchange_velocity, patch_moisture_exchange_velocity + real(r8) :: patch_momentum_coefficient, patch_enthalpy_coefficient, patch_inverse_monin_obukhov + + ierr = 1 + sensible = spval + latent = spval + evaporation = spval + ground_heat = spval + runoff = spval + surface_runoff = spval + subsurface_runoff = spval + skin_temp = spval + t2m = spval + q2m = spval + u10m = spval + v10m = spval + surface_humidity = spval + emissivity = spval + roughness = spval + albedo = spval + friction_velocity = spval + stability_zeta = spval + bulk_richardson = spval + momentum_profile = spval + heat_profile = spval + moisture_profile = spval + air_density = spval + heat_exchange_velocity = spval + moisture_exchange_velocity = spval + momentum_coefficient = spval + enthalpy_coefficient = spval + inverse_monin_obukhov = spval + + IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subend)) RETURN + IF (.not. allocated(elm_patch%subfrc)) RETURN + IF (numpatch < 1) RETURN + IF (size(elm_patch%subfrc) < numpatch) RETURN + IF (allocated(patchmask)) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + IF (element < 1 .or. element > size(elm_patch%substt) .or. & + element > size(elm_patch%subend)) RETURN + + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + IF (istt < 1 .or. iend < istt .or. iend > numpatch .or. & + iend > size(elm_patch%subfrc)) RETURN + + sensible = 0._r8 + latent = 0._r8 + evaporation = 0._r8 + ground_heat = 0._r8 + runoff = 0._r8 + surface_runoff = 0._r8 + subsurface_runoff = 0._r8 + skin_temp = 0._r8 + t2m = 0._r8 + q2m = 0._r8 + u10m = 0._r8 + v10m = 0._r8 + surface_humidity = 0._r8 + emissivity = 0._r8 + roughness = 0._r8 + friction_velocity = 0._r8 + stability_zeta = 0._r8 + bulk_richardson = 0._r8 + momentum_profile = 0._r8 + heat_profile = 0._r8 + moisture_profile = 0._r8 + air_density = 0._r8 + heat_exchange_velocity = 0._r8 + moisture_exchange_velocity = 0._r8 + momentum_coefficient = 0._r8 + enthalpy_coefficient = 0._r8 + inverse_monin_obukhov = 0._r8 + albedo_sum = 0._r8 + albedo_wt = 0._r8 + radiative_wt = 0._r8 + heat_conductance_sum = 0._r8 + moisture_conductance_sum = 0._r8 + humidity_conductance_sum = 0._r8 + exchange_wt(:) = 0._r8 + bad_value = 0.5_r8 * abs(spval) + sumwt = 0._r8 + + DO patch = istt, iend + IF (patch < 1 .or. patch > numpatch) THEN + WRITE(*,*) 'Error: CoLM2024 element surface references invalid patch:', element, patch, numpatch + RETURN + ENDIF + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF + wt = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(wt)) RETURN + IF (wt <= 0._r8) CYCLE + CALL colm_mpas_get_surface(patch, patch_sensible, patch_latent, patch_evaporation, patch_ground_heat, & + patch_runoff, patch_surface_runoff, patch_subsurface_runoff, & + patch_skin_temp, patch_t2m, patch_q2m, patch_u10m, patch_v10m, & + patch_surface_humidity, & + patch_emissivity, patch_roughness, patch_albedo, patch_friction_velocity, & + patch_stability_zeta, patch_bulk_richardson, patch_momentum_profile, & + patch_heat_profile, patch_moisture_profile, patch_air_density, & + patch_heat_exchange_velocity, patch_moisture_exchange_velocity, & + patch_momentum_coefficient, patch_enthalpy_coefficient, & + patch_inverse_monin_obukhov, patch_ierr) + IF (patch_ierr /= 0) THEN + WRITE(*,*) 'Error: failed to retrieve CoLM2024 patch surface:', element, patch, patch_ierr + RETURN + ENDIF + IF (.not. ieee_is_finite(patch_skin_temp) .or. patch_skin_temp <= 0._r8 .or. & + abs(patch_skin_temp) >= bad_value) RETURN + IF (.not. all(ieee_is_finite((/patch_sensible, patch_latent, patch_evaporation, patch_ground_heat, & + patch_runoff, patch_surface_runoff, patch_subsurface_runoff, patch_t2m, & + patch_q2m, patch_u10m, patch_v10m, patch_surface_humidity, & + patch_emissivity, patch_roughness/)))) RETURN + IF (any(abs((/patch_sensible, patch_latent, patch_evaporation, patch_ground_heat, patch_runoff, & + patch_surface_runoff, patch_subsurface_runoff, patch_t2m, patch_q2m, & + patch_u10m, patch_v10m, patch_surface_humidity, patch_emissivity, & + patch_roughness/)) >= bad_value)) RETURN + IF (patch_t2m <= 0._r8 .or. patch_q2m < 0._r8 .or. patch_q2m >= 1._r8 .or. & + patch_surface_humidity < 0._r8 .or. patch_surface_humidity >= 1._r8 .or. & + patch_emissivity < 0._r8 .or. patch_emissivity > 1._r8 .or. patch_roughness < 0._r8) RETURN + IF (.not. all(ieee_is_finite((/patch_air_density, patch_heat_exchange_velocity, & + patch_moisture_exchange_velocity/)))) RETURN + IF (any(abs((/patch_air_density, patch_heat_exchange_velocity, & + patch_moisture_exchange_velocity/)) >= bad_value)) RETURN + IF (patch_air_density <= 0._r8 .or. patch_heat_exchange_velocity < 0._r8 .or. & + patch_moisture_exchange_velocity < 0._r8) RETURN + + sumwt = sumwt + wt + sensible = sensible + wt * patch_sensible + latent = latent + wt * patch_latent + evaporation = evaporation + wt * patch_evaporation + ground_heat = ground_heat + wt * patch_ground_heat + runoff = runoff + wt * patch_runoff + surface_runoff = surface_runoff + wt * patch_surface_runoff + subsurface_runoff = subsurface_runoff + wt * patch_subsurface_runoff + ! CoLM defines trad from outgoing longwave radiation, so preserve the + ! area-weighted radiative flux when reducing patches to one MPAS cell. + skin_temp = skin_temp + wt * patch_emissivity * patch_skin_temp**4 + radiative_wt = radiative_wt + wt * patch_emissivity + t2m = t2m + wt * patch_t2m + q2m = q2m + wt * patch_q2m + u10m = u10m + wt * patch_u10m + v10m = v10m + wt * patch_v10m + surface_humidity = surface_humidity + wt * patch_surface_humidity + emissivity = emissivity + wt * patch_emissivity + roughness = roughness + wt * patch_roughness + IF (abs(patch_friction_velocity) < bad_value .and. patch_friction_velocity >= 0._r8) THEN + ! Momentum stress is proportional to ustar**2, so reduce stress + ! rather than linearly averaging patch friction velocities. + friction_velocity = friction_velocity + wt * patch_friction_velocity**2 + exchange_wt(1) = exchange_wt(1) + wt + ENDIF + IF (abs(patch_stability_zeta) < bad_value) THEN + stability_zeta = stability_zeta + wt * patch_stability_zeta + exchange_wt(2) = exchange_wt(2) + wt + ENDIF + IF (abs(patch_bulk_richardson) < bad_value) THEN + bulk_richardson = bulk_richardson + wt * patch_bulk_richardson + exchange_wt(3) = exchange_wt(3) + wt + ENDIF + IF (abs(patch_momentum_profile) < bad_value .and. patch_momentum_profile > tiny(1._r8)) THEN + momentum_profile = momentum_profile + wt * patch_momentum_profile + exchange_wt(4) = exchange_wt(4) + wt + ENDIF + IF (abs(patch_heat_profile) < bad_value .and. patch_heat_profile > tiny(1._r8)) THEN + heat_profile = heat_profile + wt * patch_heat_profile + exchange_wt(5) = exchange_wt(5) + wt + ENDIF + IF (abs(patch_moisture_profile) < bad_value .and. patch_moisture_profile > tiny(1._r8)) THEN + moisture_profile = moisture_profile + wt * patch_moisture_profile + exchange_wt(6) = exchange_wt(6) + wt + ENDIF + air_density = air_density + wt * patch_air_density + exchange_wt(7) = exchange_wt(7) + wt + ! Return one cell-scale exchange velocity whose product with the + ! cell air density exactly preserves the patch-mean conductance. + heat_conductance_sum = heat_conductance_sum + & + wt * patch_air_density * patch_heat_exchange_velocity + moisture_conductance_sum = moisture_conductance_sum + & + wt * patch_air_density * patch_moisture_exchange_velocity + humidity_conductance_sum = humidity_conductance_sum + & + wt * patch_air_density * patch_moisture_exchange_velocity * & + patch_surface_humidity + exchange_wt(8) = exchange_wt(8) + wt + exchange_wt(9) = exchange_wt(9) + wt + IF (abs(patch_momentum_coefficient) < bad_value .and. patch_momentum_coefficient >= 0._r8) THEN + momentum_coefficient = momentum_coefficient + wt * patch_momentum_coefficient + exchange_wt(10) = exchange_wt(10) + wt + ENDIF + IF (abs(patch_enthalpy_coefficient) < bad_value .and. patch_enthalpy_coefficient >= 0._r8) THEN + enthalpy_coefficient = enthalpy_coefficient + wt * patch_enthalpy_coefficient + exchange_wt(11) = exchange_wt(11) + wt + ENDIF + IF (abs(patch_inverse_monin_obukhov) < bad_value) THEN + inverse_monin_obukhov = inverse_monin_obukhov + wt * patch_inverse_monin_obukhov + exchange_wt(12) = exchange_wt(12) + wt + ENDIF + IF (patch_albedo >= 0._r8 .and. patch_albedo <= 1._r8) THEN + albedo_sum = albedo_sum + wt * patch_albedo + albedo_wt = albedo_wt + wt + ENDIF + ENDDO + + IF (sumwt <= 0._r8) THEN + sensible = spval + latent = spval + evaporation = spval + ground_heat = spval + runoff = spval + surface_runoff = spval + subsurface_runoff = spval + skin_temp = spval + t2m = spval + q2m = spval + u10m = spval + v10m = spval + surface_humidity = spval + emissivity = spval + roughness = spval + friction_velocity = spval + stability_zeta = spval + bulk_richardson = spval + momentum_profile = spval + heat_profile = spval + moisture_profile = spval + air_density = spval + heat_exchange_velocity = spval + moisture_exchange_velocity = spval + momentum_coefficient = spval + enthalpy_coefficient = spval + inverse_monin_obukhov = spval + RETURN + ENDIF + + sensible = sensible / sumwt + latent = latent / sumwt + evaporation = evaporation / sumwt + ground_heat = ground_heat / sumwt + runoff = runoff / sumwt + surface_runoff = surface_runoff / sumwt + subsurface_runoff = subsurface_runoff / sumwt + IF (radiative_wt <= 0._r8) RETURN + skin_temp = (skin_temp / radiative_wt)**0.25_r8 + t2m = t2m / sumwt + q2m = q2m / sumwt + u10m = u10m / sumwt + v10m = v10m / sumwt + emissivity = emissivity / sumwt + roughness = roughness / sumwt + IF (exchange_wt(1) > 0._r8) THEN + friction_velocity = sqrt(friction_velocity / exchange_wt(1)) + ELSE + friction_velocity = spval + ENDIF + IF (exchange_wt(2) > 0._r8) THEN + stability_zeta = stability_zeta / exchange_wt(2) + ELSE + stability_zeta = spval + ENDIF + IF (exchange_wt(3) > 0._r8) THEN + bulk_richardson = bulk_richardson / exchange_wt(3) + ELSE + bulk_richardson = spval + ENDIF + IF (exchange_wt(4) > 0._r8) THEN + momentum_profile = momentum_profile / exchange_wt(4) + ELSE + momentum_profile = spval + ENDIF + IF (exchange_wt(5) > 0._r8) THEN + heat_profile = heat_profile / exchange_wt(5) + ELSE + heat_profile = spval + ENDIF + IF (exchange_wt(6) > 0._r8) THEN + moisture_profile = moisture_profile / exchange_wt(6) + ELSE + moisture_profile = spval + ENDIF + IF (exchange_wt(7) > 0._r8) THEN + air_density = air_density / exchange_wt(7) + ELSE + air_density = spval + ENDIF + IF (exchange_wt(8) > 0._r8 .and. air_density > 0._r8) THEN + heat_exchange_velocity = heat_conductance_sum / (sumwt * air_density) + ELSE + heat_exchange_velocity = spval + ENDIF + IF (exchange_wt(9) > 0._r8 .and. air_density > 0._r8) THEN + moisture_exchange_velocity = moisture_conductance_sum / (sumwt * air_density) + ELSE + moisture_exchange_velocity = spval + ENDIF + IF (moisture_conductance_sum > tiny(1._r8)) THEN + surface_humidity = humidity_conductance_sum / moisture_conductance_sum + ELSE + surface_humidity = surface_humidity / sumwt + ENDIF + IF (.not. ieee_is_finite(surface_humidity) .or. surface_humidity < 0._r8 .or. & + surface_humidity >= 1._r8) RETURN + IF (exchange_wt(10) > 0._r8) THEN + momentum_coefficient = momentum_coefficient / exchange_wt(10) + ELSE + momentum_coefficient = spval + ENDIF + IF (exchange_wt(11) > 0._r8) THEN + enthalpy_coefficient = enthalpy_coefficient / exchange_wt(11) + ELSE + enthalpy_coefficient = spval + ENDIF + IF (exchange_wt(12) > 0._r8) THEN + inverse_monin_obukhov = inverse_monin_obukhov / exchange_wt(12) + ELSE + inverse_monin_obukhov = spval + ENDIF + IF (albedo_wt > 0._r8) albedo = albedo_sum / albedo_wt + ierr = 0 + END SUBROUTINE colm_mpas_get_element_surface + + SUBROUTINE colm_mpas_get_element_boundary_state(element, skin_temp, surface_humidity, & + emissivity, roughness, albedo, ierr) + integer, intent(in) :: element + real(r8), intent(out) :: skin_temp, surface_humidity, emissivity, roughness, albedo + integer, intent(out) :: ierr + + integer :: patch + integer :: istt + integer :: iend + real(r8) :: wt + real(r8) :: sumwt + real(r8) :: radiative_wt + real(r8) :: patch_humidity + real(r8) :: patch_albedo + real(r8) :: bad_value + + ierr = 1 + skin_temp = spval + surface_humidity = spval + emissivity = spval + roughness = spval + albedo = spval + + IF (.not. allocated(elm_patch%substt) .or. .not. allocated(elm_patch%subend) .or. & + .not. allocated(elm_patch%subfrc)) RETURN + IF (.not. allocated(trad) .or. .not. allocated(qref) .or. .not. allocated(emis) .or. & + .not. allocated(z0m) .or. .not. allocated(alb)) RETURN + IF (numpatch < 1 .or. size(elm_patch%subfrc) < numpatch) RETURN + IF (allocated(patchmask)) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + IF (element < 1 .or. element > size(elm_patch%substt) .or. & + element > size(elm_patch%subend)) RETURN + + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + IF (istt < 1 .or. iend < istt .or. iend > numpatch) RETURN + + skin_temp = 0._r8 + surface_humidity = 0._r8 + emissivity = 0._r8 + roughness = 0._r8 + albedo = 0._r8 + sumwt = 0._r8 + radiative_wt = 0._r8 + bad_value = 0.5_r8 * abs(spval) + + DO patch = istt, iend + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF + wt = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(wt) .or. wt < 0._r8) RETURN + IF (wt <= 0._r8) CYCLE + + patch_humidity = qref(patch) + IF (allocated(qsfc)) THEN + IF (patch <= size(qsfc)) THEN + IF (ieee_is_finite(qsfc(patch)) .and. abs(qsfc(patch)) < bad_value .and. & + qsfc(patch) >= 0._r8 .and. qsfc(patch) < 1._r8) patch_humidity = qsfc(patch) + ENDIF + ENDIF + patch_albedo = sum(alb(:,:,patch)) / real(size(alb(:,:,patch)), r8) + + IF (.not. all(ieee_is_finite((/trad(patch), patch_humidity, emis(patch), z0m(patch), & + patch_albedo/)))) RETURN + IF (any(abs((/trad(patch), patch_humidity, emis(patch), z0m(patch), patch_albedo/)) >= & + bad_value)) RETURN + IF (trad(patch) <= 0._r8 .or. patch_humidity < 0._r8 .or. patch_humidity >= 1._r8 .or. & + emis(patch) <= 0._r8 .or. emis(patch) > 1._r8 .or. z0m(patch) < 0._r8 .or. & + patch_albedo < 0._r8 .or. patch_albedo > 1._r8) RETURN + + skin_temp = skin_temp + wt * emis(patch) * trad(patch)**4 + radiative_wt = radiative_wt + wt * emis(patch) + surface_humidity = surface_humidity + wt * patch_humidity + emissivity = emissivity + wt * emis(patch) + roughness = roughness + wt * z0m(patch) + albedo = albedo + wt * patch_albedo + sumwt = sumwt + wt + ENDDO + + IF (sumwt <= 0._r8 .or. radiative_wt <= 0._r8) RETURN + skin_temp = (skin_temp / radiative_wt)**0.25_r8 + surface_humidity = surface_humidity / sumwt + emissivity = emissivity / sumwt + roughness = roughness / sumwt + albedo = albedo / sumwt + ierr = 0 + END SUBROUTINE colm_mpas_get_element_boundary_state + + SUBROUTINE colm_mpas_get_element_river_state(element, water_depth, velocity, discharge, ierr) +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeTimeVars, only: river_water_depth_elm, river_velocity_elm, river_discharge_elm +#endif + integer, intent(in) :: element + real(r8), intent(out) :: water_depth + real(r8), intent(out) :: velocity + real(r8), intent(out) :: discharge + integer, intent(out) :: ierr + + real(r8) :: bad_value + + water_depth = spval + velocity = spval + discharge = spval + ierr = 1 + IF (.not. colm_mpas_initialized) RETURN + +#ifdef GridRiverLakeFlow + IF (.not. allocated(river_water_depth_elm) .or. .not. allocated(river_velocity_elm) .or. & + .not. allocated(river_discharge_elm)) RETURN + IF (element < 1 .or. element > size(river_water_depth_elm) .or. & + element > size(river_velocity_elm) .or. element > size(river_discharge_elm)) RETURN + + water_depth = river_water_depth_elm(element) + velocity = river_velocity_elm(element) + discharge = river_discharge_elm(element) + bad_value = 0.5_r8 * abs(spval) + IF (.not. all(ieee_is_finite((/water_depth, velocity, discharge/)))) RETURN + IF (abs(water_depth) < bad_value .and. water_depth < 0._r8) RETURN +#endif + + ierr = 0 + END SUBROUTINE colm_mpas_get_element_river_state + + SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_depth, snow_cover, & + leaf_area_index, vegetation_fraction, soil_availability, ground_temperature, & + soil_liquid, soil_ice, soil_moisture, soil_temperature, ierr) + integer, intent(in) :: element + real(r8), intent(out) :: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index + real(r8), intent(out) :: vegetation_fraction, soil_availability, ground_temperature + real(r8), intent(out) :: soil_liquid(:), soil_ice(:), soil_moisture(:), soil_temperature(:) + integer, intent(out) :: ierr + + integer :: patch + integer :: istt + integer :: iend + integer :: n + integer :: nlev + real(r8) :: wt + real(r8) :: sumwt + real(r8) :: vegetation_wt + real(r8) :: availability_wt + real(r8) :: bad_value + real(r8), parameter :: negative_tolerance = 1.e-10_r8 + real(r8) :: patch_canopy_water + real(r8) :: patch_snow_water + real(r8) :: patch_snow_depth + real(r8) :: patch_snow_cover + real(r8) :: patch_lai + real(r8) :: patch_ground_temperature + real(r8) :: patch_fveg + real(r8) :: patch_availability + real(r8) :: patch_liquid + real(r8) :: patch_ice + real(r8) :: patch_moisture + real(r8) :: soil_wt(nl_soil) + integer :: navailability + + ierr = 1 + canopy_water = spval + snow_water = spval + snow_depth = spval + snow_cover = spval + leaf_area_index = spval + vegetation_fraction = spval + soil_availability = spval + ground_temperature = spval + soil_liquid(:) = spval + soil_ice(:) = spval + soil_moisture(:) = spval + soil_temperature(:) = spval + + IF (size(soil_liquid) < nl_soil) RETURN + IF (size(soil_ice) < nl_soil) RETURN + IF (size(soil_moisture) < nl_soil) RETURN + IF (size(soil_temperature) < nl_soil) RETURN + nlev = nl_soil + IF (.not. allocated(elm_patch%substt)) RETURN + IF (.not. allocated(elm_patch%subend)) RETURN + IF (.not. allocated(elm_patch%subfrc)) RETURN + IF (.not. allocated(ldew)) RETURN + IF (.not. allocated(scv)) RETURN + IF (.not. allocated(snowdp)) RETURN + IF (.not. allocated(fsno)) RETURN + IF (.not. allocated(lai)) RETURN + IF (.not. allocated(t_grnd)) RETURN + IF (.not. allocated(t_soisno)) RETURN + IF (.not. allocated(wliq_soisno)) RETURN + IF (.not. allocated(wice_soisno)) RETURN + IF (numpatch < 1) RETURN + IF (size(elm_patch%subfrc) < numpatch) RETURN + IF (size(ldew) < numpatch .or. size(scv) < numpatch .or. size(snowdp) < numpatch .or. & + size(fsno) < numpatch .or. size(lai) < numpatch .or. size(t_grnd) < numpatch) RETURN + IF (allocated(patchmask)) THEN + IF (size(patchmask) < numpatch) RETURN + ENDIF + IF (lbound(t_soisno, 1) > 1 .or. ubound(t_soisno, 1) < nl_soil) RETURN + IF (lbound(wliq_soisno, 1) > 1 .or. ubound(wliq_soisno, 1) < nl_soil) RETURN + IF (lbound(wice_soisno, 1) > 1 .or. ubound(wice_soisno, 1) < nl_soil) RETURN + IF (lbound(t_soisno, 2) > 1 .or. ubound(t_soisno, 2) < numpatch) RETURN + IF (lbound(wliq_soisno, 2) > 1 .or. ubound(wliq_soisno, 2) < numpatch) RETURN + IF (lbound(wice_soisno, 2) > 1 .or. ubound(wice_soisno, 2) < numpatch) RETURN + IF (element < 1 .or. element > size(elm_patch%substt) .or. & + element > size(elm_patch%subend)) RETURN + + istt = elm_patch%substt(element) + iend = elm_patch%subend(element) + IF (istt < 1 .or. iend < istt .or. iend > numpatch .or. iend > size(elm_patch%subfrc)) RETURN + + bad_value = 0.5_r8 * abs(spval) + canopy_water = 0._r8 + snow_water = 0._r8 + snow_depth = 0._r8 + snow_cover = 0._r8 + leaf_area_index = 0._r8 + vegetation_fraction = 0._r8 + soil_availability = 0._r8 + ground_temperature = 0._r8 + soil_liquid(:) = 0._r8 + soil_ice(:) = 0._r8 + soil_moisture(:) = 0._r8 + soil_temperature(:) = 0._r8 + soil_wt(:) = 0._r8 + sumwt = 0._r8 + vegetation_wt = 0._r8 + availability_wt = 0._r8 + + DO patch = istt, iend + IF (patch < 1 .or. patch > numpatch) THEN + WRITE(*,*) 'Error: CoLM2024 element state references invalid patch:', element, patch, numpatch + RETURN + ENDIF + IF (allocated(patchmask)) THEN + IF (.not. patchmask(patch)) CYCLE + ENDIF + wt = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(wt)) RETURN + IF (wt <= 0._r8) CYCLE + + patch_canopy_water = ldew(patch) + patch_snow_water = scv(patch) + patch_snow_depth = snowdp(patch) + patch_snow_cover = fsno(patch) + patch_lai = lai(patch) + patch_ground_temperature = t_grnd(patch) + IF (.not. all(ieee_is_finite((/patch_canopy_water, patch_snow_water, patch_snow_depth, & + patch_snow_cover, patch_lai, patch_ground_temperature/)))) RETURN + IF (any(abs((/patch_canopy_water, patch_snow_water, patch_snow_depth, patch_snow_cover, & + patch_lai, patch_ground_temperature/)) >= bad_value)) RETURN + IF (patch_canopy_water < -negative_tolerance .or. patch_snow_water < -negative_tolerance .or. & + patch_snow_depth < -negative_tolerance .or. patch_snow_cover < -negative_tolerance .or. & + patch_snow_cover > 1._r8 + negative_tolerance .or. patch_lai < -negative_tolerance) RETURN + + sumwt = sumwt + wt + canopy_water = canopy_water + wt * max(0._r8, patch_canopy_water) + snow_water = snow_water + wt * max(0._r8, patch_snow_water) + snow_depth = snow_depth + wt * max(0._r8, patch_snow_depth) + snow_cover = snow_cover + wt * max(0._r8, min(1._r8, patch_snow_cover)) + leaf_area_index = leaf_area_index + wt * max(0._r8, patch_lai) + ground_temperature = ground_temperature + wt * patch_ground_temperature + + IF (allocated(fveg)) THEN + IF (patch <= size(fveg)) THEN + patch_fveg = fveg(patch) + IF (abs(patch_fveg) < bad_value) THEN + vegetation_fraction = vegetation_fraction + wt * max(0._r8, min(1._r8, patch_fveg)) + vegetation_wt = vegetation_wt + wt + ENDIF + ENDIF + ENDIF + + patch_availability = 0._r8 + navailability = 0 + IF (allocated(rstfacsun_out)) THEN + IF (patch <= size(rstfacsun_out)) THEN + IF (abs(rstfacsun_out(patch)) < bad_value) THEN + patch_availability = patch_availability + max(0._r8, min(1._r8, rstfacsun_out(patch))) + navailability = navailability + 1 + ENDIF + ENDIF + ENDIF + IF (allocated(rstfacsha_out)) THEN + IF (patch <= size(rstfacsha_out)) THEN + IF (abs(rstfacsha_out(patch)) < bad_value) THEN + patch_availability = patch_availability + max(0._r8, min(1._r8, rstfacsha_out(patch))) + navailability = navailability + 1 + ENDIF + ENDIF + ENDIF + IF (navailability > 0) THEN + soil_availability = soil_availability + wt * patch_availability / real(navailability, r8) + availability_wt = availability_wt + wt + ENDIF + + DO n = 1, nlev + IF (.not. ieee_is_finite(dz_soi(n)) .or. dz_soi(n) <= 0._r8) RETURN + IF (.not. all(ieee_is_finite((/t_soisno(n, patch), wliq_soisno(n, patch), & + wice_soisno(n, patch)/)))) RETURN + IF (any(abs((/t_soisno(n, patch), wliq_soisno(n, patch), & + wice_soisno(n, patch)/)) >= bad_value)) RETURN + IF (wliq_soisno(n, patch) < -negative_tolerance .or. & + wice_soisno(n, patch) < -negative_tolerance) RETURN + + patch_liquid = max(0._r8, wliq_soisno(n, patch) / (denh2o * dz_soi(n))) + patch_ice = max(0._r8, wice_soisno(n, patch) / (denice * dz_soi(n))) + patch_moisture = patch_liquid + patch_ice + soil_liquid(n) = soil_liquid(n) + wt * patch_liquid + soil_ice(n) = soil_ice(n) + wt * patch_ice + soil_moisture(n) = soil_moisture(n) + wt * patch_moisture + soil_temperature(n) = soil_temperature(n) + wt * t_soisno(n, patch) + soil_wt(n) = soil_wt(n) + wt + ENDDO + ENDDO + + IF (sumwt <= 0._r8) THEN + canopy_water = spval + snow_water = spval + snow_depth = spval + snow_cover = spval + leaf_area_index = spval + vegetation_fraction = spval + soil_availability = spval + ground_temperature = spval + soil_liquid(:) = spval + soil_ice(:) = spval + soil_moisture(:) = spval + soil_temperature(:) = spval + RETURN + ENDIF + + canopy_water = canopy_water / sumwt + snow_water = snow_water / sumwt + snow_depth = snow_depth / sumwt + snow_cover = snow_cover / sumwt + leaf_area_index = leaf_area_index / sumwt + ground_temperature = ground_temperature / sumwt + IF (vegetation_wt > 0._r8) THEN + vegetation_fraction = vegetation_fraction / vegetation_wt + ELSE + vegetation_fraction = spval + ENDIF + IF (availability_wt > 0._r8) THEN + soil_availability = soil_availability / availability_wt + ELSE + soil_availability = spval + ENDIF + + IF (any(soil_wt(1:nlev) <= 0._r8)) RETURN + DO n = 1, nlev + soil_liquid(n) = soil_liquid(n) / soil_wt(n) + soil_ice(n) = soil_ice(n) / soil_wt(n) + soil_moisture(n) = soil_moisture(n) / soil_wt(n) + soil_temperature(n) = soil_temperature(n) / soil_wt(n) + ENDDO + + ierr = 0 + END SUBROUTINE colm_mpas_get_element_state + + END MODULE MOD_CoLM_MPAS_Interface diff --git a/src/core_atmosphere/physics/physics_colm2024/include/define.h b/src/core_atmosphere/physics/physics_colm2024/include/define.h new file mode 100644 index 0000000000..52c941b636 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/include/define.h @@ -0,0 +1,98 @@ +! 1. Spatial structure: +! Select one of the following options. +#undef GRIDBASED +#undef CATCHMENT +#define UNSTRUCTURED +#undef SinglePoint + +! 2. Land subgrid type classification: +! Select one of the following options. +#undef LULC_USGS +#undef LULC_IGBP +#undef LULC_IGBP_PFT +#define LULC_IGBP_PC + +! 2.1 3D Urban model (put it temporarily here): +#undef URBAN_MODEL +! Dependence: only LULC_IGBP subgrid type for +! single point URBAN_MODEL right now. +#if (defined URBAN_MODEL && defined SinglePoint) +#define LULC_IGBP +#undef LULC_USGS +#undef LULC_IGBP_PFT +#undef LULC_IGBP_PC +#endif + +! 3. Embedded diagnostics are written through MPAS streams. +#undef CoLMDEBUG +! If defined, surface data in vector is mapped to gridded data for checking. +#undef SrfdataDiag + +! 4. CoLM uses MPI exclusively through the MPAS-owned communicator. +#define MPAS_MPI + +! 5. Hydrological process options. +! 5.1 Two soil hydraulic models can be used. +#undef Campbell_SOIL_MODEL +#define vanGenuchten_Mualem_SOIL_MODEL +! 5.2 If defined, lateral flow is modeled. +#define CatchLateralFlow +! Conflicts : +#ifndef CATCHMENT +#undef CatchLateralFlow +#endif + +! 6. Embedded grid river-lake routing. +#define GridRiverLakeFlow +! Conflicts : +#if (defined CATCHMENT || defined SinglePoint) +#undef GridRiverLakeFlow +#endif + +#undef GridRiverLakeSediment +#if (!defined GridRiverLakeFlow) +#undef GridRiverLakeSediment +#endif + +! 7. If defined, BGC model is used. +#undef BGC + +! Conflicts : only used when LULC_IGBP_PFT is defined. +#ifndef LULC_IGBP_PFT +#ifndef LULC_IGBP_PC +#undef BGC +#endif +#endif +! 7.1 If defined, CROP model is used +#undef CROP +! Conflicts : only used when BGC is defined +#ifndef BGC +#undef CROP +#endif + +! 8. If defined, open Land use and land cover change mode. +#undef LULCC + +! 9. If defined, data assimilation is used. +#undef DataAssimilation +#if (defined DataAssimilation) +#define LULC_IGBP +#undef LULC_USGS +#undef LULC_IGBP_PFT +#undef LULC_IGBP_PC +#endif + +! 10. Interface to AI model. +#undef USESplitAI + +! 11. External lake models. +#undef EXTERNAL_LAKE + +! 12. Hyperspectral scheme. +#define HYPERSPECTRAL + +! MPAS embeds CoLM as a land-surface physics package on every MPAS rank. +! CoLM keeps patch/PFT state below MPAS-owned cells and communicates through the +! MPAS communicator. MPAS supplies CoLM VIS/NIR direct/diffuse forcing. +#define MPAS_EMBEDDED_COLM +#undef HYPERSPECTRAL diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNAnnualUpdate.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNAnnualUpdate.F90 new file mode 100644 index 0000000000..8eff998fda --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNAnnualUpdate.F90 @@ -0,0 +1,81 @@ +#include + +#ifdef BGC +MODULE MOD_BGC_CNAnnualUpdate + +!------------------------------------------------------------------------------------------------------ +! !DESCRIPTION: +! On the radiation time step, update annual summation variables mostly for phenology modules: +! annsum_potential_gpp : annual sum of potential gpp of last year is used to calculate the available +! retranslocation N +! annmax_retransn : maximum of retranslocation N pool size of last year in a whole year, used to +! calculate the available rentranslocation N +! annavg_tref : annual 2m air temperature of last year is used to calculate onset phenology +! annsum_npp : annual NPP of last year is used to calculate the allocation partition. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! !REFERENCES: +! Lawrence, D.M., Fisher, R.A., Koven, C.D., Oleson, K.W., Swenson, S.C., Bonan, G., Collier, N., +! Ghimire, B., van Kampenhout, L., Kennedy, D. and Kluzek, E., 2019. +! The Community Land Model version 5: Description of new features, benchmarking, +! and impact of forcing uncertainty. Journal of Advances in Modeling Earth Systems, 11(12), 4245-4287. + +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + + USE MOD_Vars_PFTimeVariables, only: & + tempsum_potential_gpp_p, tempmax_retransn_p, tempavg_tref_p, tempsum_npp_p, & + annsum_potential_gpp_p , annmax_retransn_p , annavg_tref_p , annsum_npp_p + + USE MOD_TimeManager, only: isendofyear + USE MOD_Precision + + IMPLICIT NONE + + PUBLIC CNAnnualUpdate + +CONTAINS + + SUBROUTINE CNAnnualUpdate(i,ps,pe,deltim,idate) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: idate(3) ! date (year, days of year, seconds of the day) + + !!LOCAL VARIABLES: + integer m + + + IF (isendofyear(idate,deltim)) THEN + + DO m = ps, pe + ! update annual plant ndemand accumulator + annsum_potential_gpp_p(m) = tempsum_potential_gpp_p(m) + tempsum_potential_gpp_p(m) = 0._r8 + + ! update annual total N retranslocation accumulator + annmax_retransn_p(m) = tempmax_retransn_p(m) + tempmax_retransn_p(m) = 0._r8 + + ! update annual average 2m air temperature accumulator + annavg_tref_p(m) = tempavg_tref_p(m) + tempavg_tref_p(m) = 0._r8 + + ! update annual NPP accumulator, convert to annual total + annsum_npp_p(m) = tempsum_npp_p(m) * deltim + tempsum_npp_p(m) = 0._r8 + + ENDDO + + ENDIF + + END SUBROUTINE CNAnnualUpdate + +END MODULE MOD_BGC_CNAnnualUpdate + +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 new file mode 100644 index 0000000000..217d078ae9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90 @@ -0,0 +1,265 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNBalanceCheck + +!-------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! C and N balance check module. +! run sequential: BeginCNBalance(i) -> all CN cycle processes ->CBalanceCheck & NBalanceCheck +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF + USE MOD_BGC_Vars_TimeVariables, only: & + sminn, col_endcb, col_begcb, totcolc, col_endnb, col_begnb, totcoln, & + col_vegbegcb, totvegc, ctrunc_veg, col_vegbegnb, totvegn, ntrunc_veg, & + col_soilbegcb, totsomc, totlitc, totcwdc, ctrunc_soil, & + col_soilbegnb, totsomn, totlitn, totcwdn, ntrunc_soil, col_sminnbegnb, & + col_vegendcb, col_vegendnb, col_soilendcb, col_soilendnb, col_sminnendnb + USE MOD_BGC_Vars_1DFluxes, only: & + gpp, er, ar, decomp_hr, fire_closs, hrv_xsmrpool_to_atm, wood_harvestc, grainc_to_cropprodc, & + som_c_leached, ndep_to_sminn, nfix_to_sminn, supplement_to_sminn, ffix_to_sminn, & + fert_to_sminn, soyfixn_to_sminn, denit, fire_nloss, wood_harvestn, grainn_to_cropprodn, & + sminn_leached, f_n2o_nit, smin_no3_leached, smin_no3_runoff, som_n_leached, sminn_to_plant + USE MOD_BGC_Vars_PFTimeVariables, only: & + leafc_p, frootc_p, livestemc_p, deadstemc_p, livecrootc_p, deadcrootc_p, & + leafc_storage_p, frootc_storage_p, livestemc_storage_p, & + deadstemc_storage_p, livecrootc_storage_p, deadcrootc_storage_p, gresp_storage_p, & + leafc_xfer_p, frootc_xfer_p, livestemc_xfer_p, & + deadstemc_xfer_p, livecrootc_xfer_p, deadcrootc_xfer_p, gresp_xfer_p, xsmrpool_p, & + grainc_p, grainc_storage_p, grainc_xfer_p, ctrunc_p, totvegc_p, cropseedc_deficit_p + USE MOD_BGC_Vars_1DPFTFluxes, only: & + grainc_to_food_p, & + leafc_to_litter_p , frootc_to_litter_p , livestemc_to_litter_p, & + m_leafc_to_litter_p , m_leafc_storage_to_litter_p , m_leafc_xfer_to_litter_p , & + m_frootc_to_litter_p , m_frootc_storage_to_litter_p , m_frootc_xfer_to_litter_p , & + m_livestemc_to_litter_p , m_livestemc_storage_to_litter_p , m_livestemc_xfer_to_litter_p , & + m_deadstemc_to_litter_p , m_deadstemc_storage_to_litter_p , m_deadstemc_xfer_to_litter_p , & + m_livecrootc_to_litter_p , m_livecrootc_storage_to_litter_p, m_livecrootc_xfer_to_litter_p, & + m_deadcrootc_to_litter_p , m_deadcrootc_storage_to_litter_p, m_deadcrootc_xfer_to_litter_p, & + m_gresp_storage_to_litter_p, m_gresp_xfer_to_litter_p + USE MOD_MPAS_MPI + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + + USE MOD_BGC_Vars_1DFluxes, only: & + gap_mortality_to_met_c, gap_mortality_to_cel_c, gap_mortality_to_lig_c, gap_mortality_to_cwdc , & + phenology_to_met_c, phenology_to_cel_c, phenology_to_lig_c + + IMPLICIT NONE + + PUBLIC BeginCNBalance + PUBLIC CBalanceCheck + PUBLIC NBalanceCheck + +CONTAINS + + SUBROUTINE BeginCNBalance(i) + + ! !DESCRIPTION: + ! BeginCNBalance SUBROUTINE stores initial C and N pool size at begining of each time step, which is + ! further used in CN balance check. + ! + ! !ORIGINAL: + ! The Community Land Model version 5.0 (CLM5.0) + ! + ! !REVISION: + ! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + + col_begcb(i) = totcolc(i) + col_begnb(i) = totcoln(i) + + col_vegbegcb(i) = totvegc(i) + ctrunc_veg(i) + col_vegbegnb(i) = totvegn(i) + ntrunc_veg(i) + + col_soilbegcb(i) = totsomc(i) + totlitc(i) + totcwdc(i) + ctrunc_soil(i) + col_soilbegnb(i) = totsomn(i) + totlitn(i) + totcwdn(i) + ntrunc_soil(i) + + col_sminnbegnb(i) = sminn(i) + + END SUBROUTINE BeginCNBalance + + SUBROUTINE CBalanceCheck(i,ps,pe,nl_soil,dz_soi,deltim,dlat,dlon) + + ! !DESCRIPTION: + ! CBalanceCheck tests the carbon balance of each time step, which meet C balance equation: + ! col_endcb - col_begcb = (col_cinputs - col_coutputs)*deltim + ! + ! !ORIGINAL: + ! The Community Land Model version 5.0 (CLM5.0) + ! + ! !REVISION: + ! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! end pft index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dlat ! latitude (degree) + real(r8),intent(in) :: dlon ! longitude (degree) + integer, intent(in) :: nl_soil + real(r8),intent(in) :: dz_soi(nl_soil) + +!Local variables + real(r8),parameter :: cerror = 1.e-7_r8 + real(r8) :: col_cinputs, col_coutputs, col_errcb + real(r8) :: veg_to_litter, phen_to_litter, gap_leaf_to_litter, gap_froot_to_litter, & + gap_livestem_to_litter, gap_deadstem_to_litter, gap_livecroot_to_litter, & + gap_deadcroot_to_litter, gap_gresp_to_litter, gap_veg_to_litter, phen_veg_to_litter + integer m + + col_endcb(i) = totcolc(i) + col_vegendcb(i) = totvegc(i) + ctrunc_veg(i) + col_soilendcb(i) = totsomc(i) + totlitc(i) + totcwdc(i) + ctrunc_soil(i) + + col_cinputs = gpp(i) + + col_coutputs = er(i) + fire_closs(i) + hrv_xsmrpool_to_atm(i) & + + wood_harvestc(i) + grainc_to_cropprodc(i) - som_c_leached(i) + + col_errcb = (col_cinputs - col_coutputs)*deltim - & + (col_endcb(i) - col_begcb(i)) + + phen_to_litter = sum(pftfrac(ps:pe)*(leafc_to_litter_p (ps:pe) + frootc_to_litter_p(ps:pe) & + + livestemc_to_litter_p(ps:pe))) + gap_leaf_to_litter = sum(pftfrac(ps:pe)*(m_leafc_to_litter_p (ps:pe) + m_leafc_storage_to_litter_p(ps:pe) & + + m_leafc_xfer_to_litter_p(ps:pe))) + gap_froot_to_litter = sum(pftfrac(ps:pe)*(m_frootc_to_litter_p (ps:pe) + m_frootc_storage_to_litter_p(ps:pe)& + + m_frootc_xfer_to_litter_p(ps:pe))) + gap_livestem_to_litter = sum(pftfrac(ps:pe)*(m_livestemc_to_litter_p (ps:pe) + m_livestemc_storage_to_litter_p(ps:pe)& + + m_livestemc_xfer_to_litter_p(ps:pe))) + gap_deadstem_to_litter = sum(pftfrac(ps:pe)*(m_deadstemc_to_litter_p (ps:pe) + m_deadstemc_storage_to_litter_p(ps:pe)& + + m_deadstemc_xfer_to_litter_p(ps:pe))) + gap_livecroot_to_litter = sum(pftfrac(ps:pe)*(m_livecrootc_to_litter_p(ps:pe) + m_livecrootc_storage_to_litter_p(ps:pe)& + + m_livecrootc_xfer_to_litter_p(ps:pe))) + gap_deadcroot_to_litter = sum(pftfrac(ps:pe)*(m_deadcrootc_to_litter_p(ps:pe) + m_deadcrootc_storage_to_litter_p(ps:pe)& + + m_deadcrootc_xfer_to_litter_p(ps:pe))) + gap_gresp_to_litter = sum(pftfrac(ps:pe)*(m_gresp_storage_to_litter_p(ps:pe)+m_gresp_xfer_to_litter_p(ps:pe))) + + gap_veg_to_litter = sum((gap_mortality_to_met_c(1:nl_soil,i) + gap_mortality_to_cel_c(1:nl_soil,i)& + + gap_mortality_to_lig_c(1:nl_soil,i) + gap_mortality_to_cwdc (1:nl_soil,i))*dz_soi(1:nl_soil)) + phen_veg_to_litter = sum((phenology_to_met_c (1:nl_soil,i) + phenology_to_cel_c (1:nl_soil,i)& + + phenology_to_lig_c (1:nl_soil,i))*dz_soi(1:nl_soil)) + veg_to_litter = phen_to_litter + gap_leaf_to_litter + gap_froot_to_litter + gap_livestem_to_litter & + + gap_deadstem_to_litter + gap_livecroot_to_litter + gap_deadcroot_to_litter + gap_gresp_to_litter + + IF(abs(col_errcb) > cerror) THEN + write(*,*)'column cbalance error = ', col_errcb, i, mpas_rank + write(*,*)'Latdeg,Londeg=' , dlat, dlon + write(*,*)'begcb = ',col_begcb(i) + write(*,*)'endcb = ',col_endcb(i) + write(*,*)'delta store = ',col_endcb(i)-col_begcb(i) + write(*,*)'delta veg = ',col_vegendcb(i) - col_vegbegcb(i),totvegc(i),col_vegendcb(i),col_vegbegcb(i) + write(*,*)'delta soil = ',col_soilendcb(i) - col_soilbegcb(i),totsomc(i),totlitc(i),totcwdc(i),col_soilendcb(i),col_soilbegcb(i) + DO m = ps, pe + write(*,*)'m=',m,pftclass(m) + write(*,*)'vegc,leafc = ',leafc_p(m)+leafc_storage_p(m)+leafc_xfer_p(m) + write(*,*)'vegc,frootc = ',frootc_p(m)+frootc_storage_p(m)+frootc_xfer_p(m) + write(*,*)'vegc,livestemc = ',livestemc_p(m)+livestemc_storage_p(m)+livestemc_xfer_p(m) + write(*,*)'vegc,deadstemc = ',deadstemc_p(m)+deadstemc_storage_p(m)+deadstemc_xfer_p(m) + write(*,*)'vegc,livecrootc = ',livecrootc_p(m)+livecrootc_storage_p(m)+livecrootc_xfer_p(m) + write(*,*)'vegc,deadcrootc = ',deadcrootc_p(m)+deadcrootc_storage_p(m)+deadcrootc_xfer_p(m) + write(*,*)'grainc = ',grainc_p(m)+grainc_storage_p(m)+grainc_xfer_p(m)+cropseedc_deficit_p(m) + write(*,*)'growth respiration c = ',gresp_storage_p(m)+gresp_xfer_p(m)+xsmrpool_p(m) + ENDDO + write(*,*)'--------veg output to litter-------------' + write(*,*)'veg to soil and litter = ', veg_to_litter, phen_to_litter, gap_leaf_to_litter, gap_froot_to_litter, gap_livestem_to_litter, & + gap_deadstem_to_litter, gap_livecroot_to_litter, gap_deadcroot_to_litter , gap_gresp_to_litter + write(*,*)'--------liter and soil input from veg----' + write(*,*)'input to soil and litter = ',gap_veg_to_litter + phen_veg_to_litter + write(*,*)'phen, gap to litter = ',phen_veg_to_litter, gap_veg_to_litter + write(*,*)'--- Inputs ---' + write(*,*)'gpp = ',gpp(i)*deltim + write(*,*)'--- Outputs ---' + write(*,*)'er = ',er(i)*deltim + write(*,*)'ar = ',ar(i)*deltim + write(*,*)'decomp_hr = ',decomp_hr(i)*deltim + write(*,*)'fire_closs = ',fire_closs(i)*deltim + write(*,*)'col_hrv_xsmrpool_to_atm = ',hrv_xsmrpool_to_atm(i)*deltim + write(*,*)'wood_harvestc = ',wood_harvestc(i)*deltim + write(*,*)'grainc_to_cropprodc = ',grainc_to_cropprodc(i)*deltim, grainc_to_food_p(ps)*deltim + write(*,*)'-1*som_c_leached = ',som_c_leached(i)*deltim + CALL CoLM_stop('BGC carbon balance check failed.') + ENDIF + + END SUBROUTINE CBalanceCheck + + SUBROUTINE NBalanceCheck(i,ps,pe,deltim,dlat,dlon) + +! !DESCRIPTION: +! NBalanceCheck tests the carbon balance of each time step, which meet N balance equation: +! col_endnb - col_begnb = (col_ninputs - col_noutputs)*deltim +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i,ps,pe ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dlat ! latitude (degree) + real(r8),intent(in) :: dlon ! longitude (degree) + +!Local variables + real(r8),parameter :: nerror = 1.e-7_r8 + real(r8) :: col_ninputs, col_noutputs, col_errnb + + col_endnb(i) = totcoln(i) + col_vegendnb(i) = totvegn(i) + ntrunc_veg(i) + col_soilendnb(i) = totsomn(i) + totlitn(i) + totcwdn(i) + ntrunc_soil(i) + col_sminnendnb(i) = sminn(i) + + col_ninputs = ndep_to_sminn(i) + nfix_to_sminn(i) + supplement_to_sminn(i) + + col_ninputs = col_ninputs + fert_to_sminn(i) + soyfixn_to_sminn(i) + + col_noutputs = denit(i) + fire_nloss(i) + wood_harvestn(i) + grainn_to_cropprodn(i) + + IF(DEF_USE_NITRIF)THEN + col_noutputs = col_noutputs + f_n2o_nit(i) + smin_no3_leached(i) + smin_no3_runoff(i) + ELSE + col_noutputs = col_noutputs + sminn_leached(i) + ENDIF + + col_noutputs = col_noutputs - som_n_leached(i) + col_errnb =(col_ninputs - col_noutputs)*deltim - (col_endnb(i) - col_begnb(i)) + + IF (abs(col_errnb) > nerror) THEN ! + write(*,*)'column nbalance error = ',col_errnb, i, mpas_rank + write(*,*)'Latdeg,Londeg = ',dlat, dlon + write(*,*)'begnb = ',col_begnb(i) + write(*,*)'endnb = ',col_endnb(i) + write(*,*)'delta store = ',col_endnb(i)-col_begnb(i) + write(*,*)'delta veg = ',col_vegendnb(i)-col_vegbegnb(i) + write(*,*)'delta soil = ',col_soilendnb(i)-col_soilbegnb(i) + write(*,*)'delta sminn = ',col_sminnendnb(i)-col_sminnbegnb(i) + write(*,*)'smin_to_plant = ',sminn_to_plant(i)*deltim + write(*,*)'input mass = ',col_ninputs*deltim + write(*,*)'output mass = ',col_noutputs*deltim,f_n2o_nit(i)*deltim,smin_no3_leached(i)*deltim,& + smin_no3_runoff(i)*deltim, denit(i)*deltim,fire_nloss(i)*deltim,& + ( wood_harvestn(i) + grainn_to_cropprodn(i))*deltim + write(*,*)'net flux = ',(col_ninputs-col_noutputs)*deltim + write(*,*)'inputs,ffix,nfix,ndep = ',ffix_to_sminn(i)*deltim,nfix_to_sminn(i)*deltim,ndep_to_sminn(i)*deltim,& + fert_to_sminn(i)*deltim,soyfixn_to_sminn(i)*deltim + IF(DEF_USE_NITRIF)THEN + write(*,*)'outputs,leached,runoff,denit = ',smin_no3_leached(i)*deltim, smin_no3_runoff(i)*deltim,f_n2o_nit(i)*deltim + ELSE + write(*,*)'outputs,leached,denit,fire,harvest,som_n_leached',& + sminn_leached(i)*deltim,denit(i)*deltim,fire_nloss(i)*deltim,& + (wood_harvestn(i)+grainn_to_cropprodn(i))*deltim, - som_n_leached(i) + ENDIF + CALL CoLM_stop('BGC nitrogen balance check failed.') + ENDIF + + END SUBROUTINE NBalanceCheck + +END MODULE MOD_BGC_CNBalanceCheck +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate1.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate1.F90 new file mode 100644 index 0000000000..24f7bd6731 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate1.F90 @@ -0,0 +1,493 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNCStateUpdate1 + +!------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! First updates in vegetation and soil carbon. The major updates are included in bgc_CNCStateUpdate1Mod +! 1. Update phenology-associated veg and soil C pool size changes, including plant growth +! 2. Update decomposition-associated soil C pool size changes +! 3. Record the accumulated C transfers associated to phenology and decomposition for semi-analytic spinup +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record the accumulated phenology-associated C transfer for veg and soil C semi-analytic spinup +! 3) Record the accumulated decomposition-associated C transfer for soil C semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + USE MOD_Const_PFT, only: woody + USE MOD_BGC_Vars_TimeInvariants, only: & +! bgc constants + donor_pool, receiver_pool, i_met_lit, i_cel_lit, i_lig_lit, i_cwd, i_soil1, i_soil2, i_soil3 + + USE MOD_BGC_Vars_TimeVariables, only: & + I_met_c_vr_acc, I_cel_c_vr_acc, I_lig_c_vr_acc, & + AKX_met_to_soil1_c_vr_acc , AKX_cel_to_soil1_c_vr_acc , AKX_lig_to_soil2_c_vr_acc , AKX_soil1_to_soil2_c_vr_acc, & + AKX_cwd_to_cel_c_vr_acc , AKX_cwd_to_lig_c_vr_acc , AKX_soil1_to_soil3_c_vr_acc, AKX_soil2_to_soil1_c_vr_acc, & + AKX_soil2_to_soil3_c_vr_acc, AKX_soil3_to_soil1_c_vr_acc, & + AKX_met_exit_c_vr_acc , AKX_cel_exit_c_vr_acc , AKX_lig_exit_c_vr_acc , AKX_cwd_exit_c_vr_acc , & + AKX_soil1_exit_c_vr_acc , AKX_soil2_exit_c_vr_acc , AKX_soil3_exit_c_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & +! decomposition pools flux variables (in) + decomp_cpools_sourcesink, decomp_ctransfer_vr, decomp_hr_vr , & + phenology_to_met_c , phenology_to_cel_c , phenology_to_lig_c + + USE MOD_BGC_Vars_PFTimeVariables, only: & +! vegetation carbon state variables (inout) + leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p , livecrootc_storage_p, livecrootc_xfer_p, & + deadcrootc_p , deadcrootc_storage_p, deadcrootc_xfer_p, & + grainc_p , grainc_storage_p , grainc_xfer_p , & + cropseedc_deficit_p, xsmrpool_p , gresp_storage_p , gresp_xfer_p, & + cpool_p, & + +! crop variables (in) + harvdate_p , cropprod1c_p , & + +! SASU variables + I_leafc_p_acc , I_leafc_st_p_acc , I_frootc_p_acc , I_frootc_st_p_acc , & + I_livestemc_p_acc , I_livestemc_st_p_acc , I_deadstemc_p_acc , I_deadstemc_st_p_acc , & + I_livecrootc_p_acc, I_livecrootc_st_p_acc, I_deadcrootc_p_acc, I_deadcrootc_st_p_acc, & + I_grainc_p_acc , I_grainc_st_p_acc , & + + AKX_leafc_xf_to_leafc_p_acc , AKX_frootc_xf_to_frootc_p_acc , AKX_livestemc_xf_to_livestemc_p_acc , & + AKX_deadstemc_xf_to_deadstemc_p_acc , AKX_livecrootc_xf_to_livecrootc_p_acc , AKX_deadcrootc_xf_to_deadcrootc_p_acc , & + AKX_grainc_xf_to_grainc_p_acc , AKX_livestemc_to_deadstemc_p_acc , AKX_livecrootc_to_deadcrootc_p_acc , & + + AKX_leafc_st_to_leafc_xf_p_acc , AKX_frootc_st_to_frootc_xf_p_acc , AKX_livestemc_st_to_livestemc_xf_p_acc , & + AKX_deadstemc_st_to_deadstemc_xf_p_acc, AKX_livecrootc_st_to_livecrootc_xf_p_acc, AKX_deadcrootc_st_to_deadcrootc_xf_p_acc, & + AKX_livestemc_st_to_livestemc_xf_p_acc, AKX_grainc_st_to_grainc_xf_p_acc , & + + AKX_leafc_exit_p_acc , AKX_frootc_exit_p_acc , AKX_livestemc_exit_p_acc , & + AKX_deadstemc_exit_p_acc , AKX_livecrootc_exit_p_acc , AKX_deadcrootc_exit_p_acc , & + AKX_grainc_exit_p_acc , & + + AKX_leafc_st_exit_p_acc , AKX_frootc_st_exit_p_acc , AKX_livestemc_st_exit_p_acc , & + AKX_deadstemc_st_exit_p_acc , AKX_livecrootc_st_exit_p_acc , AKX_deadcrootc_st_exit_p_acc , & + AKX_grainc_st_exit_p_acc , & + + AKX_leafc_xf_exit_p_acc , AKX_frootc_xf_exit_p_acc , AKX_livestemc_xf_exit_p_acc , & + AKX_deadstemc_xf_exit_p_acc , AKX_livecrootc_xf_exit_p_acc , AKX_deadcrootc_xf_exit_p_acc , & + AKX_grainc_xf_exit_p_acc + + + USE MOD_BGC_Vars_1DPFTFluxes, only: & +! vegetation carbon flux variables (in) +! Vegetation physiology + psn_to_cpool_p, & + +! xfer to display + leafc_xfer_to_leafc_p , frootc_xfer_to_frootc_p , & + livestemc_xfer_to_livestemc_p , deadstemc_xfer_to_deadstemc_p , & + livecrootc_xfer_to_livecrootc_p, deadcrootc_xfer_to_deadcrootc_p, & + grainc_xfer_to_grainc_p , & + +! storage to xfer (in) + leafc_storage_to_xfer_p , frootc_storage_to_xfer_p , & + livestemc_storage_to_xfer_p , deadstemc_storage_to_xfer_p , & + livecrootc_storage_to_xfer_p, deadcrootc_storage_to_xfer_p, & + grainc_storage_to_xfer_p , gresp_storage_to_xfer_p , & + +! display to litter & live to dead (in) + leafc_to_litter_p , frootc_to_litter_p , & + grainc_to_food_p , grainc_to_seed_p , & + crop_seedc_to_leaf_p , livestemc_to_litter_p , & + livestemc_to_deadstemc_p, livecrootc_to_deadcrootc_p, & + +! crop + cropprod1c_loss_p, & + +! cpool to display/storage (in) + cpool_to_xsmrpool_p , cpool_to_gresp_storage_p , & + cpool_to_leafc_p , cpool_to_leafc_storage_p , & + cpool_to_frootc_p , cpool_to_frootc_storage_p , & + cpool_to_livestemc_p , cpool_to_livestemc_storage_p , & + cpool_to_deadstemc_p , cpool_to_deadstemc_storage_p , & + cpool_to_livecrootc_p, cpool_to_livecrootc_storage_p, & + cpool_to_deadcrootc_p, cpool_to_deadcrootc_storage_p, & + cpool_to_grainc_p , cpool_to_grainc_storage_p , & + +! cpool to growth repsiration + cpool_leaf_gr_p , cpool_froot_gr_p , & + cpool_livestem_gr_p , cpool_deadstem_gr_p , & + cpool_livecroot_gr_p , cpool_deadcroot_gr_p , & + cpool_leaf_storage_gr_p , cpool_froot_storage_gr_p , & + cpool_livestem_storage_gr_p , cpool_deadstem_storage_gr_p , & + cpool_livecroot_storage_gr_p, cpool_deadcroot_storage_gr_p , & + + cpool_grain_gr_p , cpool_grain_storage_gr_p , & + +! maintenance respiration fluxes (in) + leaf_xsmr_p, froot_xsmr_p, livestem_xsmr_p, livecroot_xsmr_p, grain_xsmr_p , & + leaf_curmr_p, froot_curmr_p, livestem_curmr_p, livecroot_curmr_p, grain_curmr_p, & + +! growth respiration fluxes (in/inout) + transfer_leaf_gr_p , transfer_froot_gr_p , & + transfer_livestem_gr_p , transfer_deadstem_gr_p , & + transfer_livecroot_gr_p, transfer_deadcroot_gr_p, & + transfer_grain_gr_p , xsmrpool_to_atm_p + + + IMPLICIT NONE + + PUBLIC :: CStateUpdate1 + +CONTAINS + + SUBROUTINE CStateUpdate1 (i, ps, pe, deltim, nl_soil, ndecomp_transitions, npcropmin) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_transitions ! number of total transitions among different litter & soil bgc pools + integer ,intent(in) :: npcropmin ! index of first crop pft + +! Local variables + integer j,k + integer ivt, m + + DO m = ps, pe + cpool_p(m) = cpool_p(m) + psn_to_cpool_p(m) * deltim + ENDDO + DO j=1,nl_soil + decomp_cpools_sourcesink(j,i_met_lit,i) = phenology_to_met_c(j,i) *deltim + decomp_cpools_sourcesink(j,i_cel_lit,i) = phenology_to_cel_c(j,i) *deltim + decomp_cpools_sourcesink(j,i_lig_lit,i) = phenology_to_lig_c(j,i) *deltim + decomp_cpools_sourcesink(j,i_cwd ,i) = 0._r8 + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j=1,nl_soil + I_met_c_vr_acc(j,i) = I_met_c_vr_acc(j,i) + phenology_to_met_c(j,i) *deltim + I_cel_c_vr_acc(j,i) = I_cel_c_vr_acc(j,i) + phenology_to_cel_c(j,i) *deltim + I_lig_c_vr_acc(j,i) = I_lig_c_vr_acc(j,i) + phenology_to_lig_c(j,i) *deltim + ENDDO + ENDIF + + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + decomp_cpools_sourcesink(j,donor_pool(k),i) = & + decomp_cpools_sourcesink(j,donor_pool(k),i) & + - (decomp_hr_vr(j,k,i) + decomp_ctransfer_vr(j,k,i)) * deltim + ENDDO + ENDDO + + DO k = 1,ndecomp_transitions + IF ( receiver_pool(k) /= 0 ) THEN ! skip terminal transitions + DO j = 1,nl_soil + decomp_cpools_sourcesink(j,receiver_pool(k),i) = & + decomp_cpools_sourcesink(j,receiver_pool(k),i) & + + decomp_ctransfer_vr(j,k,i) * deltim + ENDDO + ENDIF + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j = 1, nl_soil + AKX_met_to_soil1_c_vr_acc (j,i) = AKX_met_to_soil1_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 1,i) * deltim + AKX_cel_to_soil1_c_vr_acc (j,i) = AKX_cel_to_soil1_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 2,i) * deltim + AKX_lig_to_soil2_c_vr_acc (j,i) = AKX_lig_to_soil2_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 3,i) * deltim + AKX_soil1_to_soil2_c_vr_acc(j,i) = AKX_soil1_to_soil2_c_vr_acc(j,i) + decomp_ctransfer_vr(j, 4,i) * deltim + AKX_cwd_to_cel_c_vr_acc (j,i) = AKX_cwd_to_cel_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 5,i) * deltim + AKX_cwd_to_lig_c_vr_acc (j,i) = AKX_cwd_to_lig_c_vr_acc (j,i) + decomp_ctransfer_vr(j, 6,i) * deltim + AKX_soil1_to_soil3_c_vr_acc(j,i) = AKX_soil1_to_soil3_c_vr_acc(j,i) + decomp_ctransfer_vr(j, 7,i) * deltim + AKX_soil2_to_soil1_c_vr_acc(j,i) = AKX_soil2_to_soil1_c_vr_acc(j,i) + decomp_ctransfer_vr(j, 8,i) * deltim + AKX_soil2_to_soil3_c_vr_acc(j,i) = AKX_soil2_to_soil3_c_vr_acc(j,i) + decomp_ctransfer_vr(j, 9,i) * deltim + AKX_soil3_to_soil1_c_vr_acc(j,i) = AKX_soil3_to_soil1_c_vr_acc(j,i) + decomp_ctransfer_vr(j,10,i) * deltim + + AKX_met_exit_c_vr_acc (j,i) = AKX_met_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 1,i) + decomp_ctransfer_vr(j, 1,i)) * deltim + AKX_cel_exit_c_vr_acc (j,i) = AKX_cel_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 2,i) + decomp_ctransfer_vr(j, 2,i)) * deltim + AKX_lig_exit_c_vr_acc (j,i) = AKX_lig_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 3,i) + decomp_ctransfer_vr(j, 3,i)) * deltim + AKX_soil1_exit_c_vr_acc (j,i) = AKX_soil1_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 4,i) + decomp_ctransfer_vr(j, 4,i)) * deltim + AKX_cwd_exit_c_vr_acc (j,i) = AKX_cwd_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 5,i) + decomp_ctransfer_vr(j, 5,i)) * deltim + AKX_cwd_exit_c_vr_acc (j,i) = AKX_cwd_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 6,i) + decomp_ctransfer_vr(j, 6,i)) * deltim + AKX_soil1_exit_c_vr_acc (j,i) = AKX_soil1_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 7,i) + decomp_ctransfer_vr(j, 7,i)) * deltim + AKX_soil2_exit_c_vr_acc (j,i) = AKX_soil2_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 8,i) + decomp_ctransfer_vr(j, 8,i)) * deltim + AKX_soil2_exit_c_vr_acc (j,i) = AKX_soil2_exit_c_vr_acc (j,i) + (decomp_hr_vr(j, 9,i) + decomp_ctransfer_vr(j, 9,i)) * deltim + AKX_soil3_exit_c_vr_acc (j,i) = AKX_soil3_exit_c_vr_acc (j,i) + (decomp_hr_vr(j,10,i) + decomp_ctransfer_vr(j,10,i)) * deltim + ENDDO + ENDIF + + DO m = ps , pe + ivt = pftclass(m) + leafc_p (m) = leafc_p (m) + leafc_xfer_to_leafc_p (m) * deltim + leafc_xfer_p (m) = leafc_xfer_p (m) - leafc_xfer_to_leafc_p (m) * deltim + frootc_p (m) = frootc_p (m) + frootc_xfer_to_frootc_p(m) * deltim + frootc_xfer_p(m) = frootc_xfer_p(m) - frootc_xfer_to_frootc_p(m) * deltim + IF(woody(ivt) == 1)THEN + livestemc_p (m) = livestemc_p (m) + livestemc_xfer_to_livestemc_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) - livestemc_xfer_to_livestemc_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) + deadstemc_xfer_to_deadstemc_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) - deadstemc_xfer_to_deadstemc_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) + livecrootc_xfer_to_livecrootc_p(m) * deltim + livecrootc_xfer_p(m) = livecrootc_xfer_p(m) - livecrootc_xfer_to_livecrootc_p(m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) + deadcrootc_xfer_to_deadcrootc_p(m) * deltim + deadcrootc_xfer_p(m) = deadcrootc_xfer_p(m) - deadcrootc_xfer_to_deadcrootc_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops +! lines here for consistency; the transfer terms are zero + livestemc_p (m) = livestemc_p (m) + livestemc_xfer_to_livestemc_p(m) * deltim + livestemc_xfer_p(m) = livestemc_xfer_p(m) - livestemc_xfer_to_livestemc_p(m) * deltim + grainc_p (m) = grainc_p (m) + grainc_xfer_to_grainc_p (m) * deltim + grainc_xfer_p (m) = grainc_xfer_p (m) - grainc_xfer_to_grainc_p (m) * deltim + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafc_xf_to_leafc_p_acc (m) = AKX_leafc_xf_to_leafc_p_acc (m) + leafc_xfer_to_leafc_p (m) * deltim + AKX_frootc_xf_to_frootc_p_acc(m) = AKX_frootc_xf_to_frootc_p_acc(m) + frootc_xfer_to_frootc_p(m) * deltim + AKX_leafc_xf_exit_p_acc (m) = AKX_leafc_xf_exit_p_acc (m) + leafc_xfer_to_leafc_p (m) * deltim + AKX_frootc_xf_exit_p_acc (m) = AKX_frootc_xf_exit_p_acc (m) + frootc_xfer_to_frootc_p(m) * deltim + IF(woody(ivt) == 1)THEN + AKX_livestemc_xf_to_livestemc_p_acc (m) = AKX_livestemc_xf_to_livestemc_p_acc (m) + livestemc_xfer_to_livestemc_p (m) * deltim + AKX_livestemc_xf_exit_p_acc (m) = AKX_livestemc_xf_exit_p_acc (m) + livestemc_xfer_to_livestemc_p (m) * deltim + AKX_deadstemc_xf_to_deadstemc_p_acc (m) = AKX_deadstemc_xf_to_deadstemc_p_acc (m) + deadstemc_xfer_to_deadstemc_p (m) * deltim + AKX_deadstemc_xf_exit_p_acc (m) = AKX_deadstemc_xf_exit_p_acc (m) + deadstemc_xfer_to_deadstemc_p (m) * deltim + AKX_livecrootc_xf_to_livecrootc_p_acc(m) = AKX_livecrootc_xf_to_livecrootc_p_acc(m) + livecrootc_xfer_to_livecrootc_p(m) * deltim + AKX_livecrootc_xf_exit_p_acc (m) = AKX_livecrootc_xf_exit_p_acc (m) + livecrootc_xfer_to_livecrootc_p(m) * deltim + AKX_deadcrootc_xf_to_deadcrootc_p_acc(m) = AKX_deadcrootc_xf_to_deadcrootc_p_acc(m) + deadcrootc_xfer_to_deadcrootc_p(m) * deltim + AKX_deadcrootc_xf_exit_p_acc (m) = AKX_deadcrootc_xf_exit_p_acc (m) + deadcrootc_xfer_to_deadcrootc_p(m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + AKX_livestemc_xf_to_livestemc_p_acc(m) = AKX_livestemc_xf_to_livestemc_p_acc(m) + livestemc_xfer_to_livestemc_p(m) * deltim + AKX_livestemc_xf_exit_p_acc (m) = AKX_livestemc_xf_exit_p_acc (m) + livestemc_xfer_to_livestemc_p(m) * deltim + AKX_grainc_xf_to_grainc_p_acc (m) = AKX_grainc_xf_to_grainc_p_acc (m) + grainc_xfer_to_grainc_p (m) * deltim + AKX_grainc_xf_exit_p_acc (m) = AKX_grainc_xf_exit_p_acc (m) + grainc_xfer_to_grainc_p (m) * deltim + ENDIF + ENDIF + +! phenology: litterfall fluxes + leafc_p (m) = leafc_p (m) - leafc_to_litter_p (m) * deltim + frootc_p(m) = frootc_p(m) - frootc_to_litter_p(m) * deltim + +! livewood turnover fluxes + IF (woody(ivt) == 1) THEN + livestemc_p (m) = livestemc_p (m) - livestemc_to_deadstemc_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) + livestemc_to_deadstemc_p (m) * deltim + livecrootc_p(m) = livecrootc_p(m) - livecrootc_to_deadcrootc_p(m) * deltim + deadcrootc_p(m) = deadcrootc_p(m) + livecrootc_to_deadcrootc_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + livestemc_p (m) = livestemc_p (m) - livestemc_to_litter_p(m) * deltim + grainc_p (m) = grainc_p (m) - (grainc_to_food_p(m) + grainc_to_seed_p(m)) * deltim + cropseedc_deficit_p(m) = cropseedc_deficit_p(m) - crop_seedc_to_leaf_p(m) * deltim + grainc_to_seed_p(m) * deltim + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafc_exit_p_acc (m) = AKX_leafc_exit_p_acc (m) + leafc_to_litter_p (m) * deltim + AKX_frootc_exit_p_acc(m) = AKX_frootc_exit_p_acc(m) + frootc_to_litter_p(m) * deltim + IF(woody(ivt) == 1) THEN + AKX_livestemc_to_deadstemc_p_acc (m) = AKX_livestemc_to_deadstemc_p_acc (m) + livestemc_to_deadstemc_p (m) * deltim + AKX_livestemc_exit_p_acc (m) = AKX_livestemc_exit_p_acc (m) + livestemc_to_deadstemc_p (m) * deltim + AKX_livecrootc_to_deadcrootc_p_acc(m) = AKX_livecrootc_to_deadcrootc_p_acc(m) + livecrootc_to_deadcrootc_p(m) * deltim + AKX_livecrootc_exit_p_acc (m) = AKX_livecrootc_exit_p_acc (m) + livecrootc_to_deadcrootc_p(m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + AKX_livestemc_exit_p_acc (m) = AKX_livestemc_exit_p_acc (m) + livestemc_to_litter_p (m) * deltim + AKX_grainc_exit_p_acc (m) = AKX_grainc_exit_p_acc (m) + (grainc_to_food_p(m) + grainc_to_seed_p(m)) * deltim + ENDIF + ENDIF +! maintenance respiration fluxes from xsmrpool + cpool_p (m) = cpool_p (m) - cpool_to_xsmrpool_p(m) * deltim + cpool_p (m) = cpool_p (m) - leaf_curmr_p (m) * deltim + cpool_p (m) = cpool_p (m) - froot_curmr_p (m) * deltim + IF (woody(ivt) == 1) THEN + cpool_p(m) = cpool_p (m) - livestem_curmr_p (m) * deltim + cpool_p(m) = cpool_p (m) - livecroot_curmr_p (m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN + cpool_p(m) = cpool_p (m) - livestem_curmr_p (m) * deltim + cpool_p(m) = cpool_p (m) - grain_curmr_p (m) * deltim + ENDIF +#ifdef FUN + cpool_p (m) = cpool_p (m) - soilc_change_p (m) * deltim +#endif + xsmrpool_p(m) = xsmrpool_p(m) + cpool_to_xsmrpool_p(m) * deltim + xsmrpool_p(m) = xsmrpool_p(m) - leaf_xsmr_p (m) * deltim + xsmrpool_p(m) = xsmrpool_p(m) - froot_xsmr_p (m) * deltim + IF (woody(ivt) == 1) THEN + xsmrpool_p(m) = xsmrpool_p(m) - livestem_xsmr_p (m) * deltim + xsmrpool_p(m) = xsmrpool_p(m) - livecroot_xsmr_p(m) * deltim + ENDIF + cpool_p (m) = cpool_p (m) - cpool_to_leafc_p (m) * deltim + leafc_p (m) = leafc_p (m) + cpool_to_leafc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_leafc_storage_p (m) * deltim + leafc_storage_p (m) = leafc_storage_p (m) + cpool_to_leafc_storage_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_frootc_p (m) * deltim + frootc_p (m) = frootc_p (m) + cpool_to_frootc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_frootc_storage_p(m) * deltim + frootc_storage_p(m) = frootc_storage_p(m) + cpool_to_frootc_storage_p(m) * deltim + IF (woody(ivt) == 1) THEN + cpool_p (m) = cpool_p (m) - cpool_to_livestemc_p (m) * deltim + livestemc_p (m) = livestemc_p (m) + cpool_to_livestemc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_livestemc_storage_p (m) * deltim + livestemc_storage_p (m) = livestemc_storage_p (m) + cpool_to_livestemc_storage_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_deadstemc_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) + cpool_to_deadstemc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_deadstemc_storage_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) + cpool_to_deadstemc_storage_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_livecrootc_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) + cpool_to_livecrootc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_livecrootc_storage_p(m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) + cpool_to_livecrootc_storage_p(m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_deadcrootc_p (m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) + cpool_to_deadcrootc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_deadcrootc_storage_p(m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) + cpool_to_deadcrootc_storage_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + cpool_p (m) = cpool_p (m) - cpool_to_livestemc_p (m) * deltim + livestemc_p (m) = livestemc_p (m) + cpool_to_livestemc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_livestemc_storage_p(m) * deltim + livestemc_storage_p(m) = livestemc_storage_p(m) + cpool_to_livestemc_storage_p(m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_grainc_p (m) * deltim + grainc_p (m) = grainc_p (m) + cpool_to_grainc_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_to_grainc_storage_p (m) * deltim + grainc_storage_p (m) = grainc_storage_p (m) + cpool_to_grainc_storage_p (m) * deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + I_leafc_p_acc(m) = I_leafc_p_acc(m) + cpool_to_leafc_p (m) * deltim + I_leafc_st_p_acc(m) = I_leafc_st_p_acc(m) + cpool_to_leafc_storage_p (m) * deltim + I_frootc_p_acc(m) = I_frootc_p_acc(m) + cpool_to_frootc_p (m) * deltim + I_frootc_st_p_acc(m) = I_frootc_st_p_acc(m) + cpool_to_frootc_storage_p (m) * deltim + IF(woody(ivt) == 1) THEN + I_livestemc_p_acc (m) = I_livestemc_p_acc (m) + cpool_to_livestemc_p (m) * deltim + I_livestemc_st_p_acc (m) = I_livestemc_st_p_acc (m) + cpool_to_livestemc_storage_p (m) * deltim + I_deadstemc_p_acc (m) = I_deadstemc_p_acc (m) + cpool_to_deadstemc_p (m) * deltim + I_deadstemc_st_p_acc (m) = I_deadstemc_st_p_acc (m) + cpool_to_deadstemc_storage_p (m) * deltim + I_livecrootc_p_acc (m) = I_livecrootc_p_acc (m) + cpool_to_livecrootc_p (m) * deltim + I_livecrootc_st_p_acc(m) = I_livecrootc_st_p_acc(m) + cpool_to_livecrootc_storage_p(m) * deltim + I_deadcrootc_p_acc (m) = I_deadcrootc_p_acc (m) + cpool_to_deadcrootc_p (m) * deltim + I_deadcrootc_st_p_acc(m) = I_deadcrootc_st_p_acc(m) + cpool_to_deadcrootc_storage_p(m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + I_livestemc_p_acc (m) = I_livestemc_p_acc (m) + cpool_to_livestemc_p (m) * deltim + I_livestemc_st_p_acc (m) = I_livestemc_st_p_acc (m) + cpool_to_livestemc_storage_p (m) * deltim + I_grainc_p_acc (m) = I_grainc_p_acc (m) + cpool_to_grainc_p (m) * deltim + I_grainc_st_p_acc (m) = I_grainc_st_p_acc (m) + cpool_to_grainc_storage_p (m) * deltim + ENDIF + ENDIF + ! growth respiration for transfer growth + cpool_p (m) = cpool_p (m) - cpool_leaf_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_froot_gr_p (m) * deltim + IF(woody(ivt) == 1) THEN + cpool_p (m) = cpool_p (m) - cpool_livestem_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_deadstem_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_livecroot_gr_p(m) * deltim + cpool_p (m) = cpool_p (m) - cpool_deadcroot_gr_p(m) * deltim + ENDIF + IF(ivt >= npcropmin)THEN + cpool_p (m) = cpool_p (m) - cpool_livestem_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_grain_gr_p (m) * deltim + ENDIF + + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_leaf_gr_p (m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_froot_gr_p(m) * deltim + IF (woody(ivt) == 1) THEN + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_livestem_gr_p (m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_deadstem_gr_p (m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_livecroot_gr_p(m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_deadcroot_gr_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_livestem_gr_p(m) * deltim + gresp_xfer_p(m) = gresp_xfer_p(m) - transfer_grain_gr_p (m) * deltim + ENDIF + ! growth respiration at time of storage + cpool_p (m) = cpool_p (m) - cpool_leaf_storage_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_froot_storage_gr_p(m) * deltim + IF(woody(ivt) == 1)THEN + cpool_p (m) = cpool_p (m) - cpool_livestem_storage_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_deadstem_storage_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_livecroot_storage_gr_p(m) * deltim + cpool_p (m) = cpool_p (m) - cpool_deadcroot_storage_gr_p(m) * deltim + ENDIF + IF(ivt >= npcropmin)THEN + cpool_p (m) = cpool_p (m) - cpool_livestem_storage_gr_p (m) * deltim + cpool_p (m) = cpool_p (m) - cpool_grain_storage_gr_p (m) * deltim + ENDIF + + ! growth respiration stored for release during transfer growth + cpool_p (m) = cpool_p (m) - cpool_to_gresp_storage_p(m) * deltim + gresp_storage_p(m) = gresp_storage_p(m) + cpool_to_gresp_storage_p(m) * deltim + + ! move storage pools into transfer pools + leafc_storage_p (m) = leafc_storage_p (m) - leafc_storage_to_xfer_p (m) * deltim + leafc_xfer_p (m) = leafc_xfer_p (m) + leafc_storage_to_xfer_p (m) * deltim + frootc_storage_p(m) = frootc_storage_p(m) - frootc_storage_to_xfer_p(m) * deltim + frootc_xfer_p (m) = frootc_xfer_p (m) + frootc_storage_to_xfer_p(m) * deltim + IF (woody(ivt) == 1) THEN + gresp_storage_p (m) = gresp_storage_p (m) - gresp_storage_to_xfer_p(m) * deltim + gresp_xfer_p (m) = gresp_xfer_p (m) + gresp_storage_to_xfer_p(m) * deltim + + livestemc_storage_p (m) = livestemc_storage_p (m) - livestemc_storage_to_xfer_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) + livestemc_storage_to_xfer_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) - deadstemc_storage_to_xfer_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) + deadstemc_storage_to_xfer_p (m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) - livecrootc_storage_to_xfer_p(m) * deltim + livecrootc_xfer_p (m) = livecrootc_xfer_p (m) + livecrootc_storage_to_xfer_p(m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) - deadcrootc_storage_to_xfer_p(m) * deltim + deadcrootc_xfer_p (m) = deadcrootc_xfer_p (m) + deadcrootc_storage_to_xfer_p(m) * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + livestemc_storage_p (m) = livestemc_storage_p(m) - livestemc_storage_to_xfer_p(m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) + livestemc_storage_to_xfer_p(m) * deltim + grainc_storage_p (m) = grainc_storage_p (m) - grainc_storage_to_xfer_p (m) * deltim + grainc_xfer_p (m) = grainc_xfer_p (m) + grainc_storage_to_xfer_p (m) * deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafc_st_to_leafc_xf_p_acc (m) = AKX_leafc_st_to_leafc_xf_p_acc (m) + leafc_storage_to_xfer_p (m) * deltim + AKX_leafc_st_exit_p_acc (m) = AKX_leafc_st_exit_p_acc (m) + leafc_storage_to_xfer_p (m) * deltim + AKX_frootc_st_to_frootc_xf_p_acc(m) = AKX_frootc_st_to_frootc_xf_p_acc(m) + frootc_storage_to_xfer_p(m) * deltim + AKX_frootc_st_exit_p_acc (m) = AKX_frootc_st_exit_p_acc (m) + frootc_storage_to_xfer_p(m) * deltim + IF(woody(ivt) == 1) THEN + AKX_livestemc_st_to_livestemc_xf_p_acc (m) = AKX_livestemc_st_to_livestemc_xf_p_acc (m) + livestemc_storage_to_xfer_p (m) * deltim + AKX_livestemc_st_exit_p_acc (m) = AKX_livestemc_st_exit_p_acc (m) + livestemc_storage_to_xfer_p (m) * deltim + AKX_deadstemc_st_to_deadstemc_xf_p_acc (m) = AKX_deadstemc_st_to_deadstemc_xf_p_acc (m) + deadstemc_storage_to_xfer_p (m) * deltim + AKX_deadstemc_st_exit_p_acc (m) = AKX_deadstemc_st_exit_p_acc (m) + deadstemc_storage_to_xfer_p (m) * deltim + AKX_livecrootc_st_to_livecrootc_xf_p_acc(m) = AKX_livecrootc_st_to_livecrootc_xf_p_acc(m) + livecrootc_storage_to_xfer_p(m) * deltim + AKX_livecrootc_st_exit_p_acc (m) = AKX_livecrootc_st_exit_p_acc (m) + livecrootc_storage_to_xfer_p(m) * deltim + AKX_deadcrootc_st_to_deadcrootc_xf_p_acc(m) = AKX_deadcrootc_st_to_deadcrootc_xf_p_acc(m) + deadcrootc_storage_to_xfer_p(m) * deltim + AKX_deadcrootc_st_exit_p_acc (m) = AKX_deadcrootc_st_exit_p_acc (m) + deadcrootc_storage_to_xfer_p(m) * deltim + ENDIF + IF( ivt >= npcropmin) THEN + AKX_livestemc_st_to_livestemc_xf_p_acc (m) = AKX_livestemc_st_to_livestemc_xf_p_acc (m) + livestemc_storage_to_xfer_p (m) * deltim + AKX_livestemc_st_exit_p_acc (m) = AKX_livestemc_st_exit_p_acc (m) + livestemc_storage_to_xfer_p (m) * deltim + AKX_grainc_st_to_grainc_xf_p_acc (m) = AKX_grainc_st_to_grainc_xf_p_acc (m) + grainc_storage_to_xfer_p (m) * deltim + AKX_grainc_st_exit_p_acc (m) = AKX_grainc_st_exit_p_acc (m) + grainc_storage_to_xfer_p (m) * deltim + ENDIF + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + xsmrpool_p(m) = xsmrpool_p(m) - livestem_xsmr_p(m)*deltim + xsmrpool_p(m) = xsmrpool_p(m) - grain_xsmr_p (m)*deltim + IF (harvdate_p(m) < 999) THEN ! beginning at harvest, send to atm + xsmrpool_to_atm_p(m) = xsmrpool_to_atm_p(m) + xsmrpool_p(m)/deltim + xsmrpool_p (m) = 0._r8 + xsmrpool_to_atm_p(m) = xsmrpool_to_atm_p(m) + cpool_p (m)/deltim + cpool_p (m) = 0._r8 + xsmrpool_to_atm_p(m) = xsmrpool_to_atm_p(m) + frootc_p(m)/deltim + frootc_p (m) = 0._r8 + ENDIF + ENDIF +#ifdef CROP + cropprod1c_loss_p(m) = cropprod1c_p(m) * 7.2e-8_r8 + cropprod1c_p (m) = cropprod1c_p(m) + grainc_to_food_p(m) * deltim - cropprod1c_loss_p(m) * deltim +#endif + ENDDO ! END pft loop + + END SUBROUTINE CStateUpdate1 + +END MODULE MOD_BGC_CNCStateUpdate1 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate2.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate2.F90 new file mode 100644 index 0000000000..25fee8e971 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate2.F90 @@ -0,0 +1,176 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNCStateUpdate2 + +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! First updates in vegetation and soil carbon. The major updates are included in bgc_CNCStateUpdate1Mod +! 1. Update gap-mortality-associated veg and soil C pool size changes +! 2. Record the accumulated C transfers associated to gap-mortality for semi-analytic spinup + +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record the accumulated gap-mortality-associated C transfers for veg and soil C semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_Vars_TimeInvariants, only: & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd + USE MOD_Vars_TimeVariables, only: & +! decomposition pools & fluxes variables (inout) + decomp_cpools_vr, & + I_met_c_vr_acc, I_cel_c_vr_acc, I_lig_c_vr_acc, I_cwd_c_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & + gap_mortality_to_met_c, gap_mortality_to_cel_c , & + gap_mortality_to_lig_c, gap_mortality_to_cwdc + + USE MOD_BGC_Vars_PFTimeVariables, only: & +! vegetation carbon state variables (inout) + leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p , livecrootc_storage_p, livecrootc_xfer_p, & + deadcrootc_p , deadcrootc_storage_p, deadcrootc_xfer_p, & + gresp_storage_p , gresp_xfer_p , & + +! SASU variables + AKX_leafc_exit_p_acc , AKX_leafc_st_exit_p_acc , AKX_leafc_xf_exit_p_acc , & + AKX_frootc_exit_p_acc , AKX_frootc_st_exit_p_acc , AKX_frootc_xf_exit_p_acc , & + AKX_livestemc_exit_p_acc , AKX_livestemc_st_exit_p_acc , AKX_livestemc_xf_exit_p_acc , & + AKX_deadstemc_exit_p_acc , AKX_deadstemc_st_exit_p_acc , AKX_deadstemc_xf_exit_p_acc , & + AKX_livecrootc_exit_p_acc, AKX_livecrootc_st_exit_p_acc, AKX_livecrootc_xf_exit_p_acc, & + AKX_deadcrootc_exit_p_acc, AKX_deadcrootc_st_exit_p_acc, AKX_deadcrootc_xf_exit_p_acc + + USE MOD_BGC_Vars_1DPFTFluxes, only: & +! vegetation carbon flux variables + m_leafc_to_litter_p , m_leafc_storage_to_litter_p , m_leafc_xfer_to_litter_p , & + m_frootc_to_litter_p , m_frootc_storage_to_litter_p , m_frootc_xfer_to_litter_p , & + m_livestemc_to_litter_p , m_livestemc_storage_to_litter_p , m_livestemc_xfer_to_litter_p , & + m_deadstemc_to_litter_p , m_deadstemc_storage_to_litter_p , m_deadstemc_xfer_to_litter_p , & + m_livecrootc_to_litter_p , m_livecrootc_storage_to_litter_p, m_livecrootc_xfer_to_litter_p, & + m_deadcrootc_to_litter_p , m_deadcrootc_storage_to_litter_p, m_deadcrootc_xfer_to_litter_p, & + m_gresp_storage_to_litter_p, m_gresp_xfer_to_litter_p + + IMPLICIT NONE + + PUBLIC CStateUpdate2 + +CONTAINS + + SUBROUTINE CStateUpdate2 (i, ps, pe, deltim, nl_soil) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in second + integer ,intent(in) :: nl_soil ! number of total soil layers + + integer j + integer m + +! column level carbon fluxes from gap-phase mortality + DO j = 1,nl_soil +! column gap mortality fluxes + decomp_cpools_vr(j,i_met_lit,i) = & + decomp_cpools_vr(j,i_met_lit,i) + gap_mortality_to_met_c(j,i) * deltim + decomp_cpools_vr(j,i_cel_lit,i) = & + decomp_cpools_vr(j,i_cel_lit,i) + gap_mortality_to_cel_c(j,i) * deltim + decomp_cpools_vr(j,i_lig_lit,i) = & + decomp_cpools_vr(j,i_lig_lit,i) + gap_mortality_to_lig_c(j,i) * deltim + decomp_cpools_vr(j,i_cwd,i) = & + decomp_cpools_vr(j,i_cwd,i) + gap_mortality_to_cwdc(j,i) * deltim + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j = 1,nl_soil + I_met_c_vr_acc(j,i) = I_met_c_vr_acc(j,i) + gap_mortality_to_met_c(j,i) * deltim + I_cel_c_vr_acc(j,i) = I_cel_c_vr_acc(j,i) + gap_mortality_to_cel_c(j,i) * deltim + I_lig_c_vr_acc(j,i) = I_lig_c_vr_acc(j,i) + gap_mortality_to_lig_c(j,i) * deltim + I_cwd_c_vr_acc(j,i) = I_cwd_c_vr_acc(j,i) + gap_mortality_to_cwdc (j,i) * deltim + ENDDO + ENDIF + + ! patch loop + + DO m = ps, pe + gresp_xfer_p (m) = gresp_xfer_p(m) & + - m_gresp_xfer_to_litter_p (m) * deltim + gresp_storage_p (m) = gresp_storage_p(m) & + - m_gresp_storage_to_litter_p (m) * deltim + ! patch-level carbon fluxes from gap-phase mortality + ! displayed pools + leafc_p (m) = leafc_p (m) & + - m_leafc_to_litter_p (m) * deltim + frootc_p (m) = frootc_p (m) & + - m_frootc_to_litter_p (m) * deltim + livestemc_p (m) = livestemc_p (m) & + - m_livestemc_to_litter_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) & + - m_deadstemc_to_litter_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) & + - m_livecrootc_to_litter_p (m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) & + - m_deadcrootc_to_litter_p (m) * deltim + + ! storage pools + leafc_storage_p (m) = leafc_storage_p (m) & + - m_leafc_storage_to_litter_p (m) * deltim + frootc_storage_p (m) = frootc_storage_p (m) & + - m_frootc_storage_to_litter_p (m) * deltim + livestemc_storage_p (m) = livestemc_storage_p (m) & + - m_livestemc_storage_to_litter_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) & + - m_deadstemc_storage_to_litter_p (m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) & + - m_livecrootc_storage_to_litter_p(m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) & + - m_deadcrootc_storage_to_litter_p(m) * deltim + + ! transfer pools + leafc_xfer_p (m) = leafc_xfer_p (m) & + - m_leafc_xfer_to_litter_p (m) * deltim + frootc_xfer_p (m) = frootc_xfer_p (m) & + - m_frootc_xfer_to_litter_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) & + - m_livestemc_xfer_to_litter_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) & + - m_deadstemc_xfer_to_litter_p (m) * deltim + livecrootc_xfer_p (m) = livecrootc_xfer_p (m) & + - m_livecrootc_xfer_to_litter_p (m) * deltim + deadcrootc_xfer_p (m) = deadcrootc_xfer_p (m) & + - m_deadcrootc_xfer_to_litter_p (m) * deltim + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafc_exit_p_acc (m) = AKX_leafc_exit_p_acc (m) + m_leafc_to_litter_p (m) * deltim + AKX_frootc_exit_p_acc (m) = AKX_frootc_exit_p_acc (m) + m_frootc_to_litter_p (m) * deltim + AKX_livestemc_exit_p_acc (m) = AKX_livestemc_exit_p_acc (m) + m_livestemc_to_litter_p (m) * deltim + AKX_deadstemc_exit_p_acc (m) = AKX_deadstemc_exit_p_acc (m) + m_deadstemc_to_litter_p (m) * deltim + AKX_livecrootc_exit_p_acc (m) = AKX_livecrootc_exit_p_acc (m) + m_livecrootc_to_litter_p (m) * deltim + AKX_deadcrootc_exit_p_acc (m) = AKX_deadcrootc_exit_p_acc (m) + m_deadcrootc_to_litter_p (m) * deltim + + AKX_leafc_st_exit_p_acc (m) = AKX_leafc_st_exit_p_acc (m) + m_leafc_storage_to_litter_p (m) * deltim + AKX_frootc_st_exit_p_acc (m) = AKX_frootc_st_exit_p_acc (m) + m_frootc_storage_to_litter_p (m) * deltim + AKX_livestemc_st_exit_p_acc (m) = AKX_livestemc_st_exit_p_acc (m) + m_livestemc_storage_to_litter_p (m) * deltim + AKX_deadstemc_st_exit_p_acc (m) = AKX_deadstemc_st_exit_p_acc (m) + m_deadstemc_storage_to_litter_p (m) * deltim + AKX_livecrootc_st_exit_p_acc(m) = AKX_livecrootc_st_exit_p_acc(m) + m_livecrootc_storage_to_litter_p(m) * deltim + AKX_deadcrootc_st_exit_p_acc(m) = AKX_deadcrootc_st_exit_p_acc(m) + m_deadcrootc_storage_to_litter_p(m) * deltim + + AKX_leafc_xf_exit_p_acc (m) = AKX_leafc_xf_exit_p_acc (m) + m_leafc_xfer_to_litter_p (m) * deltim + AKX_frootc_xf_exit_p_acc (m) = AKX_frootc_xf_exit_p_acc (m) + m_frootc_xfer_to_litter_p (m) * deltim + AKX_livestemc_xf_exit_p_acc (m) = AKX_livestemc_xf_exit_p_acc (m) + m_livestemc_xfer_to_litter_p (m) * deltim + AKX_deadstemc_xf_exit_p_acc (m) = AKX_deadstemc_xf_exit_p_acc (m) + m_deadstemc_xfer_to_litter_p (m) * deltim + AKX_livecrootc_xf_exit_p_acc(m) = AKX_livecrootc_xf_exit_p_acc(m) + m_livecrootc_xfer_to_litter_p (m) * deltim + AKX_deadcrootc_xf_exit_p_acc(m) = AKX_deadcrootc_xf_exit_p_acc(m) + m_deadcrootc_xfer_to_litter_p (m) * deltim + ENDIF + ENDDO + + END SUBROUTINE CStateUpdate2 + +END MODULE MOD_BGC_CNCStateUpdate2 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate3.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate3.F90 new file mode 100644 index 0000000000..afb640fdd1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNCStateUpdate3.F90 @@ -0,0 +1,194 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNCStateUpdate3 + +!------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! First updates in vegetation and soil carbon. The major updates are included in bgc_CNCStateUpdate1Mod +! 1. Update fire-associated veg and soil(litter) C pool size changes +! 2. Record the accumulated C transfers associated to fire for semi-analytic spinup + +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record accumulated fire-associated C transfers for veg and soil C semi-analytic spinup + + USE MOD_Precision + USE MOD_BGC_Vars_TimeInvariants, only: & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition pools & fluxes variables (inout) + decomp_cpools_vr + + USE MOD_BGC_Vars_1DFluxes, only: & + m_decomp_cpools_to_fire_vr, & + fire_mortality_to_met_c, fire_mortality_to_cel_c, & + fire_mortality_to_lig_c, fire_mortality_to_cwdc + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation carbon state variables (inout) + leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p , livecrootc_storage_p, livecrootc_xfer_p, & + deadcrootc_p , deadcrootc_storage_p, deadcrootc_xfer_p, & + gresp_storage_p , gresp_xfer_p + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation carbon flux variables + m_leafc_to_fire_p , m_leafc_storage_to_fire_p , m_leafc_xfer_to_fire_p , & + m_frootc_to_fire_p , m_frootc_storage_to_fire_p , m_frootc_xfer_to_fire_p , & + m_livestemc_to_fire_p , m_livestemc_storage_to_fire_p , m_livestemc_xfer_to_fire_p , & + m_deadstemc_to_fire_p , m_deadstemc_storage_to_fire_p , m_deadstemc_xfer_to_fire_p , & + m_livecrootc_to_fire_p , m_livecrootc_storage_to_fire_p, m_livecrootc_xfer_to_fire_p, & + m_deadcrootc_to_fire_p , m_deadcrootc_storage_to_fire_p, m_deadcrootc_xfer_to_fire_p, & + m_livestemc_to_deadstemc_fire_p , m_livecrootc_to_deadcrootc_fire_p , & + m_gresp_storage_to_fire_p , m_gresp_xfer_to_fire_p , & + + m_leafc_to_litter_fire_p , m_leafc_storage_to_litter_fire_p , m_leafc_xfer_to_litter_fire_p , & + m_frootc_to_litter_fire_p , m_frootc_storage_to_litter_fire_p , m_frootc_xfer_to_litter_fire_p , & + m_livestemc_to_litter_fire_p , m_livestemc_storage_to_litter_fire_p , m_livestemc_xfer_to_litter_fire_p , & + m_deadstemc_to_litter_fire_p , m_deadstemc_storage_to_litter_fire_p , m_deadstemc_xfer_to_litter_fire_p , & + m_livecrootc_to_litter_fire_p , m_livecrootc_storage_to_litter_fire_p, m_livecrootc_xfer_to_litter_fire_p, & + m_deadcrootc_to_litter_fire_p , m_deadcrootc_storage_to_litter_fire_p, m_deadcrootc_xfer_to_litter_fire_p, & + m_gresp_storage_to_litter_fire_p, m_gresp_xfer_to_litter_fire_p + + IMPLICIT NONE + + PUBLIC CStateUpdate3 + +CONTAINS + + SUBROUTINE CStateUpdate3(i, ps, pe, deltim, nl_soil, ndecomp_pools) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil number + integer ,intent(in) :: ndecomp_pools ! number total litter & soil pools + + integer j,l,m + + DO j = 1, nl_soil + ! patch-level wood to column-level CWD (uncombusted wood) + decomp_cpools_vr(j,i_cwd,i) = decomp_cpools_vr(j,i_cwd,i) & + + fire_mortality_to_cwdc (j,i) * deltim + + ! patch-level wood to column-level litter (uncombusted wood) + decomp_cpools_vr(j,i_met_lit,i) = decomp_cpools_vr(j,i_met_lit,i) & + + fire_mortality_to_met_c(j,i) * deltim + decomp_cpools_vr(j,i_cel_lit,i) = decomp_cpools_vr(j,i_cel_lit,i) & + + fire_mortality_to_cel_c(j,i) * deltim + decomp_cpools_vr(j,i_lig_lit,i) = decomp_cpools_vr(j,i_lig_lit,i) & + + fire_mortality_to_lig_c(j,i) * deltim + ENDDO + + ! litter and CWD losses to fire + DO l = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_cpools_vr(j,l,i) = decomp_cpools_vr(j,l,i) & + - m_decomp_cpools_to_fire_vr(j,l,i) * deltim + ENDDO + ENDDO + + ! patch-level carbon fluxes from fire + DO m = ps , pe + gresp_storage_p (m) = gresp_storage_p (m) & + - m_gresp_storage_to_fire_p (m) * deltim + gresp_storage_p (m) = gresp_storage_p (m) & + - m_gresp_storage_to_litter_fire_p (m) * deltim + gresp_xfer_p (m) = gresp_xfer_p (m) & + - m_gresp_xfer_to_fire_p (m) * deltim + gresp_xfer_p (m) = gresp_xfer_p (m) & + - m_gresp_xfer_to_litter_fire_p (m) * deltim + ! displayed pools + leafc_p (m) = leafc_p (m) & + - m_leafc_to_fire_p (m) * deltim + leafc_p (m) = leafc_p (m) & + - m_leafc_to_litter_fire_p (m) * deltim + frootc_p (m) = frootc_p (m) & + - m_frootc_to_fire_p (m) * deltim + frootc_p (m) = frootc_p (m) & + - m_frootc_to_litter_fire_p (m) * deltim + livestemc_p (m) = livestemc_p (m) & + - m_livestemc_to_fire_p (m) * deltim + livestemc_p (m) = livestemc_p (m) & + - m_livestemc_to_litter_fire_p (m) * deltim & + - m_livestemc_to_deadstemc_fire_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) & + - m_deadstemc_to_fire_p (m) * deltim + deadstemc_p (m) = deadstemc_p (m) & + - m_deadstemc_to_litter_fire_p (m) * deltim & + + m_livestemc_to_deadstemc_fire_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) & + - m_livecrootc_to_fire_p (m) * deltim + livecrootc_p (m) = livecrootc_p (m) & + - m_livecrootc_to_litter_fire_p (m) * deltim & + - m_livecrootc_to_deadcrootc_fire_p (m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) & + - m_deadcrootc_to_fire_p (m) * deltim + deadcrootc_p (m) = deadcrootc_p (m) & + - m_deadcrootc_to_litter_fire_p (m) * deltim & + + m_livecrootc_to_deadcrootc_fire_p (m) * deltim + + ! storage pools + leafc_storage_p (m) = leafc_storage_p (m) & + - m_leafc_storage_to_fire_p (m) * deltim + leafc_storage_p (m) = leafc_storage_p (m) & + - m_leafc_storage_to_litter_fire_p (m) * deltim + frootc_storage_p (m) = frootc_storage_p (m) & + - m_frootc_storage_to_fire_p (m) * deltim + frootc_storage_p (m) = frootc_storage_p (m) & + - m_frootc_storage_to_litter_fire_p (m) * deltim + livestemc_storage_p (m) = livestemc_storage_p (m) & + - m_livestemc_storage_to_fire_p (m) * deltim + livestemc_storage_p (m) = livestemc_storage_p (m) & + - m_livestemc_storage_to_litter_fire_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) & + - m_deadstemc_storage_to_fire_p (m) * deltim + deadstemc_storage_p (m) = deadstemc_storage_p (m) & + - m_deadstemc_storage_to_litter_fire_p (m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) & + - m_livecrootc_storage_to_fire_p (m) * deltim + livecrootc_storage_p(m) = livecrootc_storage_p(m) & + - m_livecrootc_storage_to_litter_fire_p(m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) & + - m_deadcrootc_storage_to_fire_p (m) * deltim + deadcrootc_storage_p(m) = deadcrootc_storage_p(m) & + - m_deadcrootc_storage_to_litter_fire_p(m) * deltim + + ! transfer pools + leafc_xfer_p (m) = leafc_xfer_p (m) & + - m_leafc_xfer_to_fire_p (m) * deltim + leafc_xfer_p (m) = leafc_xfer_p (m) & + - m_leafc_xfer_to_litter_fire_p (m) * deltim + frootc_xfer_p (m) = frootc_xfer_p (m) & + - m_frootc_xfer_to_fire_p (m) * deltim + frootc_xfer_p (m) = frootc_xfer_p (m) & + - m_frootc_xfer_to_litter_fire_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) & + - m_livestemc_xfer_to_fire_p (m) * deltim + livestemc_xfer_p (m) = livestemc_xfer_p (m) & + - m_livestemc_xfer_to_litter_fire_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) & + - m_deadstemc_xfer_to_fire_p (m) * deltim + deadstemc_xfer_p (m) = deadstemc_xfer_p (m) & + - m_deadstemc_xfer_to_litter_fire_p (m) * deltim + livecrootc_xfer_p (m) = livecrootc_xfer_p (m) & + - m_livecrootc_xfer_to_fire_p (m) * deltim + livecrootc_xfer_p (m) = livecrootc_xfer_p (m) & + - m_livecrootc_xfer_to_litter_fire_p (m) * deltim + deadcrootc_xfer_p (m) = deadcrootc_xfer_p (m) & + - m_deadcrootc_xfer_to_fire_p (m) * deltim + deadcrootc_xfer_p (m) = deadcrootc_xfer_p (m) & + - m_deadcrootc_xfer_to_litter_fire_p (m) * deltim + ENDDO + + END SUBROUTINE CStateUpdate3 + +END MODULE MOD_BGC_CNCStateUpdate3 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate1.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate1.F90 new file mode 100644 index 0000000000..d0678b2a5b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate1.F90 @@ -0,0 +1,410 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNNStateUpdate1 + +!------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! First updates in vegetation and soil nitrogen. The major updates are included in bgc_CNNStateUpdate1Mod +! 1. Update phenology-associated veg and soil N pool size changes, including plant growth +! 2. Update decomposition-associated soil N pool size changes +! 3. Record the accumulated N transfers associated to phenology and decomposition for semi-analytic spinup +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record the accumulated phenology-associated N transfer for veg and soil N semi-analytic spinup +! 3) Record the accumulated decomposition-associated N transfer for soil N semi-analytic spinup + + USE MOD_Precision + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_Const_PFT, only: woody + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_BGC_Vars_TimeInvariants, only: & + ! bgc constants + donor_pool, receiver_pool, i_met_lit, i_cel_lit, i_lig_lit, i_cwd, i_soil1, i_soil2, i_soil3 + + USE MOD_BGC_Vars_TimeVariables, only: & + I_met_n_vr_acc, I_cel_n_vr_acc, I_lig_n_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition pools flux varables (in) + decomp_npools_sourcesink, & + phenology_to_met_n , phenology_to_cel_n, phenology_to_lig_n + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation nitrogen state variables (inout) + leafn_p , leafn_storage_p , leafn_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p , livecrootn_storage_p, livecrootn_xfer_p, & + deadcrootn_p , deadcrootn_storage_p, deadcrootn_xfer_p, & + grainn_p , grainn_storage_p , grainn_xfer_p , & + cropseedn_deficit_p, retransn_p , npool_p , & + + ! SASU variables + I_leafn_p_acc , I_leafn_st_p_acc , I_frootn_p_acc , I_frootn_st_p_acc , & + I_livestemn_p_acc , I_livestemn_st_p_acc , I_deadstemn_p_acc , I_deadstemn_st_p_acc , & + I_livecrootn_p_acc, I_livecrootn_st_p_acc, I_deadcrootn_p_acc, I_deadcrootn_st_p_acc, & + I_grainn_p_acc , I_grainn_st_p_acc , & + + AKX_leafn_xf_to_leafn_p_acc , AKX_frootn_xf_to_frootn_p_acc , AKX_livestemn_xf_to_livestemn_p_acc , & + AKX_deadstemn_xf_to_deadstemn_p_acc , AKX_livecrootn_xf_to_livecrootn_p_acc , AKX_deadcrootn_xf_to_deadcrootn_p_acc , & + AKX_grainn_xf_to_grainn_p_acc , AKX_livestemn_to_deadstemn_p_acc , AKX_livecrootn_to_deadcrootn_p_acc , & + + AKX_leafn_st_to_leafn_xf_p_acc , AKX_frootn_st_to_frootn_xf_p_acc , AKX_livestemn_st_to_livestemn_xf_p_acc , & + AKX_deadstemn_st_to_deadstemn_xf_p_acc, AKX_livecrootn_st_to_livecrootn_xf_p_acc, AKX_deadcrootn_st_to_deadcrootn_xf_p_acc, & + AKX_livestemn_st_to_livestemn_xf_p_acc, AKX_grainn_st_to_grainn_xf_p_acc , & + + AKX_leafn_to_retransn_p_acc , AKX_frootn_to_retransn_p_acc , AKX_livestemn_to_retransn_p_acc , & + AKX_livecrootn_to_retransn_p_acc , & + + AKX_retransn_to_leafn_p_acc , AKX_retransn_to_frootn_p_acc , AKX_retransn_to_livestemn_p_acc , & + AKX_retransn_to_deadstemn_p_acc , AKX_retransn_to_livecrootn_p_acc , AKX_retransn_to_deadcrootn_p_acc , & + AKX_retransn_to_grainn_p_acc , & + + AKX_retransn_to_leafn_st_p_acc , AKX_retransn_to_frootn_st_p_acc , AKX_retransn_to_livestemn_st_p_acc , & + AKX_retransn_to_deadstemn_st_p_acc , AKX_retransn_to_livecrootn_st_p_acc , AKX_retransn_to_deadcrootn_st_p_acc , & + AKX_retransn_to_grainn_st_p_acc , & + + AKX_leafn_exit_p_acc , AKX_frootn_exit_p_acc , AKX_livestemn_exit_p_acc , & + AKX_deadstemn_exit_p_acc , AKX_livecrootn_exit_p_acc , AKX_deadcrootn_exit_p_acc , & + AKX_grainn_exit_p_acc , AKX_retransn_exit_p_acc , & + + AKX_leafn_st_exit_p_acc , AKX_frootn_st_exit_p_acc , AKX_livestemn_st_exit_p_acc , & + AKX_deadstemn_st_exit_p_acc , AKX_livecrootn_st_exit_p_acc , AKX_deadcrootn_st_exit_p_acc , & + AKX_grainn_st_exit_p_acc , & + + AKX_leafn_xf_exit_p_acc , AKX_frootn_xf_exit_p_acc , AKX_livestemn_xf_exit_p_acc , & + AKX_deadstemn_xf_exit_p_acc , AKX_livecrootn_xf_exit_p_acc , AKX_deadcrootn_xf_exit_p_acc , & + AKX_grainn_xf_exit_p_acc + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation nitrogen flux variables (in) + ! xfer to display + leafn_xfer_to_leafn_p , frootn_xfer_to_frootn_p , & + livestemn_xfer_to_livestemn_p , deadstemn_xfer_to_deadstemn_p , & + livecrootn_xfer_to_livecrootn_p, deadcrootn_xfer_to_deadcrootn_p, & + grainn_xfer_to_grainn_p , & + + ! storage to xfer (in) + leafn_storage_to_xfer_p , frootn_storage_to_xfer_p , & + livestemn_storage_to_xfer_p , deadstemn_storage_to_xfer_p , & + livecrootn_storage_to_xfer_p, deadcrootn_storage_to_xfer_p, & + grainn_storage_to_xfer_p , & + + ! display to litter & live to dead (in) + leafn_to_litter_p , frootn_to_litter_p , & + grainn_to_food_p , grainn_to_seed_p , & + crop_seedn_to_leaf_p , livestemn_to_litter_p , & + livestemn_to_deadstemn_p, livecrootn_to_deadcrootn_p, & + + ! display to retransn / retransn to npool (in) + leafn_to_retransn_p , frootn_to_retransn_p , & + livestemn_to_retransn_p , livecrootn_to_retransn_p , & + retransn_to_npool_p , free_retransn_to_npool_p , & + + ! npool to display/storage (in) + npool_to_leafn_p , npool_to_leafn_storage_p , & + npool_to_frootn_p , npool_to_frootn_storage_p , & + npool_to_livestemn_p , npool_to_livestemn_storage_p , & + npool_to_deadstemn_p , npool_to_deadstemn_storage_p , & + npool_to_livecrootn_p, npool_to_livecrootn_storage_p, & + npool_to_deadcrootn_p, npool_to_deadcrootn_storage_p, & + npool_to_grainn_p , npool_to_grainn_storage_p , plant_nalloc_p + + USE MOD_Vars_PFTimeInvariants, only: pftfrac + IMPLICIT NONE + + PUBLIC NStateUpdate1 + +CONTAINS + + SUBROUTINE NStateUpdate1 (i, ps, pe, deltim, nl_soil, ndecomp_transitions, npcropmin,dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_transitions ! number of total transitions among different litter & soil bgc pools + integer ,intent(in) :: npcropmin ! index of first crop pft + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer + + integer j,k + integer ivt, m + real(r8) f_retr_in_nall + + ! soilbiogeochemistry fluxes TODO - this should be moved elsewhere + ! plant to litter fluxes - phenology and dynamic landcover fluxes + DO j = 1, nl_soil + decomp_npools_sourcesink(j,i_met_lit,i) = phenology_to_met_n(j,i) * deltim + + decomp_npools_sourcesink(j,i_cel_lit,i) = phenology_to_cel_n(j,i) * deltim + + decomp_npools_sourcesink(j,i_lig_lit,i) = phenology_to_lig_n(j,i) * deltim + + decomp_npools_sourcesink(j,i_cwd,i) = 0._r8 + + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j=1,nl_soil + I_met_n_vr_acc(j,i) = I_met_n_vr_acc(j,i) + phenology_to_met_n(j,i) * deltim + I_cel_n_vr_acc(j,i) = I_cel_n_vr_acc(j,i) + phenology_to_cel_n(j,i) * deltim + I_lig_n_vr_acc(j,i) = I_lig_n_vr_acc(j,i) + phenology_to_lig_n(j,i) * deltim + ENDDO + ENDIF + + DO m = ps , pe + ivt = pftclass(m) + ! phenology: transfer growth fluxes + leafn_p(m) = leafn_p(m) + leafn_xfer_to_leafn_p(m)*deltim + leafn_xfer_p(m) = leafn_xfer_p(m) - leafn_xfer_to_leafn_p(m)*deltim + frootn_p(m) = frootn_p(m) + frootn_xfer_to_frootn_p(m)*deltim + frootn_xfer_p(m) = frootn_xfer_p(m) - frootn_xfer_to_frootn_p(m)*deltim + + IF (woody(ivt) == 1) THEN + livestemn_p(m) = livestemn_p(m) + livestemn_xfer_to_livestemn_p(m)*deltim + livestemn_xfer_p(m) = livestemn_xfer_p(m) - livestemn_xfer_to_livestemn_p(m)*deltim + deadstemn_p(m) = deadstemn_p(m) + deadstemn_xfer_to_deadstemn_p(m)*deltim + deadstemn_xfer_p(m) = deadstemn_xfer_p(m) - deadstemn_xfer_to_deadstemn_p(m)*deltim + livecrootn_p(m) = livecrootn_p(m) + livecrootn_xfer_to_livecrootn_p(m)*deltim + livecrootn_xfer_p(m) = livecrootn_xfer_p(m) - livecrootn_xfer_to_livecrootn_p(m)*deltim + deadcrootn_p(m) = deadcrootn_p(m) + deadcrootn_xfer_to_deadcrootn_p(m)*deltim + deadcrootn_xfer_p(m) = deadcrootn_xfer_p(m) - deadcrootn_xfer_to_deadcrootn_p(m)*deltim + ENDIF + + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + livestemn_p(m) = livestemn_p(m) + livestemn_xfer_to_livestemn_p(m)*deltim + livestemn_xfer_p(m) = livestemn_xfer_p(m) - livestemn_xfer_to_livestemn_p(m)*deltim + grainn_p(m) = grainn_p(m) + grainn_xfer_to_grainn_p(m)*deltim + grainn_xfer_p(m) = grainn_xfer_p(m) - grainn_xfer_to_grainn_p(m)*deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafn_xf_to_leafn_p_acc (m) = AKX_leafn_xf_to_leafn_p_acc (m) + leafn_xfer_to_leafn_p (m) * deltim + AKX_frootn_xf_to_frootn_p_acc(m) = AKX_frootn_xf_to_frootn_p_acc(m) + frootn_xfer_to_frootn_p(m) * deltim + AKX_leafn_xf_exit_p_acc (m) = AKX_leafn_xf_exit_p_acc (m) + leafn_xfer_to_leafn_p (m) * deltim + AKX_frootn_xf_exit_p_acc (m) = AKX_frootn_xf_exit_p_acc (m) + frootn_xfer_to_frootn_p(m) * deltim + IF(woody(ivt) == 1)THEN + AKX_livestemn_xf_to_livestemn_p_acc (m) = AKX_livestemn_xf_to_livestemn_p_acc (m) + livestemn_xfer_to_livestemn_p (m) * deltim + AKX_livestemn_xf_exit_p_acc (m) = AKX_livestemn_xf_exit_p_acc (m) + livestemn_xfer_to_livestemn_p (m) * deltim + AKX_deadstemn_xf_to_deadstemn_p_acc (m) = AKX_deadstemn_xf_to_deadstemn_p_acc (m) + deadstemn_xfer_to_deadstemn_p (m) * deltim + AKX_deadstemn_xf_exit_p_acc (m) = AKX_deadstemn_xf_exit_p_acc (m) + deadstemn_xfer_to_deadstemn_p (m) * deltim + AKX_livecrootn_xf_to_livecrootn_p_acc(m) = AKX_livecrootn_xf_to_livecrootn_p_acc(m) + livecrootn_xfer_to_livecrootn_p(m) * deltim + AKX_livecrootn_xf_exit_p_acc (m) = AKX_livecrootn_xf_exit_p_acc (m) + livecrootn_xfer_to_livecrootn_p(m) * deltim + AKX_deadcrootn_xf_to_deadcrootn_p_acc(m) = AKX_deadcrootn_xf_to_deadcrootn_p_acc(m) + deadcrootn_xfer_to_deadcrootn_p(m) * deltim + AKX_deadcrootn_xf_exit_p_acc (m) = AKX_deadcrootn_xf_exit_p_acc (m) + deadcrootn_xfer_to_deadcrootn_p(m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + AKX_livestemn_xf_to_livestemn_p_acc(m) = AKX_livestemn_xf_to_livestemn_p_acc(m) + livestemn_xfer_to_livestemn_p(m) * deltim + AKX_livestemn_xf_exit_p_acc (m) = AKX_livestemn_xf_exit_p_acc (m) + livestemn_xfer_to_livestemn_p(m) * deltim + AKX_grainn_xf_to_grainn_p_acc (m) = AKX_grainn_xf_to_grainn_p_acc (m) + grainn_xfer_to_grainn_p (m) * deltim + AKX_grainn_xf_exit_p_acc (m) = AKX_grainn_xf_exit_p_acc (m) + grainn_xfer_to_grainn_p (m) * deltim + ENDIF + ENDIF + + ! phenology: litterfall and retranslocation fluxes + leafn_p(m) = leafn_p(m) - leafn_to_litter_p(m)*deltim + frootn_p(m) = frootn_p(m) - frootn_to_litter_p(m)*deltim + leafn_p(m) = leafn_p(m) - leafn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + leafn_to_retransn_p(m)*deltim + + ! live wood turnover and retranslocation fluxes + IF (woody(ivt) == 1) THEN + livestemn_p(m) = livestemn_p(m) - livestemn_to_deadstemn_p(m)*deltim + deadstemn_p(m) = deadstemn_p(m) + livestemn_to_deadstemn_p(m)*deltim + livecrootn_p(m) = livecrootn_p(m) - livecrootn_to_deadcrootn_p(m)*deltim + deadcrootn_p(m) = deadcrootn_p(m) + livecrootn_to_deadcrootn_p(m)*deltim + + livestemn_p(m) = livestemn_p(m) - livestemn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + livestemn_to_retransn_p(m)*deltim + livecrootn_p(m) = livecrootn_p(m) - livecrootn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + livecrootn_to_retransn_p(m)*deltim + ENDIF + IF (ivt >= npcropmin) THEN + frootn_p(m) = frootn_p(m) - frootn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + frootn_to_retransn_p(m)*deltim + livestemn_p(m) = livestemn_p(m) - livestemn_to_litter_p(m)*deltim + livestemn_p(m) = livestemn_p(m) - livestemn_to_retransn_p(m)*deltim + retransn_p(m) = retransn_p(m) + livestemn_to_retransn_p(m)*deltim + grainn_p(m) = grainn_p(m) & + - (grainn_to_food_p(m) + grainn_to_seed_p(m))*deltim + cropseedn_deficit_p(m) = cropseedn_deficit_p(m) & + - crop_seedn_to_leaf_p(m) * deltim & + + grainn_to_seed_p(m) * deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafn_exit_p_acc (m) = AKX_leafn_exit_p_acc (m) + leafn_to_litter_p (m) * deltim + AKX_frootn_exit_p_acc (m) = AKX_frootn_exit_p_acc (m) + frootn_to_litter_p (m) * deltim + AKX_leafn_to_retransn_p_acc(m) = AKX_leafn_to_retransn_p_acc(m) + leafn_to_retransn_p(m) * deltim + AKX_leafn_exit_p_acc (m) = AKX_leafn_exit_p_acc (m) + leafn_to_retransn_p(m) * deltim + IF(woody(ivt) == 1) THEN + AKX_livestemn_to_deadstemn_p_acc (m) = AKX_livestemn_to_deadstemn_p_acc (m) + livestemn_to_deadstemn_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + livestemn_to_deadstemn_p (m) * deltim + AKX_livecrootn_to_deadcrootn_p_acc(m) = AKX_livecrootn_to_deadcrootn_p_acc(m) + livecrootn_to_deadcrootn_p(m) * deltim + AKX_livecrootn_exit_p_acc (m) = AKX_livecrootn_exit_p_acc (m) + livecrootn_to_deadcrootn_p(m) * deltim + + AKX_livestemn_to_retransn_p_acc (m) = AKX_livestemn_to_retransn_p_acc (m) + livestemn_to_retransn_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + livestemn_to_retransn_p (m) * deltim + AKX_livecrootn_to_retransn_p_acc (m) = AKX_livecrootn_to_retransn_p_acc (m) + livecrootn_to_retransn_p (m) * deltim + AKX_livecrootn_exit_p_acc (m) = AKX_livecrootn_exit_p_acc (m) + livecrootn_to_retransn_p (m) * deltim + ENDIF + IF(ivt >= npcropmin) THEN + AKX_frootn_to_retransn_p_acc (m) = AKX_frootn_to_retransn_p_acc (m) + frootn_to_retransn_p (m) * deltim + AKX_frootn_exit_p_acc (m) = AKX_frootn_exit_p_acc (m) + frootn_to_retransn_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + livestemn_to_litter_p (m) * deltim + AKX_livestemn_to_retransn_p_acc (m) = AKX_livestemn_to_retransn_p_acc (m) + livestemn_to_retransn_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + livestemn_to_retransn_p (m) * deltim + AKX_grainn_exit_p_acc (m) = AKX_grainn_exit_p_acc (m) + (grainn_to_food_p(m) + grainn_to_seed_p(m)) * deltim + ENDIF + ENDIF + + ! allocation fluxes + retransn_p(m) = retransn_p(m) - retransn_to_npool_p(m)*deltim + retransn_p(m) = retransn_p(m) - free_retransn_to_npool_p(m)*deltim + leafn_p(m) = leafn_p(m) + npool_to_leafn_p(m)*deltim + leafn_storage_p(m) = leafn_storage_p(m) + npool_to_leafn_storage_p(m)*deltim + frootn_p(m) = frootn_p(m) + npool_to_frootn_p(m)*deltim + frootn_storage_p(m) = frootn_storage_p(m) + npool_to_frootn_storage_p(m)*deltim + + IF (woody(ivt) == 1) THEN + livestemn_p(m) = livestemn_p(m) + npool_to_livestemn_p(m)*deltim + livestemn_storage_p(m) = livestemn_storage_p(m) + npool_to_livestemn_storage_p(m)*deltim + deadstemn_p(m) = deadstemn_p(m) + npool_to_deadstemn_p(m)*deltim + deadstemn_storage_p(m) = deadstemn_storage_p(m) + npool_to_deadstemn_storage_p(m)*deltim + livecrootn_p(m) = livecrootn_p(m) + npool_to_livecrootn_p(m)*deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) + npool_to_livecrootn_storage_p(m)*deltim + deadcrootn_p(m) = deadcrootn_p(m) + npool_to_deadcrootn_p(m)*deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) + npool_to_deadcrootn_storage_p(m)*deltim + ENDIF + + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + livestemn_p(m) = livestemn_p(m) + npool_to_livestemn_p(m)*deltim + livestemn_storage_p(m) = livestemn_storage_p(m) + npool_to_livestemn_storage_p(m)*deltim + grainn_p(m) = grainn_p(m) + npool_to_grainn_p(m)*deltim + grainn_storage_p(m) = grainn_storage_p(m) + npool_to_grainn_storage_p(m)*deltim + ENDIF + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + IF(plant_nalloc_p(m) .ne. 0)THEN + f_retr_in_nall = retransn_to_npool_p(m) / plant_nalloc_p(m) + AKX_retransn_exit_p_acc (m) = AKX_retransn_exit_p_acc (m) & + + (retransn_to_npool_p (m) + free_retransn_to_npool_p (m)) * deltim + I_leafn_p_acc (m) = I_leafn_p_acc (m) + npool_to_leafn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_leafn_p_acc (m) = AKX_retransn_to_leafn_p_acc (m) + npool_to_leafn_p (m) * f_retr_in_nall * deltim + I_leafn_st_p_acc (m) = I_leafn_st_p_acc (m) + npool_to_leafn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_leafn_st_p_acc (m) = AKX_retransn_to_leafn_st_p_acc (m) + npool_to_leafn_storage_p (m) * f_retr_in_nall * deltim + I_frootn_p_acc (m) = I_frootn_p_acc (m) + npool_to_frootn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_frootn_p_acc (m) = AKX_retransn_to_frootn_p_acc (m) + npool_to_frootn_p (m) * f_retr_in_nall * deltim + I_frootn_st_p_acc (m) = I_frootn_st_p_acc (m) + npool_to_frootn_storage_p(m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_frootn_st_p_acc(m) = AKX_retransn_to_frootn_st_p_acc(m) + npool_to_frootn_storage_p(m) * f_retr_in_nall * deltim + IF(woody(ivt) == 1)THEN + I_livestemn_p_acc (m) = I_livestemn_p_acc (m) & + + npool_to_livestemn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livestemn_p_acc (m) = AKX_retransn_to_livestemn_p_acc (m) & + + npool_to_livestemn_p (m) * f_retr_in_nall * deltim + I_livestemn_st_p_acc (m) = I_livestemn_st_p_acc (m) & + + npool_to_livestemn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livestemn_st_p_acc (m) = AKX_retransn_to_livestemn_st_p_acc (m) & + + npool_to_livestemn_storage_p (m) * f_retr_in_nall * deltim + I_deadstemn_p_acc (m) = I_deadstemn_p_acc (m) & + + npool_to_deadstemn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_deadstemn_p_acc (m) = AKX_retransn_to_deadstemn_p_acc (m) & + + npool_to_deadstemn_p (m) * f_retr_in_nall * deltim + I_deadstemn_st_p_acc (m) = I_deadstemn_st_p_acc (m) & + + npool_to_deadstemn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_deadstemn_st_p_acc (m) = AKX_retransn_to_deadstemn_st_p_acc (m) & + + npool_to_deadstemn_storage_p (m) * f_retr_in_nall * deltim + I_livecrootn_p_acc (m) = I_livecrootn_p_acc (m) & + + npool_to_livecrootn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livecrootn_p_acc (m) = AKX_retransn_to_livecrootn_p_acc (m) & + + npool_to_livecrootn_p (m) * f_retr_in_nall * deltim + I_livecrootn_st_p_acc (m) = I_livecrootn_st_p_acc (m) & + + npool_to_livecrootn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livecrootn_st_p_acc(m) = AKX_retransn_to_livecrootn_st_p_acc(m) & + + npool_to_livecrootn_storage_p (m) * f_retr_in_nall * deltim + I_deadcrootn_p_acc (m) = I_deadcrootn_p_acc (m) & + + npool_to_deadcrootn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_deadcrootn_p_acc (m) = AKX_retransn_to_deadcrootn_p_acc (m) & + + npool_to_deadcrootn_p (m) * f_retr_in_nall * deltim + I_deadcrootn_st_p_acc (m) = I_deadcrootn_st_p_acc (m) & + + npool_to_deadcrootn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_deadcrootn_st_p_acc(m) = AKX_retransn_to_deadcrootn_st_p_acc(m) & + + npool_to_deadcrootn_storage_p (m) * f_retr_in_nall * deltim + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + I_livestemn_p_acc (m) = I_livestemn_p_acc (m) & + + npool_to_livestemn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livestemn_p_acc (m) = AKX_retransn_to_livestemn_p_acc(m) & + + npool_to_livestemn_p (m) * f_retr_in_nall * deltim + I_livestemn_st_p_acc (m) = I_livestemn_st_p_acc (m) & + + npool_to_livestemn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_livestemn_st_p_acc (m) = AKX_retransn_to_livestemn_st_p_acc(m) & + + npool_to_livestemn_storage_p (m) * f_retr_in_nall * deltim + I_grainn_p_acc (m) = I_grainn_p_acc (m) & + + npool_to_grainn_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_grainn_p_acc (m) = AKX_retransn_to_grainn_p_acc (m) & + + npool_to_grainn_p (m) * f_retr_in_nall * deltim + I_grainn_st_p_acc (m) = I_grainn_st_p_acc (m) & + + npool_to_grainn_storage_p (m) * (1._r8 - f_retr_in_nall) * deltim + AKX_retransn_to_grainn_st_p_acc (m) = AKX_retransn_to_grainn_st_p_acc(m) & + + npool_to_grainn_storage_p (m) * f_retr_in_nall * deltim + ENDIF + ENDIF + ENDIF + ! move storage pools into transfer pools + leafn_storage_p(m) = leafn_storage_p(m) - leafn_storage_to_xfer_p(m)*deltim + leafn_xfer_p(m) = leafn_xfer_p(m) + leafn_storage_to_xfer_p(m)*deltim + frootn_storage_p(m) = frootn_storage_p(m) - frootn_storage_to_xfer_p(m)*deltim + frootn_xfer_p(m) = frootn_xfer_p(m) + frootn_storage_to_xfer_p(m)*deltim + + IF (woody(ivt) == 1) THEN + livestemn_storage_p(m) = livestemn_storage_p(m) - livestemn_storage_to_xfer_p(m)*deltim + livestemn_xfer_p(m) = livestemn_xfer_p(m) + livestemn_storage_to_xfer_p(m)*deltim + deadstemn_storage_p(m) = deadstemn_storage_p(m) - deadstemn_storage_to_xfer_p(m)*deltim + deadstemn_xfer_p(m) = deadstemn_xfer_p(m) + deadstemn_storage_to_xfer_p(m)*deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) - livecrootn_storage_to_xfer_p(m)*deltim + livecrootn_xfer_p(m) = livecrootn_xfer_p(m) + livecrootn_storage_to_xfer_p(m)*deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) - deadcrootn_storage_to_xfer_p(m)*deltim + deadcrootn_xfer_p(m) = deadcrootn_xfer_p(m) + deadcrootn_storage_to_xfer_p(m)*deltim + ENDIF + + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + ! lines here for consistency; the transfer terms are zero + livestemn_storage_p(m) = livestemn_storage_p(m) - livestemn_storage_to_xfer_p(m)*deltim + livestemn_xfer_p(m) = livestemn_xfer_p(m) + livestemn_storage_to_xfer_p(m)*deltim + grainn_storage_p(m) = grainn_storage_p(m) - grainn_storage_to_xfer_p(m)*deltim + grainn_xfer_p(m) = grainn_xfer_p(m) + grainn_storage_to_xfer_p(m)*deltim + ENDIF + + IF(DEF_USE_SASU)THEN + AKX_leafn_st_to_leafn_xf_p_acc (m) = AKX_leafn_st_to_leafn_xf_p_acc (m) + leafn_storage_to_xfer_p (m) * deltim + AKX_leafn_st_exit_p_acc (m) = AKX_leafn_st_exit_p_acc (m) + leafn_storage_to_xfer_p (m) * deltim + AKX_frootn_st_to_frootn_xf_p_acc (m) = AKX_frootn_st_to_frootn_xf_p_acc (m) + frootn_storage_to_xfer_p (m) * deltim + AKX_frootn_st_exit_p_acc (m) = AKX_frootn_st_exit_p_acc (m) + frootn_storage_to_xfer_p (m) * deltim + IF(woody(ivt) == 1) THEN + AKX_livestemn_st_to_livestemn_xf_p_acc (m) = AKX_livestemn_st_to_livestemn_xf_p_acc (m) + livestemn_storage_to_xfer_p (m) * deltim + AKX_livestemn_st_exit_p_acc (m) = AKX_livestemn_st_exit_p_acc (m) + livestemn_storage_to_xfer_p (m) * deltim + AKX_deadstemn_st_to_deadstemn_xf_p_acc (m) = AKX_deadstemn_st_to_deadstemn_xf_p_acc (m) + deadstemn_storage_to_xfer_p (m) * deltim + AKX_deadstemn_st_exit_p_acc (m) = AKX_deadstemn_st_exit_p_acc (m) + deadstemn_storage_to_xfer_p (m) * deltim + AKX_livecrootn_st_to_livecrootn_xf_p_acc(m) = AKX_livecrootn_st_to_livecrootn_xf_p_acc(m) + livecrootn_storage_to_xfer_p(m) * deltim + AKX_livecrootn_st_exit_p_acc (m) = AKX_livecrootn_st_exit_p_acc (m) + livecrootn_storage_to_xfer_p(m) * deltim + AKX_deadcrootn_st_to_deadcrootn_xf_p_acc(m) = AKX_deadcrootn_st_to_deadcrootn_xf_p_acc(m) + deadcrootn_storage_to_xfer_p(m) * deltim + AKX_deadcrootn_st_exit_p_acc (m) = AKX_deadcrootn_st_exit_p_acc (m) + deadcrootn_storage_to_xfer_p(m) * deltim + ENDIF + IF( ivt >= npcropmin) THEN + AKX_livestemn_st_to_livestemn_xf_p_acc (m) = AKX_livestemn_st_to_livestemn_xf_p_acc (m) + livestemn_storage_to_xfer_p (m) * deltim + AKX_livestemn_st_exit_p_acc (m) = AKX_livestemn_st_exit_p_acc (m) + livestemn_storage_to_xfer_p (m) * deltim + AKX_grainn_st_to_grainn_xf_p_acc (m) = AKX_grainn_st_to_grainn_xf_p_acc (m) + grainn_storage_to_xfer_p (m) * deltim + AKX_grainn_st_exit_p_acc (m) = AKX_grainn_st_exit_p_acc (m) + grainn_storage_to_xfer_p (m) * deltim + ENDIF + ENDIF + ENDDO ! END pft loop + + END SUBROUTINE NStateUpdate1 + +END MODULE MOD_BGC_CNNStateUpdate1 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate2.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate2.F90 new file mode 100644 index 0000000000..d44a47e063 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate2.F90 @@ -0,0 +1,172 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNNStateUpdate2 + +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! First updates in vegetation and soil nitrogen. The major updates are included in bgc_CNNStateUpdate1Mod +! 1. Update gap-mortality-associated veg and soil N pool size changes +! 2. Record the accumulated N transfers associated to gap-mortality for semi-analytic spinup + +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record the accumulated gap-mortality-associated N transfers for veg and soil N semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_BGC_Vars_TimeInvariants, only: & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd, i_soil1, i_soil2,i_soil3 + USE MOD_BGC_Vars_TimeVariables, only: & + ! decompositionn nitrogen pools & fluxes variables (inout) + decomp_npools_vr, & + I_met_n_vr_acc , I_cel_n_vr_acc , I_lig_n_vr_acc , I_cwd_n_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & + gap_mortality_to_met_n, gap_mortality_to_cel_n , & + gap_mortality_to_lig_n, gap_mortality_to_cwdn + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation nitrogen state variables (inout) + leafn_p , leafn_storage_p , leafn_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p , livecrootn_storage_p, livecrootn_xfer_p, & + deadcrootn_p , deadcrootn_storage_p, deadcrootn_xfer_p, & + retransn_p , npool_p, grainn_p, grainn_storage_p, grainn_xfer_p, cropseedn_deficit_p, & + + ! SASU variables + AKX_leafn_exit_p_acc , AKX_leafn_st_exit_p_acc , AKX_leafn_xf_exit_p_acc , & + AKX_frootn_exit_p_acc , AKX_frootn_st_exit_p_acc , AKX_frootn_xf_exit_p_acc , & + AKX_livestemn_exit_p_acc , AKX_livestemn_st_exit_p_acc , AKX_livestemn_xf_exit_p_acc , & + AKX_deadstemn_exit_p_acc , AKX_deadstemn_st_exit_p_acc , AKX_deadstemn_xf_exit_p_acc , & + AKX_livecrootn_exit_p_acc, AKX_livecrootn_st_exit_p_acc, AKX_livecrootn_xf_exit_p_acc, & + AKX_deadcrootn_exit_p_acc, AKX_deadcrootn_st_exit_p_acc, AKX_deadcrootn_xf_exit_p_acc, & + AKX_retransn_exit_p_acc + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation nitrogen flux variables + m_leafn_to_litter_p , m_leafn_storage_to_litter_p , m_leafn_xfer_to_litter_p , & + m_frootn_to_litter_p , m_frootn_storage_to_litter_p , m_frootn_xfer_to_litter_p , & + m_livestemn_to_litter_p , m_livestemn_storage_to_litter_p , m_livestemn_xfer_to_litter_p , & + m_deadstemn_to_litter_p , m_deadstemn_storage_to_litter_p , m_deadstemn_xfer_to_litter_p , & + m_livecrootn_to_litter_p , m_livecrootn_storage_to_litter_p, m_livecrootn_xfer_to_litter_p, & + m_deadcrootn_to_litter_p , m_deadcrootn_storage_to_litter_p, m_deadcrootn_xfer_to_litter_p, & + m_retransn_to_litter_p + + USE MOD_Vars_PFTimeInvariants, only: pftfrac + IMPLICIT NONE + + PUBLIC NStateUpdate2 + +CONTAINS + + SUBROUTINE NStateUpdate2(i, ps, pe, deltim, nl_soil, dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer + + integer j, m + + ! column-level nitrogen fluxes from gap-phase mortality + DO j = 1, nl_soil + decomp_npools_vr(j,i_met_lit,i) = & + decomp_npools_vr(j,i_met_lit,i) + gap_mortality_to_met_n(j,i) * deltim + decomp_npools_vr(j,i_cel_lit,i) = & + decomp_npools_vr(j,i_cel_lit,i) + gap_mortality_to_cel_n(j,i) * deltim + decomp_npools_vr(j,i_lig_lit,i) = & + decomp_npools_vr(j,i_lig_lit,i) + gap_mortality_to_lig_n(j,i) * deltim + decomp_npools_vr(j,i_cwd,i) = & + decomp_npools_vr(j,i_cwd,i) + gap_mortality_to_cwdn(j,i) * deltim + ENDDO + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j=1,nl_soil + I_met_n_vr_acc(j,i) = I_met_n_vr_acc(j,i) + gap_mortality_to_met_n(j,i) * deltim + I_cel_n_vr_acc(j,i) = I_cel_n_vr_acc(j,i) + gap_mortality_to_cel_n(j,i) * deltim + I_lig_n_vr_acc(j,i) = I_lig_n_vr_acc(j,i) + gap_mortality_to_lig_n(j,i) * deltim + I_cwd_n_vr_acc(j,i) = I_cwd_n_vr_acc(j,i) + gap_mortality_to_cwdn (j,i) * deltim + ENDDO + ENDIF + ! patch -level nitrogen fluxes from gap-phase mortality + + ! displayed pools + DO m = ps, pe + leafn_p (m) = leafn_p (m) & + - m_leafn_to_litter_p (m) * deltim + frootn_p (m) = frootn_p (m) & + - m_frootn_to_litter_p (m) * deltim + livestemn_p (m) = livestemn_p (m) & + - m_livestemn_to_litter_p (m) * deltim + deadstemn_p (m) = deadstemn_p (m) & + - m_deadstemn_to_litter_p (m) * deltim + livecrootn_p (m) = livecrootn_p (m) & + - m_livecrootn_to_litter_p (m) * deltim + deadcrootn_p (m) = deadcrootn_p (m) & + - m_deadcrootn_to_litter_p (m) * deltim + retransn_p (m) = retransn_p (m) & + - m_retransn_to_litter_p (m) * deltim + + ! storage pools + leafn_storage_p (m) = leafn_storage_p (m) & + - m_leafn_storage_to_litter_p (m) * deltim + frootn_storage_p (m) = frootn_storage_p (m) & + - m_frootn_storage_to_litter_p (m) * deltim + livestemn_storage_p (m) = livestemn_storage_p (m) & + - m_livestemn_storage_to_litter_p (m) * deltim + deadstemn_storage_p (m) = deadstemn_storage_p (m) & + - m_deadstemn_storage_to_litter_p (m) * deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) & + - m_livecrootn_storage_to_litter_p(m) * deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) & + - m_deadcrootn_storage_to_litter_p(m) * deltim + + ! transfer pools + leafn_xfer_p (m) = leafn_xfer_p (m) & + - m_leafn_xfer_to_litter_p (m) * deltim + frootn_xfer_p (m) = frootn_xfer_p (m) & + - m_frootn_xfer_to_litter_p (m) * deltim + livestemn_xfer_p (m) = livestemn_xfer_p (m) & + - m_livestemn_xfer_to_litter_p (m) * deltim + deadstemn_xfer_p (m) = deadstemn_xfer_p (m) & + - m_deadstemn_xfer_to_litter_p (m) * deltim + livecrootn_xfer_p (m) = livecrootn_xfer_p (m) & + - m_livecrootn_xfer_to_litter_p (m) * deltim + deadcrootn_xfer_p (m) = deadcrootn_xfer_p (m) & + - m_deadcrootn_xfer_to_litter_p (m) * deltim + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + AKX_leafn_exit_p_acc (m) = AKX_leafn_exit_p_acc (m) + m_leafn_to_litter_p (m) * deltim + AKX_frootn_exit_p_acc (m) = AKX_frootn_exit_p_acc (m) + m_frootn_to_litter_p (m) * deltim + AKX_livestemn_exit_p_acc (m) = AKX_livestemn_exit_p_acc (m) + m_livestemn_to_litter_p (m) * deltim + AKX_deadstemn_exit_p_acc (m) = AKX_deadstemn_exit_p_acc (m) + m_deadstemn_to_litter_p (m) * deltim + AKX_livecrootn_exit_p_acc (m) = AKX_livecrootn_exit_p_acc (m) + m_livecrootn_to_litter_p (m) * deltim + AKX_deadcrootn_exit_p_acc (m) = AKX_deadcrootn_exit_p_acc (m) + m_deadcrootn_to_litter_p (m) * deltim + AKX_retransn_exit_p_acc (m) = AKX_retransn_exit_p_acc (m) + m_retransn_to_litter_p (m) * deltim + + AKX_leafn_st_exit_p_acc (m) = AKX_leafn_st_exit_p_acc (m) + m_leafn_storage_to_litter_p (m) * deltim + AKX_frootn_st_exit_p_acc (m) = AKX_frootn_st_exit_p_acc (m) + m_frootn_storage_to_litter_p (m) * deltim + AKX_livestemn_st_exit_p_acc (m) = AKX_livestemn_st_exit_p_acc (m) + m_livestemn_storage_to_litter_p (m) * deltim + AKX_deadstemn_st_exit_p_acc (m) = AKX_deadstemn_st_exit_p_acc (m) + m_deadstemn_storage_to_litter_p (m) * deltim + AKX_livecrootn_st_exit_p_acc (m) = AKX_livecrootn_st_exit_p_acc (m) + m_livecrootn_storage_to_litter_p(m) * deltim + AKX_deadcrootn_st_exit_p_acc (m) = AKX_deadcrootn_st_exit_p_acc (m) + m_deadcrootn_storage_to_litter_p(m) * deltim + + AKX_leafn_xf_exit_p_acc (m) = AKX_leafn_xf_exit_p_acc (m) + m_leafn_xfer_to_litter_p (m) * deltim + AKX_frootn_xf_exit_p_acc (m) = AKX_frootn_xf_exit_p_acc (m) + m_frootn_xfer_to_litter_p (m) * deltim + AKX_livestemn_xf_exit_p_acc (m) = AKX_livestemn_xf_exit_p_acc (m) + m_livestemn_xfer_to_litter_p (m) * deltim + AKX_deadstemn_xf_exit_p_acc (m) = AKX_deadstemn_xf_exit_p_acc (m) + m_deadstemn_xfer_to_litter_p (m) * deltim + AKX_livecrootn_xf_exit_p_acc (m) = AKX_livecrootn_xf_exit_p_acc (m) + m_livecrootn_xfer_to_litter_p (m) * deltim + AKX_deadcrootn_xf_exit_p_acc (m) = AKX_deadcrootn_xf_exit_p_acc (m) + m_deadcrootn_xfer_to_litter_p (m) * deltim + ENDIF + ENDDO + + END SUBROUTINE NStateUpdate2 + +END MODULE MOD_BGC_CNNStateUpdate2 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate3.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate3.F90 new file mode 100644 index 0000000000..eff81d7448 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNNStateUpdate3.F90 @@ -0,0 +1,222 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNNStateUpdate3 + +!------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! First updates in vegetation and soil nitrogen. The major updates are included in bgc_CNNStateUpdate1Mod +! 1. Update fire-associated veg and soil(litter) N pool size changes +! 2. Record the accumulated N transfers associated to fire for semi-analytic spinup + +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record accumulated fire-associated N transfers for veg and soil N semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF, DEF_USE_FIRE + USE MOD_BGC_Vars_TimeInvariants, only: & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd, i_soil1, i_soil2, i_soil3 + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition pools & fluxes variables (inout) + decomp_npools_vr, sminn_vr, smin_no3_vr, smin_nh4_vr + + USE MOD_BGC_Vars_1DFluxes, only: & + m_decomp_npools_to_fire_vr, & + fire_mortality_to_met_n, fire_mortality_to_cel_n, & + fire_mortality_to_lig_n, fire_mortality_to_cwdn , & + + ! mineral nitrogen pools & fluxes variables (inout) + sminn_leached_vr, smin_no3_leached_vr, smin_no3_runoff_vr + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation nitrogen state variables (inout) + leafn_p , leafn_storage_p , leafn_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p , livecrootn_storage_p, livecrootn_xfer_p, & + deadcrootn_p , deadcrootn_storage_p, deadcrootn_xfer_p, & + retransn_p + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation nitrogen flux variables + m_leafn_to_fire_p , m_leafn_storage_to_fire_p , m_leafn_xfer_to_fire_p , & + m_frootn_to_fire_p , m_frootn_storage_to_fire_p , m_frootn_xfer_to_fire_p , & + m_livestemn_to_fire_p , m_livestemn_storage_to_fire_p , m_livestemn_xfer_to_fire_p , & + m_deadstemn_to_fire_p , m_deadstemn_storage_to_fire_p , m_deadstemn_xfer_to_fire_p , & + m_livecrootn_to_fire_p , m_livecrootn_storage_to_fire_p, m_livecrootn_xfer_to_fire_p, & + m_deadcrootn_to_fire_p , m_deadcrootn_storage_to_fire_p, m_deadcrootn_xfer_to_fire_p, & + m_livestemn_to_deadstemn_fire_p , m_livecrootn_to_deadcrootn_fire_p , & + m_retransn_to_fire_p, & + + m_leafn_to_litter_fire_p , m_leafn_storage_to_litter_fire_p , m_leafn_xfer_to_litter_fire_p , & + m_frootn_to_litter_fire_p , m_frootn_storage_to_litter_fire_p , m_frootn_xfer_to_litter_fire_p , & + m_livestemn_to_litter_fire_p , m_livestemn_storage_to_litter_fire_p , m_livestemn_xfer_to_litter_fire_p , & + m_deadstemn_to_litter_fire_p , m_deadstemn_storage_to_litter_fire_p , m_deadstemn_xfer_to_litter_fire_p , & + m_livecrootn_to_litter_fire_p , m_livecrootn_storage_to_litter_fire_p, m_livecrootn_xfer_to_litter_fire_p, & + m_deadcrootn_to_litter_fire_p , m_deadcrootn_storage_to_litter_fire_p, m_deadcrootn_xfer_to_litter_fire_p, & + m_retransn_to_litter_fire_p + + + IMPLICIT NONE + + PUBLIC NStateUpdate3 + +CONTAINS + + SUBROUTINE NStateUpdate3(i, ps, pe, deltim, nl_soil, ndecomp_pools, dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + + integer ,intent(in) :: nl_soil ! number of total soil number + integer ,intent(in) :: ndecomp_pools ! number total litter & soil pools + real(r8),intent(in) :: dz_soi(1:nl_soil)! thicnesses of eacn soil layer + + integer j,l,m + + + IF(.not. DEF_USE_NITRIF)THEN + ! mineral N loss due to leaching + DO j = 1, nl_soil + sminn_vr(j,i) = sminn_vr(j,i) - sminn_leached_vr(j,i) * deltim + ENDDO + ELSE + DO j = 1, nl_soil + ! mineral N loss due to leaching and runoff + smin_no3_vr(j,i) = max( smin_no3_vr(j,i) & + - ( smin_no3_leached_vr(j,i) + smin_no3_runoff_vr(j,i) ) * deltim, 0._r8) + + sminn_vr(j,i) = smin_no3_vr(j,i) + smin_nh4_vr(j,i) + ENDDO + ENDIF + + ! column level nitrogen fluxes from fire + ! patch-level wood to column-level CWD (uncombusted wood) + IF(DEF_USE_FIRE)THEN + DO j = 1, nl_soil + decomp_npools_vr(j,i_cwd,i) = decomp_npools_vr(j,i_cwd,i) & + + fire_mortality_to_cwdn(j,i) * deltim + + ! patch-level wood to column-level litter (uncombusted wood) + decomp_npools_vr(j,i_met_lit,i) = decomp_npools_vr(j,i_met_lit,i) & + + fire_mortality_to_met_n(j,i)* deltim + decomp_npools_vr(j,i_cel_lit,i) = decomp_npools_vr(j,i_cel_lit,i) & + + fire_mortality_to_cel_n(j,i)* deltim + decomp_npools_vr(j,i_lig_lit,i) = decomp_npools_vr(j,i_lig_lit,i) & + + fire_mortality_to_lig_n(j,i)* deltim + ENDDO + + ! litter and CWD losses to fire + DO l = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_npools_vr(j,l,i) = decomp_npools_vr(j,l,i) & + - m_decomp_npools_to_fire_vr(j,l,i) * deltim + ENDDO + ENDDO + + DO m = ps , pe + !from fire displayed pools + leafn_p (m) = leafn_p (m) & + - m_leafn_to_fire_p (m) * deltim + frootn_p (m) = frootn_p (m) & + - m_frootn_to_fire_p (m) * deltim + livestemn_p (m) = livestemn_p (m) & + - m_livestemn_to_fire_p (m) * deltim + deadstemn_p (m) = deadstemn_p (m) & + - m_deadstemn_to_fire_p (m) * deltim + livecrootn_p (m) = livecrootn_p (m) & + - m_livecrootn_to_fire_p (m) * deltim + deadcrootn_p (m) = deadcrootn_p (m) & + - m_deadcrootn_to_fire_p (m) * deltim + + leafn_p (m) = leafn_p (m) & + - m_leafn_to_litter_fire_p (m) * deltim + frootn_p (m) = frootn_p (m) & + - m_frootn_to_litter_fire_p (m) * deltim + livestemn_p (m) = livestemn_p (m) & + - m_livestemn_to_litter_fire_p (m) * deltim & + - m_livestemn_to_deadstemn_fire_p (m) * deltim + deadstemn_p (m) = deadstemn_p (m) & + - m_deadstemn_to_litter_fire_p (m) * deltim & + + m_livestemn_to_deadstemn_fire_p (m) * deltim + livecrootn_p (m) = livecrootn_p (m) & + - m_livecrootn_to_litter_fire_p (m) * deltim & + - m_livecrootn_to_deadcrootn_fire_p(m) * deltim + deadcrootn_p (m) = deadcrootn_p (m) & + - m_deadcrootn_to_litter_fire_p (m) * deltim & + + m_livecrootn_to_deadcrootn_fire_p(m) * deltim + + ! storage pools + leafn_storage_p (m) = leafn_storage_p (m) & + - m_leafn_storage_to_fire_p (m) * deltim + frootn_storage_p (m) = frootn_storage_p (m) & + - m_frootn_storage_to_fire_p (m) * deltim + livestemn_storage_p (m) = livestemn_storage_p (m) & + - m_livestemn_storage_to_fire_p (m) * deltim + deadstemn_storage_p (m) = deadstemn_storage_p (m) & + - m_deadstemn_storage_to_fire_p (m) * deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) & + - m_livecrootn_storage_to_fire_p (m) * deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) & + - m_deadcrootn_storage_to_fire_p (m) * deltim + + leafn_storage_p (m) = leafn_storage_p (m) & + - m_leafn_storage_to_litter_fire_p (m) * deltim + frootn_storage_p (m) = frootn_storage_p (m) & + - m_frootn_storage_to_litter_fire_p (m) * deltim + livestemn_storage_p (m) = livestemn_storage_p (m) & + - m_livestemn_storage_to_litter_fire_p (m) * deltim + deadstemn_storage_p (m) = deadstemn_storage_p (m) & + - m_deadstemn_storage_to_litter_fire_p (m) * deltim + livecrootn_storage_p(m) = livecrootn_storage_p(m) & + - m_livecrootn_storage_to_litter_fire_p(m) * deltim + deadcrootn_storage_p(m) = deadcrootn_storage_p(m) & + - m_deadcrootn_storage_to_litter_fire_p(m) * deltim + + + ! transfer pools + leafn_xfer_p (m) = leafn_xfer_p (m) & + - m_leafn_xfer_to_fire_p (m) * deltim + frootn_xfer_p (m) = frootn_xfer_p (m) & + - m_frootn_xfer_to_fire_p (m) * deltim + livestemn_xfer_p (m) = livestemn_xfer_p (m) & + - m_livestemn_xfer_to_fire_p (m) * deltim + deadstemn_xfer_p (m) = deadstemn_xfer_p (m) & + - m_deadstemn_xfer_to_fire_p (m) * deltim + livecrootn_xfer_p (m) = livecrootn_xfer_p (m) & + - m_livecrootn_xfer_to_fire_p (m) * deltim + deadcrootn_xfer_p (m) = deadcrootn_xfer_p (m) & + - m_deadcrootn_xfer_to_fire_p (m) * deltim + + leafn_xfer_p (m) = leafn_xfer_p (m) & + - m_leafn_xfer_to_litter_fire_p (m) * deltim + frootn_xfer_p (m) = frootn_xfer_p (m) & + - m_frootn_xfer_to_litter_fire_p (m) * deltim + livestemn_xfer_p (m) = livestemn_xfer_p (m) & + - m_livestemn_xfer_to_litter_fire_p (m) * deltim + deadstemn_xfer_p (m) = deadstemn_xfer_p (m) & + - m_deadstemn_xfer_to_litter_fire_p (m) * deltim + livecrootn_xfer_p (m) = livecrootn_xfer_p (m) & + - m_livecrootn_xfer_to_litter_fire_p (m) * deltim + deadcrootn_xfer_p (m) = deadcrootn_xfer_p (m) & + - m_deadcrootn_xfer_to_litter_fire_p (m) * deltim + + ! retranslocated N pool + retransn_p (m) = retransn_p (m) & + - m_retransn_to_fire_p (m) * deltim + retransn_p (m) = retransn_p (m) & + - m_retransn_to_litter_fire_p (m) * deltim + ENDDO + ENDIF + + END SUBROUTINE NStateUpdate3 + +END MODULE MOD_BGC_CNNStateUpdate3 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 new file mode 100644 index 0000000000..ff4c5f506e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90 @@ -0,0 +1,1075 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNSASU + +!---------------------------------------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE implements an semi-analytic accerlating spin-up method (SASU) in CoLM bgc MODULE. The SASU method analytically calculates +! the steady state of each vegetation and soil C and N pool sizes, and replace current CN pool sizes with analytical steady state +! solution. So, CN pool sizes in both vegetation and soil reach steady state much faster than conventional spin up method. +! +! !MODULE for CoLM-BGC matrices +! The vegetation matrix equation +! Xn+1 = Xn + I*dt + (Aph*Kph + Agm*Kgm + Afire*Kfire) * dt +! The soil matrix equation +! Xn+1 = Xn + I*dt + (A*K(ksi) + Kfire + tri/dz)*Xn*dt +! The steady state solution for vegetation C is X = -I*B*(Aph*Kph + Agm*Kgm + Afire*Kfire)**(-1) +! The steady state solution for soil C is X = -I *(A*K(ksi) + Kfire + tri/dz)**(-1) +! +! !ORIGINAL: +! The Community Land Model version 5.1 (CLM5.1) unreleased version developed by Xingjie Lu +! +! !REFERENCES: +! Lu, X., Du, Z., Huang, Y., Lawrence, D., Kluzek, E., Collier, N., Lombardozzi, D., Sobhani, N., Schuur, E.A. and Luo, Y., 2020. +! Full implementation of matrix approach to biogeochemistry MODULE of CLM5. Journal of Advances in Modeling Earth Systems, 12(11), e2020MS002105. +! Liao, C., Lu, X., Huang Y., Tao F., Lawrence, D., Koven C., Oleson, K., Wieder, W., Kluzek, E., Huang, X., Luo, Y. (in submission) +! Matrix Approach to Accelerate Spin-Up of CLM5 +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. +! USE accumulated transfer fluxes to calculate the matrix. + + USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_BGC_Vars_TimeInvariants, only: & + i_met_lit, i_cel_lit, i_lig_lit, i_cwd, i_soil1, i_soil2, i_soil3, floating_cn_ratio + + USE MOD_BGC_Vars_TimeVariables, only: & + decomp_cpools_vr , decomp_npools_vr , decomp0_cpools_vr , decomp0_npools_vr , & + decomp_cpools_vr_Cap , decomp_npools_vr_Cap , & + I_met_c_vr_acc , I_cel_c_vr_acc , I_lig_c_vr_acc , I_cwd_c_vr_acc , & + AKX_met_to_soil1_c_vr_acc , AKX_cel_to_soil1_c_vr_acc , AKX_lig_to_soil2_c_vr_acc , AKX_soil1_to_soil2_c_vr_acc, & + AKX_cwd_to_cel_c_vr_acc , AKX_cwd_to_lig_c_vr_acc , AKX_soil1_to_soil3_c_vr_acc, AKX_soil2_to_soil1_c_vr_acc, & + AKX_soil2_to_soil3_c_vr_acc, AKX_soil3_to_soil1_c_vr_acc, & + AKX_met_exit_c_vr_acc , AKX_cel_exit_c_vr_acc , AKX_lig_exit_c_vr_acc , AKX_cwd_exit_c_vr_acc , & + AKX_soil1_exit_c_vr_acc , AKX_soil2_exit_c_vr_acc , AKX_soil3_exit_c_vr_acc , & + diagVX_c_vr_acc , upperVX_c_vr_acc , lowerVX_c_vr_acc , & + I_met_n_vr_acc , I_cel_n_vr_acc , I_lig_n_vr_acc , I_cwd_n_vr_acc , & + AKX_met_to_soil1_n_vr_acc , AKX_cel_to_soil1_n_vr_acc , AKX_lig_to_soil2_n_vr_acc , AKX_soil1_to_soil2_n_vr_acc, & + AKX_cwd_to_cel_n_vr_acc , AKX_cwd_to_lig_n_vr_acc , AKX_soil1_to_soil3_n_vr_acc, AKX_soil2_to_soil1_n_vr_acc, & + AKX_soil2_to_soil3_n_vr_acc, AKX_soil3_to_soil1_n_vr_acc, & + AKX_met_exit_n_vr_acc , AKX_cel_exit_n_vr_acc , AKX_lig_exit_n_vr_acc , AKX_cwd_exit_n_vr_acc , & + AKX_soil1_exit_n_vr_acc , AKX_soil2_exit_n_vr_acc , AKX_soil3_exit_n_vr_acc , & + diagVX_n_vr_acc , upperVX_n_vr_acc , lowerVX_n_vr_acc , skip_balance_check , & + cn_decomp_pools + + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_BGC_Vars_PFTimeVariables, only: & + leafc_p , leafc_storage_p , leafc_xfer_p , leafc0_p , leafc0_storage_p , leafc0_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , frootc0_p , frootc0_storage_p , frootc0_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , livestemc0_p , livestemc0_storage_p , livestemc0_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , deadstemc0_p , deadstemc0_storage_p , deadstemc0_xfer_p , & + livecrootc_p , livecrootc_storage_p , livecrootc_xfer_p , livecrootc0_p , livecrootc0_storage_p, livecrootc0_xfer_p, & + deadcrootc_p , deadcrootc_storage_p , deadcrootc_xfer_p , deadcrootc0_p , deadcrootc0_storage_p, deadcrootc0_xfer_p, & + grainc_p , grainc_storage_p , grainc_xfer_p , grainc0_p , grainc0_storage_p , grainc0_xfer_p , & + + leafcCap_p , leafc_storageCap_p , leafc_xferCap_p , & + frootcCap_p , frootc_storageCap_p , frootc_xferCap_p , & + livestemcCap_p , livestemc_storageCap_p , livestemc_xferCap_p , & + deadstemcCap_p , deadstemc_storageCap_p , deadstemc_xferCap_p , & + livecrootcCap_p , livecrootc_storageCap_p , livecrootc_xferCap_p , & + deadcrootcCap_p , deadcrootc_storageCap_p , deadcrootc_xferCap_p , & + + leafnCap_p , leafn_storageCap_p , leafn_xferCap_p , & + frootnCap_p , frootn_storageCap_p , frootn_xferCap_p , & + livestemnCap_p , livestemn_storageCap_p , livestemn_xferCap_p , & + deadstemnCap_p , deadstemn_storageCap_p , deadstemn_xferCap_p , & + livecrootnCap_p , livecrootn_storageCap_p , livecrootn_xferCap_p , & + deadcrootnCap_p , deadcrootn_storageCap_p , deadcrootn_xferCap_p , & + + leafn_p , leafn_storage_p , leafn_xfer_p , leafn0_p , leafn0_storage_p , leafn0_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , frootn0_p , frootn0_storage_p , frootn0_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , livestemn0_p , livestemn0_storage_p , livestemn0_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , deadstemn0_p , deadstemn0_storage_p , deadstemn0_xfer_p , & + livecrootn_p , livecrootn_storage_p , livecrootn_xfer_p , livecrootn0_p , livecrootn0_storage_p, livecrootn0_xfer_p, & + deadcrootn_p , deadcrootn_storage_p , deadcrootn_xfer_p , deadcrootn0_p , deadcrootn0_storage_p, deadcrootn0_xfer_p, & + grainn_p , grainn_storage_p , grainn_xfer_p , grainn0_p , grainn0_storage_p , grainn0_xfer_p , & + retransn_p , retransn0_p , & + + I_leafc_p_acc , I_leafc_st_p_acc , I_frootc_p_acc , I_frootc_st_p_acc , & + I_livestemc_p_acc , I_livestemc_st_p_acc , I_deadstemc_p_acc , I_deadstemc_st_p_acc , & + I_livecrootc_p_acc, I_livecrootc_st_p_acc, I_deadcrootc_p_acc, I_deadcrootc_st_p_acc, & + I_grainc_p_acc , I_grainc_st_p_acc , & + + I_leafn_p_acc , I_leafn_st_p_acc , I_frootn_p_acc , I_frootn_st_p_acc , & + I_livestemn_p_acc , I_livestemn_st_p_acc , I_deadstemn_p_acc , I_deadstemn_st_p_acc , & + I_livecrootn_p_acc, I_livecrootn_st_p_acc, I_deadcrootn_p_acc, I_deadcrootn_st_p_acc, & + I_grainn_p_acc , I_grainn_st_p_acc , & + + AKX_leafc_xf_to_leafc_p_acc , AKX_frootc_xf_to_frootc_p_acc , AKX_livestemc_xf_to_livestemc_p_acc , & + AKX_deadstemc_xf_to_deadstemc_p_acc , AKX_livecrootc_xf_to_livecrootc_p_acc , AKX_deadcrootc_xf_to_deadcrootc_p_acc , & + AKX_grainc_xf_to_grainc_p_acc , AKX_livestemc_to_deadstemc_p_acc , AKX_livecrootc_to_deadcrootc_p_acc , & + + AKX_leafc_st_to_leafc_xf_p_acc , AKX_frootc_st_to_frootc_xf_p_acc , AKX_livestemc_st_to_livestemc_xf_p_acc , & + AKX_deadstemc_st_to_deadstemc_xf_p_acc, AKX_livecrootc_st_to_livecrootc_xf_p_acc, AKX_deadcrootc_st_to_deadcrootc_xf_p_acc, & + AKX_grainc_st_to_grainc_xf_p_acc , & + + AKX_leafc_exit_p_acc , AKX_frootc_exit_p_acc , AKX_livestemc_exit_p_acc , & + AKX_deadstemc_exit_p_acc , AKX_livecrootc_exit_p_acc , AKX_deadcrootc_exit_p_acc , & + AKX_grainc_exit_p_acc , & + + AKX_leafc_st_exit_p_acc , AKX_frootc_st_exit_p_acc , AKX_livestemc_st_exit_p_acc , & + AKX_deadstemc_st_exit_p_acc , AKX_livecrootc_st_exit_p_acc , AKX_deadcrootc_st_exit_p_acc , & + AKX_grainc_st_exit_p_acc , & + + AKX_leafc_xf_exit_p_acc , AKX_frootc_xf_exit_p_acc , AKX_livestemc_xf_exit_p_acc , & + AKX_deadstemc_xf_exit_p_acc , AKX_livecrootc_xf_exit_p_acc , AKX_deadcrootc_xf_exit_p_acc , & + AKX_grainc_xf_exit_p_acc , & + + AKX_leafn_xf_to_leafn_p_acc , AKX_frootn_xf_to_frootn_p_acc , AKX_livestemn_xf_to_livestemn_p_acc , & + AKX_deadstemn_xf_to_deadstemn_p_acc , AKX_livecrootn_xf_to_livecrootn_p_acc , AKX_deadcrootn_xf_to_deadcrootn_p_acc , & + AKX_grainn_xf_to_grainn_p_acc , AKX_livestemn_to_deadstemn_p_acc , AKX_livecrootn_to_deadcrootn_p_acc , & + + AKX_leafn_st_to_leafn_xf_p_acc , AKX_frootn_st_to_frootn_xf_p_acc , AKX_livestemn_st_to_livestemn_xf_p_acc , & + AKX_deadstemn_st_to_deadstemn_xf_p_acc, AKX_livecrootn_st_to_livecrootn_xf_p_acc, AKX_deadcrootn_st_to_deadcrootn_xf_p_acc, & + AKX_grainn_st_to_grainn_xf_p_acc , & + + AKX_leafn_to_retransn_p_acc , AKX_frootn_to_retransn_p_acc , AKX_livestemn_to_retransn_p_acc , & + AKX_livecrootn_to_retransn_p_acc , & + + AKX_retransn_to_leafn_p_acc , AKX_retransn_to_frootn_p_acc , AKX_retransn_to_livestemn_p_acc , & + AKX_retransn_to_deadstemn_p_acc , AKX_retransn_to_livecrootn_p_acc , AKX_retransn_to_deadcrootn_p_acc , & + AKX_retransn_to_grainn_p_acc , & + + AKX_retransn_to_leafn_st_p_acc , AKX_retransn_to_frootn_st_p_acc , AKX_retransn_to_livestemn_st_p_acc , & + AKX_retransn_to_deadstemn_st_p_acc , AKX_retransn_to_livecrootn_st_p_acc , AKX_retransn_to_deadcrootn_st_p_acc , & + AKX_retransn_to_grainn_st_p_acc , & + + AKX_leafn_exit_p_acc , AKX_frootn_exit_p_acc , AKX_livestemn_exit_p_acc , & + AKX_deadstemn_exit_p_acc , AKX_livecrootn_exit_p_acc , AKX_deadcrootn_exit_p_acc , & + AKX_grainn_exit_p_acc , AKX_retransn_exit_p_acc , & + + AKX_leafn_st_exit_p_acc , AKX_frootn_st_exit_p_acc , AKX_livestemn_st_exit_p_acc , & + AKX_deadstemn_st_exit_p_acc , AKX_livecrootn_st_exit_p_acc , AKX_deadcrootn_st_exit_p_acc , & + AKX_grainn_st_exit_p_acc , & + + AKX_leafn_xf_exit_p_acc , AKX_frootn_xf_exit_p_acc , AKX_livestemn_xf_exit_p_acc , & + AKX_deadstemn_xf_exit_p_acc , AKX_livecrootn_xf_exit_p_acc , AKX_deadcrootn_xf_exit_p_acc , & + AKX_grainn_xf_exit_p_acc +! + IMPLICIT NONE + + PUBLIC :: CNSASU + PUBLIC :: inverse +!----------------------------------------------------------------------- + +CONTAINS + + + !----------------------------------------------------------------------- + SUBROUTINE CNSASU(i,ps,pe,deltim,idate,nl_soil,ndecomp_transitions, ndecomp_pools, ndecomp_pools_vr) + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: idate(3) ! current date (year, days of the year, seconds of the day) + integer, intent(in) :: nl_soil ! number of total soil number + integer, intent(in) :: ndecomp_transitions ! number of total litter & soil pools + integer, intent(in) :: ndecomp_pools ! number of total transfers between all litter & soil pools in the decomposition. + integer, intent(in) :: ndecomp_pools_vr ! number of total litter & soil pools times numer of soil layers (eg. 7 * 10) + + !----------------------------------------------------------------------- + + integer :: k, m, j + ! set index of vegetation CN pools + real(r8),parameter :: epsi = 1.e-8_r8 + integer ,parameter :: nvegc = 21 + integer ,parameter :: nvegn = 22 + integer ,parameter :: ileaf = 1 + integer ,parameter :: ileaf_st = 2 + integer ,parameter :: ileaf_xf = 3 + integer ,parameter :: ifroot = 4 + integer ,parameter :: ifroot_st = 5 + integer ,parameter :: ifroot_xf = 6 + integer ,parameter :: ilivestem = 7 + integer ,parameter :: ilivestem_st = 8 + integer ,parameter :: ilivestem_xf = 9 + integer ,parameter :: ideadstem = 10 + integer ,parameter :: ideadstem_st = 11 + integer ,parameter :: ideadstem_xf = 12 + integer ,parameter :: ilivecroot = 13 + integer ,parameter :: ilivecroot_st = 14 + integer ,parameter :: ilivecroot_xf = 15 + integer ,parameter :: ideadcroot = 16 + integer ,parameter :: ideadcroot_st = 17 + integer ,parameter :: ideadcroot_xf = 18 + integer ,parameter :: igrain = 19 + integer ,parameter :: igrain_st = 20 + integer ,parameter :: igrain_xf = 21 + integer ,parameter :: iretrans = 22 + + + real(r8),dimension(1:nvegc,1:nvegc) :: AK_veg_acc + real(r8),dimension(1:nvegn,1:nvegn) :: AK_veg_nacc + real(r8),dimension(1:nvegc) :: I_veg_acc + real(r8),dimension(1:nvegn) :: I_veg_nacc + real(r8),dimension(1:ndecomp_pools_vr,1:ndecomp_pools_vr) :: AK_soil_acc + real(r8),dimension(1:ndecomp_pools_vr,1:ndecomp_pools_vr) :: AK_soil_nacc + real(r8),dimension(1:ndecomp_pools_vr) :: I_soil_acc + real(r8),dimension(1:ndecomp_pools_vr) :: I_soil_nacc + real(r8),dimension(1:nvegc,1:nvegc) :: AKinv_veg + real(r8),dimension(1:nvegn,1:nvegn) :: AKinvn_veg + real(r8),dimension(1:ndecomp_pools_vr,1:ndecomp_pools_vr) :: AKinv_soil + real(r8),dimension(1:ndecomp_pools_vr,1:ndecomp_pools_vr) :: AKinvn_soil + real(r8),dimension(1:nvegc,1) :: vegmatrixc_cap + real(r8),dimension(1:nvegn,1) :: vegmatrixn_cap + real(r8),dimension(1:ndecomp_pools_vr,1) :: soilmatrixc_cap + real(r8),dimension(1:ndecomp_pools_vr,1) :: soilmatrixn_cap + + ! Save the C and N pool size at begin of each year, which are used to calculate C and N capacity at end of each year. + IF (idate(2) .eq. 1 .and. idate(3) .eq. deltim)THEN + DO m = ps, pe + leafc0_p (m) = max(leafc_p (m),epsi) + leafc0_storage_p (m) = max(leafc_storage_p (m),epsi) + leafc0_xfer_p (m) = max(leafc_xfer_p (m),epsi) + frootc0_p (m) = max(frootc_p (m),epsi) + frootc0_storage_p (m) = max(frootc_storage_p (m),epsi) + frootc0_xfer_p (m) = max(frootc_xfer_p (m),epsi) + livestemc0_p (m) = max(livestemc_p (m),epsi) + livestemc0_storage_p (m) = max(livestemc_storage_p (m),epsi) + livestemc0_xfer_p (m) = max(livestemc_xfer_p (m),epsi) + deadstemc0_p (m) = max(deadstemc_p (m),epsi) + deadstemc0_storage_p (m) = max(deadstemc_storage_p (m),epsi) + deadstemc0_xfer_p (m) = max(deadstemc_xfer_p (m),epsi) + livecrootc0_p (m) = max(livecrootc_p (m),epsi) + livecrootc0_storage_p(m) = max(livecrootc_storage_p(m),epsi) + livecrootc0_xfer_p (m) = max(livecrootc_xfer_p (m),epsi) + deadcrootc0_p (m) = max(deadcrootc_p (m),epsi) + deadcrootc0_storage_p(m) = max(deadcrootc_storage_p(m),epsi) + deadcrootc0_xfer_p (m) = max(deadcrootc_xfer_p (m),epsi) + grainc0_p (m) = max(grainc_p (m),epsi) + grainc0_storage_p (m) = max(grainc_storage_p (m),epsi) + grainc0_xfer_p (m) = max(grainc_xfer_p (m),epsi) + leafn0_p (m) = max(leafn_p (m),epsi) + leafn0_storage_p (m) = max(leafn_storage_p (m),epsi) + leafn0_xfer_p (m) = max(leafn_xfer_p (m),epsi) + frootn0_p (m) = max(frootn_p (m),epsi) + frootn0_storage_p (m) = max(frootn_storage_p (m),epsi) + frootn0_xfer_p (m) = max(frootn_xfer_p (m),epsi) + livestemn0_p (m) = max(livestemn_p (m),epsi) + livestemn0_storage_p (m) = max(livestemn_storage_p (m),epsi) + livestemn0_xfer_p (m) = max(livestemn_xfer_p (m),epsi) + deadstemn0_p (m) = max(deadstemn_p (m),epsi) + deadstemn0_storage_p (m) = max(deadstemn_storage_p (m),epsi) + deadstemn0_xfer_p (m) = max(deadstemn_xfer_p (m),epsi) + livecrootn0_p (m) = max(livecrootn_p (m),epsi) + livecrootn0_storage_p(m) = max(livecrootn_storage_p(m),epsi) + livecrootn0_xfer_p (m) = max(livecrootn_xfer_p (m),epsi) + deadcrootn0_p (m) = max(deadcrootn_p (m),epsi) + deadcrootn0_storage_p(m) = max(deadcrootn_storage_p(m),epsi) + deadcrootn0_xfer_p (m) = max(deadcrootn_xfer_p (m),epsi) + grainn0_p (m) = max(grainn_p (m),epsi) + grainn0_storage_p (m) = max(grainn_storage_p (m),epsi) + grainn0_xfer_p (m) = max(grainn_xfer_p (m),epsi) + retransn0_p (m) = max(retransn_p (m),epsi) + ENDDO + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp0_cpools_vr(j,k,i)=max(decomp_cpools_vr(j,k,i),epsi) + decomp0_npools_vr(j,k,i)=max(decomp_npools_vr(j,k,i),epsi) + ENDDO + ENDDO + ENDIF + + IF(idate(2) .eq. 365 .and. idate(3) .eq. 86400 - deltim)THEN + ! Copy C transfers from sparse matrix to 2D temporary variables tran_acc and tran_nacc + ! Calculate the C and N transfer rate by dividing CN transfer by base value saved at begin of each year. + + DO m = ps, pe + AK_veg_acc (1:nvegc,1:nvegc) = 0._r8 + AK_veg_nacc (1:nvegn,1:nvegn) = 0._r8 + I_veg_acc (1:nvegc) = 0._r8 + I_veg_nacc (1:nvegn) = 0._r8 + + AK_veg_acc ( ileaf, ileaf_xf) = AKX_leafc_xf_to_leafc_p_acc (m) / leafc0_xfer_p (m) + AK_veg_acc ( ifroot, ifroot_xf) = AKX_frootc_xf_to_frootc_p_acc (m) / frootc0_xfer_p (m) + AK_veg_acc ( ilivestem, ilivestem_xf) = AKX_livestemc_xf_to_livestemc_p_acc (m) / livestemc0_xfer_p (m) + AK_veg_acc ( ideadstem, ideadstem_xf) = AKX_deadstemc_xf_to_deadstemc_p_acc (m) / deadstemc0_xfer_p (m) + AK_veg_acc ( ilivecroot,ilivecroot_xf) = AKX_livecrootc_xf_to_livecrootc_p_acc (m) / livecrootc0_xfer_p (m) + AK_veg_acc ( ideadcroot,ideadcroot_xf) = AKX_deadcrootc_xf_to_deadcrootc_p_acc (m) / deadcrootc0_xfer_p (m) + AK_veg_acc ( igrain, igrain_xf) = AKX_grainc_xf_to_grainc_p_acc (m) / grainc0_xfer_p (m) + AK_veg_acc ( ideadstem, ilivestem) = AKX_livestemc_to_deadstemc_p_acc (m) / livestemc0_p (m) + AK_veg_acc ( ideadcroot, ilivecroot) = AKX_livecrootc_to_deadcrootc_p_acc (m) / livecrootc0_p (m) + + AK_veg_acc ( ileaf_xf, ileaf_st) = AKX_leafc_st_to_leafc_xf_p_acc (m) / leafc0_storage_p (m) + AK_veg_acc ( ifroot_xf, ifroot_st) = AKX_frootc_st_to_frootc_xf_p_acc (m) / frootc0_storage_p (m) + AK_veg_acc ( ilivestem_xf, ilivestem_st) = AKX_livestemc_st_to_livestemc_xf_p_acc (m) / livestemc0_storage_p (m) + AK_veg_acc ( ideadstem_xf, ideadstem_st) = AKX_deadstemc_st_to_deadstemc_xf_p_acc (m) / deadstemc0_storage_p (m) + AK_veg_acc (ilivecroot_xf,ilivecroot_st) = AKX_livecrootc_st_to_livecrootc_xf_p_acc(m) / livecrootc0_storage_p(m) + AK_veg_acc (ideadcroot_xf,ideadcroot_st) = AKX_deadcrootc_st_to_deadcrootc_xf_p_acc(m) / deadcrootc0_storage_p(m) + AK_veg_acc ( igrain_xf, igrain_st) = AKX_grainc_st_to_grainc_xf_p_acc (m) / grainc0_storage_p (m) + + AK_veg_acc ( ileaf, ileaf) = - AKX_leafc_exit_p_acc (m) / leafc0_p (m) + AK_veg_acc ( ileaf_st, ileaf_st) = - AKX_leafc_st_exit_p_acc (m) / leafc0_storage_p (m) + AK_veg_acc ( ileaf_xf, ileaf_xf) = - AKX_leafc_xf_exit_p_acc (m) / leafc0_xfer_p (m) + AK_veg_acc ( ifroot, ifroot) = - AKX_frootc_exit_p_acc (m) / frootc0_p (m) + AK_veg_acc ( ifroot_st, ifroot_st) = - AKX_frootc_st_exit_p_acc (m) / frootc0_storage_p (m) + AK_veg_acc ( ifroot_xf, ifroot_xf) = - AKX_frootc_xf_exit_p_acc (m) / frootc0_xfer_p (m) + AK_veg_acc ( ilivestem, ilivestem) = - AKX_livestemc_exit_p_acc (m) / livestemc0_p (m) + AK_veg_acc ( ilivestem_st, ilivestem_st) = - AKX_livestemc_st_exit_p_acc (m) / livestemc0_storage_p (m) + AK_veg_acc ( ilivestem_xf, ilivestem_xf) = - AKX_livestemc_xf_exit_p_acc (m) / livestemc0_xfer_p (m) + AK_veg_acc ( ideadstem, ideadstem) = - AKX_deadstemc_exit_p_acc (m) / deadstemc0_p (m) + AK_veg_acc ( ideadstem_st, ideadstem_st) = - AKX_deadstemc_st_exit_p_acc (m) / deadstemc0_storage_p (m) + AK_veg_acc ( ideadstem_xf, ideadstem_xf) = - AKX_deadstemc_xf_exit_p_acc (m) / deadstemc0_xfer_p (m) + AK_veg_acc ( ilivecroot, ilivecroot) = - AKX_livecrootc_exit_p_acc (m) / livecrootc0_p (m) + AK_veg_acc (ilivecroot_st,ilivecroot_st) = - AKX_livecrootc_st_exit_p_acc (m) / livecrootc0_storage_p(m) + AK_veg_acc (ilivecroot_xf,ilivecroot_xf) = - AKX_livecrootc_xf_exit_p_acc (m) / livecrootc0_xfer_p (m) + AK_veg_acc ( ideadcroot, ideadcroot) = - AKX_deadcrootc_exit_p_acc (m) / deadcrootc0_p (m) + AK_veg_acc (ideadcroot_st,ideadcroot_st) = - AKX_deadcrootc_st_exit_p_acc (m) / deadcrootc0_storage_p(m) + AK_veg_acc (ideadcroot_xf,ideadcroot_xf) = - AKX_deadcrootc_xf_exit_p_acc (m) / deadcrootc0_xfer_p (m) + AK_veg_acc ( igrain, igrain) = - AKX_grainc_exit_p_acc (m) / grainc0_p (m) + AK_veg_acc ( igrain_st, igrain_st) = - AKX_grainc_st_exit_p_acc (m) / grainc0_storage_p (m) + AK_veg_acc ( igrain_xf, igrain_xf) = - AKX_grainc_xf_exit_p_acc (m) / grainc0_xfer_p (m) + + I_veg_acc ( ileaf) = I_leafc_p_acc (m) + I_veg_acc ( ileaf_st) = I_leafc_st_p_acc (m) + I_veg_acc ( ifroot) = I_frootc_p_acc (m) + I_veg_acc ( ifroot_st) = I_frootc_st_p_acc (m) + I_veg_acc ( ilivestem) = I_livestemc_p_acc (m) + I_veg_acc ( ilivestem_st) = I_livestemc_st_p_acc (m) + I_veg_acc ( ideadstem) = I_deadstemc_p_acc (m) + I_veg_acc ( ideadstem_st) = I_deadstemc_st_p_acc (m) + I_veg_acc ( ilivecroot) = I_livecrootc_p_acc (m) + I_veg_acc (ilivecroot_st) = I_livecrootc_st_p_acc (m) + I_veg_acc ( ideadcroot) = I_deadcrootc_p_acc (m) + I_veg_acc (ideadcroot_st) = I_deadcrootc_st_p_acc (m) + I_veg_acc ( igrain) = I_grainc_p_acc (m) + I_veg_acc ( igrain_st) = I_grainc_st_p_acc (m) + + AK_veg_nacc ( ileaf, ileaf_xf) = AKX_leafn_xf_to_leafn_p_acc (m) / leafn0_xfer_p (m) + AK_veg_nacc ( ifroot, ifroot_xf) = AKX_frootn_xf_to_frootn_p_acc (m) / frootn0_xfer_p (m) + AK_veg_nacc ( ilivestem, ilivestem_xf) = AKX_livestemn_xf_to_livestemn_p_acc (m) / livestemn0_xfer_p (m) + AK_veg_nacc ( ideadstem, ideadstem_xf) = AKX_deadstemn_xf_to_deadstemn_p_acc (m) / deadstemn0_xfer_p (m) + AK_veg_nacc ( ilivecroot,ilivecroot_xf) = AKX_livecrootn_xf_to_livecrootn_p_acc (m) / livecrootn0_xfer_p (m) + AK_veg_nacc ( ideadcroot,ideadcroot_xf) = AKX_deadcrootn_xf_to_deadcrootn_p_acc (m) / deadcrootn0_xfer_p (m) + AK_veg_nacc ( igrain, igrain_xf) = AKX_grainn_xf_to_grainn_p_acc (m) / grainn0_xfer_p (m) + AK_veg_nacc ( ideadstem, ilivestem) = AKX_livestemn_to_deadstemn_p_acc (m) / livestemn0_p (m) + AK_veg_nacc ( ideadcroot, ilivecroot) = AKX_livecrootn_to_deadcrootn_p_acc (m) / livecrootn0_p (m) + + AK_veg_nacc ( ileaf_xf, ileaf_st) = AKX_leafn_st_to_leafn_xf_p_acc (m) / leafn0_storage_p (m) + AK_veg_nacc ( ifroot_xf, ifroot_st) = AKX_frootn_st_to_frootn_xf_p_acc (m) / frootn0_storage_p (m) + AK_veg_nacc ( ilivestem_xf, ilivestem_st) = AKX_livestemn_st_to_livestemn_xf_p_acc (m) / livestemn0_storage_p (m) + AK_veg_nacc ( ideadstem_xf, ideadstem_st) = AKX_deadstemn_st_to_deadstemn_xf_p_acc (m) / deadstemn0_storage_p (m) + AK_veg_nacc (ilivecroot_xf,ilivecroot_st) = AKX_livecrootn_st_to_livecrootn_xf_p_acc(m) / livecrootn0_storage_p(m) + AK_veg_nacc (ideadcroot_xf,ideadcroot_st) = AKX_deadcrootn_st_to_deadcrootn_xf_p_acc(m) / deadcrootn0_storage_p(m) + AK_veg_nacc ( igrain_xf, igrain_st) = AKX_grainn_st_to_grainn_xf_p_acc (m) / grainn0_storage_p (m) + + AK_veg_nacc ( iretrans, ileaf) = AKX_leafn_to_retransn_p_acc (m) / leafn0_p (m) + AK_veg_nacc ( iretrans, ifroot) = AKX_frootn_to_retransn_p_acc (m) / frootn0_p (m) + AK_veg_nacc ( iretrans, ilivestem) = AKX_livestemn_to_retransn_p_acc (m) / livestemn0_p (m) + AK_veg_nacc ( iretrans, ilivecroot) = AKX_livecrootn_to_retransn_p_acc (m) / livecrootn0_p (m) + + AK_veg_nacc ( ileaf, iretrans) = AKX_retransn_to_leafn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ifroot, iretrans) = AKX_retransn_to_frootn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ilivestem, iretrans) = AKX_retransn_to_livestemn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ideadstem, iretrans) = AKX_retransn_to_deadstemn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ilivecroot, iretrans) = AKX_retransn_to_livecrootn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ideadcroot, iretrans) = AKX_retransn_to_deadcrootn_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( igrain, iretrans) = AKX_retransn_to_grainn_p_acc (m) / retransn0_p (m) + + AK_veg_nacc ( ileaf_st, iretrans) = AKX_retransn_to_leafn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ifroot_st, iretrans) = AKX_retransn_to_frootn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ilivestem_st, iretrans) = AKX_retransn_to_livestemn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( ideadstem_st, iretrans) = AKX_retransn_to_deadstemn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc (ilivecroot_st, iretrans) = AKX_retransn_to_livecrootn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc (ideadcroot_st, iretrans) = AKX_retransn_to_deadcrootn_st_p_acc (m) / retransn0_p (m) + AK_veg_nacc ( igrain_st, iretrans) = AKX_retransn_to_grainn_st_p_acc (m) / retransn0_p (m) + + AK_veg_nacc ( ileaf, ileaf) = - AKX_leafn_exit_p_acc (m) / leafn0_p (m) + AK_veg_nacc ( ileaf_st, ileaf_st) = - AKX_leafn_st_exit_p_acc (m) / leafn0_storage_p (m) + AK_veg_nacc ( ileaf_xf, ileaf_xf) = - AKX_leafn_xf_exit_p_acc (m) / leafn0_xfer_p (m) + AK_veg_nacc ( ifroot, ifroot) = - AKX_frootn_exit_p_acc (m) / frootn0_p (m) + AK_veg_nacc ( ifroot_st, ifroot_st) = - AKX_frootn_st_exit_p_acc (m) / frootn0_storage_p (m) + AK_veg_nacc ( ifroot_xf, ifroot_xf) = - AKX_frootn_xf_exit_p_acc (m) / frootn0_xfer_p (m) + AK_veg_nacc ( ilivestem, ilivestem) = - AKX_livestemn_exit_p_acc (m) / livestemn0_p (m) + AK_veg_nacc ( ilivestem_st, ilivestem_st) = - AKX_livestemn_st_exit_p_acc (m) / livestemn0_storage_p (m) + AK_veg_nacc ( ilivestem_xf, ilivestem_xf) = - AKX_livestemn_xf_exit_p_acc (m) / livestemn0_xfer_p (m) + AK_veg_nacc ( ideadstem, ideadstem) = - AKX_deadstemn_exit_p_acc (m) / deadstemn0_p (m) + AK_veg_nacc ( ideadstem_st, ideadstem_st) = - AKX_deadstemn_st_exit_p_acc (m) / deadstemn0_storage_p (m) + AK_veg_nacc ( ideadstem_xf, ideadstem_xf) = - AKX_deadstemn_xf_exit_p_acc (m) / deadstemn0_xfer_p (m) + AK_veg_nacc ( ilivecroot, ilivecroot) = - AKX_livecrootn_exit_p_acc (m) / livecrootn0_p (m) + AK_veg_nacc (ilivecroot_st,ilivecroot_st) = - AKX_livecrootn_st_exit_p_acc (m) / livecrootn0_storage_p(m) + AK_veg_nacc (ilivecroot_xf,ilivecroot_xf) = - AKX_livecrootn_xf_exit_p_acc (m) / livecrootn0_xfer_p (m) + AK_veg_nacc ( ideadcroot, ideadcroot) = - AKX_deadcrootn_exit_p_acc (m) / deadcrootn0_p (m) + AK_veg_nacc (ideadcroot_st,ideadcroot_st) = - AKX_deadcrootn_st_exit_p_acc (m) / deadcrootn0_storage_p(m) + AK_veg_nacc (ideadcroot_xf,ideadcroot_xf) = - AKX_deadcrootn_xf_exit_p_acc (m) / deadcrootn0_xfer_p (m) + AK_veg_nacc ( igrain, igrain) = - AKX_grainn_exit_p_acc (m) / grainn0_p (m) + AK_veg_nacc ( igrain_st, igrain_st) = - AKX_grainn_st_exit_p_acc (m) / grainn0_storage_p (m) + AK_veg_nacc ( igrain_xf, igrain_xf) = - AKX_grainn_xf_exit_p_acc (m) / grainn0_xfer_p (m) + AK_veg_nacc ( iretrans, iretrans) = - AKX_retransn_exit_p_acc (m) / retransn0_p (m) + + I_veg_nacc ( ileaf) = I_leafn_p_acc (m) + I_veg_nacc ( ileaf_st) = I_leafn_st_p_acc (m) + I_veg_nacc ( ifroot) = I_frootn_p_acc (m) + I_veg_nacc ( ifroot_st) = I_frootn_st_p_acc (m) + I_veg_nacc ( ilivestem) = I_livestemn_p_acc (m) + I_veg_nacc ( ilivestem_st) = I_livestemn_st_p_acc (m) + I_veg_nacc ( ideadstem) = I_deadstemn_p_acc (m) + I_veg_nacc ( ideadstem_st) = I_deadstemn_st_p_acc (m) + I_veg_nacc ( ilivecroot) = I_livecrootn_p_acc (m) + I_veg_nacc (ilivecroot_st) = I_livecrootn_st_p_acc (m) + I_veg_nacc ( ideadcroot) = I_deadcrootn_p_acc (m) + I_veg_nacc (ideadcroot_st) = I_deadcrootn_st_p_acc (m) + I_veg_nacc ( igrain) = I_grainn_p_acc (m) + I_veg_nacc ( igrain_st) = I_grainn_st_p_acc (m) + + DO j = 1, nvegc + IF(AK_veg_acc(j,j) .eq. 0)THEN + AK_veg_acc(j,j) = - 1.e+36 + ENDIF + ENDDO + DO j = 1, nvegn + IF(AK_veg_nacc(j,j) .eq. 0)THEN + AK_veg_nacc(j,j) = - 1.e+36 + ENDIF + ENDDO + + ! Calculate capacity + CALL inverse(AK_veg_acc (1:nvegc,1:nvegc),AKinv_veg (1:nvegc,1:nvegc),nvegc) + CALL inverse(AK_veg_nacc(1:nvegn,1:nvegn),AKinvn_veg(1:nvegn,1:nvegn),nvegn) + vegmatrixc_cap(:,1) = -matmul(AKinv_veg (1:nvegc,1:nvegc),I_veg_acc (1:nvegc)) + vegmatrixn_cap(:,1) = -matmul(AKinvn_veg(1:nvegn,1:nvegn),I_veg_nacc(1:nvegn)) + + DO k = 1, nvegc + IF(vegmatrixc_cap(k,1) .lt. 0)THEN + vegmatrixc_cap(k,1) = epsi + ENDIF + ENDDO + DO k = 1, nvegn + IF(vegmatrixn_cap(k,1) .lt. 0)THEN + vegmatrixn_cap(k,1) = epsi + ENDIF + ENDDO + IF(DEF_USE_DiagMatrix)THEN + leafcCap_p (m) = vegmatrixc_cap(ileaf ,1) + leafc_storageCap_p (m) = vegmatrixc_cap(ileaf_st ,1) + leafc_xferCap_p (m) = vegmatrixc_cap(ileaf_xf ,1) + frootcCap_p (m) = vegmatrixc_cap(ifroot ,1) + frootc_storageCap_p (m) = vegmatrixc_cap(ifroot_st ,1) + frootc_xferCap_p (m) = vegmatrixc_cap(ifroot_xf ,1) + livestemcCap_p (m) = vegmatrixc_cap(ilivestem ,1) + livestemc_storageCap_p (m) = vegmatrixc_cap(ilivestem_st ,1) + livestemc_xferCap_p (m) = vegmatrixc_cap(ilivestem_xf ,1) + deadstemcCap_p (m) = vegmatrixc_cap(ideadstem ,1) + deadstemc_storageCap_p (m) = vegmatrixc_cap(ideadstem_st ,1) + deadstemc_xferCap_p (m) = vegmatrixc_cap(ideadstem_xf ,1) + livecrootcCap_p (m) = vegmatrixc_cap(ilivecroot ,1) + livecrootc_storageCap_p (m) = vegmatrixc_cap(ilivecroot_st ,1) + livecrootc_xferCap_p (m) = vegmatrixc_cap(ilivecroot_xf ,1) + deadcrootcCap_p (m) = vegmatrixc_cap(ideadcroot ,1) + deadcrootc_storageCap_p (m) = vegmatrixc_cap(ideadcroot_st ,1) + deadcrootc_xferCap_p (m) = vegmatrixc_cap(ideadcroot_xf ,1) + leafnCap_p (m) = vegmatrixn_cap(ileaf ,1) + leafn_storageCap_p (m) = vegmatrixn_cap(ileaf_st ,1) + leafn_xferCap_p (m) = vegmatrixn_cap(ileaf_xf ,1) + frootnCap_p (m) = vegmatrixn_cap(ifroot ,1) + frootn_storageCap_p (m) = vegmatrixn_cap(ifroot_st ,1) + frootn_xferCap_p (m) = vegmatrixn_cap(ifroot_xf ,1) + livestemnCap_p (m) = vegmatrixn_cap(ilivestem ,1) + livestemn_storageCap_p (m) = vegmatrixn_cap(ilivestem_st ,1) + livestemn_xferCap_p (m) = vegmatrixn_cap(ilivestem_xf ,1) + deadstemnCap_p (m) = vegmatrixn_cap(ideadstem ,1) + deadstemn_storageCap_p (m) = vegmatrixn_cap(ideadstem_st ,1) + deadstemn_xferCap_p (m) = vegmatrixn_cap(ideadstem_xf ,1) + livecrootnCap_p (m) = vegmatrixn_cap(ilivecroot ,1) + livecrootn_storageCap_p (m) = vegmatrixn_cap(ilivecroot_st ,1) + livecrootn_xferCap_p (m) = vegmatrixn_cap(ilivecroot_xf ,1) + deadcrootnCap_p (m) = vegmatrixn_cap(ideadcroot ,1) + deadcrootn_storageCap_p (m) = vegmatrixn_cap(ideadcroot_st ,1) + deadcrootn_xferCap_p (m) = vegmatrixn_cap(ideadcroot_xf ,1) + ENDIF + IF(DEF_USE_SASU)then + deadstemc_p (m) = vegmatrixc_cap(ideadstem,1) + deadstemc_storage_p (m) = vegmatrixc_cap(ideadstem_st,1) + deadcrootc_p (m) = vegmatrixc_cap(ideadcroot,1) + deadcrootc_storage_p(m) = vegmatrixc_cap(ideadcroot_st,1) + deadstemn_p (m) = vegmatrixn_cap(ideadstem,1) + deadstemn_storage_p (m) = vegmatrixn_cap(ideadstem_st,1) + deadcrootn_p (m) = vegmatrixn_cap(ideadcroot,1) + deadcrootn_storage_p(m) = vegmatrixn_cap(ideadcroot_st,1) + ENDIF + ENDDO + + AK_soil_acc (1:ndecomp_pools_vr,1:ndecomp_pools_vr) = 0._r8 + AK_soil_nacc(1:ndecomp_pools_vr,1:ndecomp_pools_vr) = 0._r8 + I_soil_acc (1:ndecomp_pools_vr) = 0._r8 + I_soil_nacc (1:ndecomp_pools_vr) = 0._r8 + DO j=1, nl_soil + ! C EXIT rate + AK_soil_acc ((i_met_lit-1)*nl_soil+j,(i_met_lit-1)*nl_soil+j) & + = - (AKX_met_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_met_lit,i)) / decomp0_cpools_vr(j,i_met_lit,i) + AK_soil_acc ((i_cel_lit-1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j) & + = - (AKX_cel_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_cel_lit,i)) / decomp0_cpools_vr(j,i_cel_lit,i) + AK_soil_acc ((i_lig_lit-1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j) & + = - (AKX_lig_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_lig_lit,i)) / decomp0_cpools_vr(j,i_lig_lit,i) + AK_soil_acc ((i_cwd -1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = - AKX_cwd_exit_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_cwd ,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = - (AKX_soil1_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_soil1,i)) / decomp0_cpools_vr(j,i_soil1 ,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = - (AKX_soil2_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_soil2,i)) / decomp0_cpools_vr(j,i_soil2 ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j) & + = - (AKX_soil3_exit_c_vr_acc(j,i) + diagVX_c_vr_acc(j,i_soil3,i)) / decomp0_cpools_vr(j,i_soil3 ,i) + + ! C transfer + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_met_lit-1)*nl_soil+j) & + = AKX_met_to_soil1_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_met_lit,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j) & + = AKX_cel_to_soil1_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_cel_lit,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j) & + = AKX_lig_to_soil2_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_lig_lit,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = AKX_soil1_to_soil2_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil1 ,i) + AK_soil_acc ((i_cel_lit-1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = AKX_cwd_to_cel_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_cwd ,i) + AK_soil_acc ((i_lig_lit-1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = AKX_cwd_to_lig_c_vr_acc (j,i) / decomp0_cpools_vr(j,i_cwd ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = AKX_soil1_to_soil3_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil1 ,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = AKX_soil2_to_soil1_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil2 ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = AKX_soil2_to_soil3_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil2 ,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j) & + = AKX_soil3_to_soil1_c_vr_acc(j,i) / decomp0_cpools_vr(j,i_soil3 ,i) + + ! C input + I_soil_acc((i_met_lit-1)*nl_soil+j) = I_met_c_vr_acc(j,i) + I_soil_acc((i_cel_lit-1)*nl_soil+j) = I_cel_c_vr_acc(j,i) + I_soil_acc((i_lig_lit-1)*nl_soil+j) = I_lig_c_vr_acc(j,i) + I_soil_acc((i_cwd -1)*nl_soil+j) = I_cwd_c_vr_acc(j,i) + + ! N EXIT rate + AK_soil_nacc((i_met_lit-1)*nl_soil+j,(i_met_lit-1)*nl_soil+j) & + = - (AKX_met_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_met_lit,i)) / decomp0_npools_vr(j,i_met_lit,i) + AK_soil_nacc((i_cel_lit-1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j) & + = - (AKX_cel_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_cel_lit,i)) / decomp0_npools_vr(j,i_cel_lit,i) + AK_soil_nacc((i_lig_lit-1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j) & + = - (AKX_lig_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_lig_lit,i)) / decomp0_npools_vr(j,i_lig_lit,i) + AK_soil_nacc((i_cwd -1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = - AKX_cwd_exit_n_vr_acc(j,i) / decomp0_npools_vr(j,i_cwd ,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = - (AKX_soil1_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_soil1,i)) / decomp0_npools_vr(j,i_soil1 ,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = - (AKX_soil2_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_soil2,i)) / decomp0_npools_vr(j,i_soil2 ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j) & + = - (AKX_soil3_exit_n_vr_acc(j,i) + diagVX_n_vr_acc(j,i_soil3,i)) / decomp0_npools_vr(j,i_soil3 ,i) + + ! N transfer + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_met_lit-1)*nl_soil+j) & + = AKX_met_to_soil1_n_vr_acc (j,i) / decomp0_npools_vr(j,i_met_lit,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j) & + = AKX_cel_to_soil1_n_vr_acc (j,i) / decomp0_npools_vr(j,i_cel_lit,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j) & + = AKX_lig_to_soil2_n_vr_acc (j,i) / decomp0_npools_vr(j,i_lig_lit,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = AKX_soil1_to_soil2_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil1 ,i) + AK_soil_nacc((i_cel_lit-1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = AKX_cwd_to_cel_n_vr_acc (j,i) / decomp0_npools_vr(j,i_cwd ,i) + AK_soil_nacc((i_lig_lit-1)*nl_soil+j,(i_cwd -1)*nl_soil+j) & + = AKX_cwd_to_lig_n_vr_acc (j,i) / decomp0_npools_vr(j,i_cwd ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j) & + = AKX_soil1_to_soil3_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil1 ,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = AKX_soil2_to_soil1_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil2 ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j) & + = AKX_soil2_to_soil3_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil2 ,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j) & + = AKX_soil3_to_soil1_n_vr_acc(j,i) / decomp0_npools_vr(j,i_soil3 ,i) + + ENDDO + + DO j=1,nl_soil-1 + ! upper triadiagnonal entries for C + AK_soil_acc ((i_met_lit-1)*nl_soil+j,(i_met_lit-1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_met_lit,i) / decomp0_cpools_vr(j+1,i_met_lit,i) + AK_soil_acc ((i_cel_lit-1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_cel_lit,i) / decomp0_cpools_vr(j+1,i_cel_lit,i) + AK_soil_acc ((i_lig_lit-1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_lig_lit,i) / decomp0_cpools_vr(j+1,i_lig_lit,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_soil1 ,i) / decomp0_cpools_vr(j+1,i_soil1 ,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_soil2 ,i) / decomp0_cpools_vr(j+1,i_soil2 ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j+1) & + = upperVX_c_vr_acc(j,i_soil3 ,i) / decomp0_cpools_vr(j+1,i_soil3 ,i) + + ! lower triadiagnonal entries for C + AK_soil_acc ((i_met_lit-1)*nl_soil+j+1,(i_met_lit-1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_met_lit,i) / decomp0_cpools_vr(j,i_met_lit,i) + AK_soil_acc ((i_cel_lit-1)*nl_soil+j+1,(i_cel_lit-1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_cel_lit,i) / decomp0_cpools_vr(j,i_cel_lit,i) + AK_soil_acc ((i_lig_lit-1)*nl_soil+j+1,(i_lig_lit-1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_lig_lit,i) / decomp0_cpools_vr(j,i_lig_lit,i) + AK_soil_acc ((i_soil1 -1)*nl_soil+j+1,(i_soil1 -1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_soil1 ,i) / decomp0_cpools_vr(j,i_soil1 ,i) + AK_soil_acc ((i_soil2 -1)*nl_soil+j+1,(i_soil2 -1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_soil2 ,i) / decomp0_cpools_vr(j,i_soil2 ,i) + AK_soil_acc ((i_soil3 -1)*nl_soil+j+1,(i_soil3 -1)*nl_soil+j) & + = lowerVX_c_vr_acc(j+1,i_soil3 ,i) / decomp0_cpools_vr(j,i_soil3 ,i) + + + ! upper triadiagnonal entries for N + AK_soil_nacc((i_met_lit-1)*nl_soil+j,(i_met_lit-1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_met_lit,i) / decomp0_npools_vr(j+1,i_met_lit,i) + AK_soil_nacc((i_cel_lit-1)*nl_soil+j,(i_cel_lit-1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_cel_lit,i) / decomp0_npools_vr(j+1,i_cel_lit,i) + AK_soil_nacc((i_lig_lit-1)*nl_soil+j,(i_lig_lit-1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_lig_lit,i) / decomp0_npools_vr(j+1,i_lig_lit,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j,(i_soil1 -1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_soil1 ,i) / decomp0_npools_vr(j+1,i_soil1 ,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j,(i_soil2 -1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_soil2 ,i) / decomp0_npools_vr(j+1,i_soil2 ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j,(i_soil3 -1)*nl_soil+j+1) & + = upperVX_n_vr_acc(j,i_soil3 ,i) / decomp0_npools_vr(j+1,i_soil3 ,i) + + ! lower triadiagnonal entries for N + AK_soil_nacc((i_met_lit-1)*nl_soil+j+1,(i_met_lit-1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_met_lit,i) / decomp0_npools_vr(j,i_met_lit,i) + AK_soil_nacc((i_cel_lit-1)*nl_soil+j+1,(i_cel_lit-1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_cel_lit,i) / decomp0_npools_vr(j,i_cel_lit,i) + AK_soil_nacc((i_lig_lit-1)*nl_soil+j+1,(i_lig_lit-1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_lig_lit,i) / decomp0_npools_vr(j,i_lig_lit,i) + AK_soil_nacc((i_soil1 -1)*nl_soil+j+1,(i_soil1 -1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_soil1 ,i) / decomp0_npools_vr(j,i_soil1 ,i) + AK_soil_nacc((i_soil2 -1)*nl_soil+j+1,(i_soil2 -1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_soil2 ,i) / decomp0_npools_vr(j,i_soil2 ,i) + AK_soil_nacc((i_soil3 -1)*nl_soil+j+1,(i_soil3 -1)*nl_soil+j) & + = lowerVX_n_vr_acc(j+1,i_soil3 ,i) / decomp0_npools_vr(j,i_soil3 ,i) + + ! N input + I_soil_nacc((i_met_lit-1)*nl_soil+j) = I_met_n_vr_acc(j,i) + I_soil_nacc((i_cel_lit-1)*nl_soil+j) = I_cel_n_vr_acc(j,i) + I_soil_nacc((i_lig_lit-1)*nl_soil+j) = I_lig_n_vr_acc(j,i) + I_soil_nacc((i_cwd -1)*nl_soil+j) = I_cwd_n_vr_acc(j,i) + + ENDDO + + DO k=1,ndecomp_pools_vr + IF (abs(AK_soil_acc(k,k)) .le. epsi)THEN !avoid inversion nan + AK_soil_acc(k,k) = - 1.e+36_r8 + ENDIF + ENDDO + + DO k=1,ndecomp_pools_vr + IF (abs(AK_soil_nacc(k,k)) .le. epsi)THEN + AK_soil_nacc(k,k) = - 1.e+36_r8 + ENDIF + ENDDO + + ! Calculate capacity + CALL inverse(AK_soil_acc (1:ndecomp_pools_vr,1:ndecomp_pools_vr),AKinv_soil (1:ndecomp_pools_vr,1:ndecomp_pools_vr),ndecomp_pools_vr) + CALL inverse(AK_soil_nacc(1:ndecomp_pools_vr,1:ndecomp_pools_vr),AKinvn_soil(1:ndecomp_pools_vr,1:ndecomp_pools_vr),ndecomp_pools_vr) + soilmatrixc_cap(:,1) = -matmul(AKinv_soil(1:ndecomp_pools_vr,1:ndecomp_pools_vr), I_soil_acc (1:ndecomp_pools_vr)) + soilmatrixn_cap(:,1) = -matmul(AKinvn_soil(1:ndecomp_pools_vr,1:ndecomp_pools_vr),I_soil_nacc(1:ndecomp_pools_vr)) + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + IF(soilmatrixc_cap(j+(k-1)*nl_soil,1) .lt. 0)THEN + soilmatrixc_cap(j+(k-1)*nl_soil,1) = 0._r8 + ENDIF + IF(soilmatrixn_cap(j+(k-1)*nl_soil,1) .lt. 0)THEN + soilmatrixn_cap(j+(k-1)*nl_soil,1) = 0._r8 + ENDIF + ENDDO + ENDDO + + IF(DEF_USE_DiagMatrix)THEN + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_cpools_vr_Cap(j,k,i) = soilmatrixc_cap(j+(k-1)*nl_soil,1) + decomp_npools_vr_Cap(j,k,i) = soilmatrixn_cap(j+(k-1)*nl_soil,1) + ENDDO + ENDDO + ENDIF + IF(DEF_USE_SASU)THEN + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + IF((soilmatrixc_cap(j+(k-1)*nl_soil,1)/decomp0_cpools_vr(j,k,i) .gt. 100 .and. soilmatrixc_cap(j+(k-1)*nl_soil,1) .gt. 1.e+5_r8 & + .or. soilmatrixn_cap(j+(k-1)*nl_soil,1)/decomp0_npools_vr(j,k,i) .gt. 100 .and. soilmatrixn_cap(j+(k-1)*nl_soil,1) .gt. 1.e+3_r8) & + .or. k .eq. i_cwd .and. (soilmatrixc_cap(j+(k-1)*nl_soil,1)/decomp0_cpools_vr(j,k,i) .gt. 100 .and. soilmatrixc_cap(j+(k-1)*nl_soil,1) .gt. 1.e+5_r8 & + .or. soilmatrixn_cap(j+(k-1)*nl_soil,1)/decomp0_npools_vr(j,k,i) .gt. 100 .and. soilmatrixn_cap(j+(k-1)*nl_soil,1) .gt. 1.e+3_r8) )THEN + soilmatrixc_cap(j+(k-1)*nl_soil,1) = decomp_cpools_vr(j,k,i) + soilmatrixn_cap(j+(k-1)*nl_soil,1) = decomp_npools_vr(j,k,i) + ENDIF + ENDDO + ENDDO + + IF(any(soilmatrixc_cap(:,1) .gt. 1.e+8_r8) .or. any(soilmatrixn_cap(:,1) .gt. 1.e+8_r8))THEN + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + soilmatrixc_cap(j+(k-1)*nl_soil,1) = decomp_cpools_vr(j,k,i) + soilmatrixn_cap(j+(k-1)*nl_soil,1) = decomp_npools_vr(j,k,i) + ENDDO + ENDDO + ENDIF + + ! IF spin up is on, the capacity replaces the pool size with capacity. + ! Copy the capacity into a 3D variable, and be ready to write to history files. + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_cpools_vr(j,k,i) = soilmatrixc_cap(j+(k-1)*nl_soil,1) + IF(floating_cn_ratio(k))THEN + decomp_npools_vr(j,k,i) = soilmatrixn_cap(j+(k-1)*nl_soil,1) + ELSE + decomp_npools_vr(j,k,i) = decomp_cpools_vr(j,k,i) / cn_decomp_pools(j,k,i) + ENDIF + ENDDO + ENDDO + + skip_balance_check(i) = .true. + ENDIF + + ! Reset to accumulation variables to 0 at END of each year + DO m=ps, pe + I_leafc_p_acc (m) = 0._r8 + I_leafc_st_p_acc (m) = 0._r8 + I_frootc_p_acc (m) = 0._r8 + I_frootc_st_p_acc (m) = 0._r8 + I_livestemc_p_acc (m) = 0._r8 + I_livestemc_st_p_acc (m) = 0._r8 + I_deadstemc_p_acc (m) = 0._r8 + I_deadstemc_st_p_acc (m) = 0._r8 + I_livecrootc_p_acc (m) = 0._r8 + I_livecrootc_st_p_acc(m) = 0._r8 + I_deadcrootc_p_acc (m) = 0._r8 + I_deadcrootc_st_p_acc(m) = 0._r8 + I_grainc_p_acc (m) = 0._r8 + I_grainc_st_p_acc (m) = 0._r8 + I_leafn_p_acc (m) = 0._r8 + I_leafn_st_p_acc (m) = 0._r8 + I_frootn_p_acc (m) = 0._r8 + I_frootn_st_p_acc (m) = 0._r8 + I_livestemn_p_acc (m) = 0._r8 + I_livestemn_st_p_acc (m) = 0._r8 + I_deadstemn_p_acc (m) = 0._r8 + I_deadstemn_st_p_acc (m) = 0._r8 + I_livecrootn_p_acc (m) = 0._r8 + I_livecrootn_st_p_acc(m) = 0._r8 + I_deadcrootn_p_acc (m) = 0._r8 + I_deadcrootn_st_p_acc(m) = 0._r8 + I_grainn_p_acc (m) = 0._r8 + I_grainn_st_p_acc (m) = 0._r8 + + AKX_leafc_xf_to_leafc_p_acc (m) = 0._r8 + AKX_frootc_xf_to_frootc_p_acc (m) = 0._r8 + AKX_livestemc_xf_to_livestemc_p_acc (m) = 0._r8 + AKX_deadstemc_xf_to_deadstemc_p_acc (m) = 0._r8 + AKX_livecrootc_xf_to_livecrootc_p_acc (m) = 0._r8 + AKX_deadcrootc_xf_to_deadcrootc_p_acc (m) = 0._r8 + AKX_grainc_xf_to_grainc_p_acc (m) = 0._r8 + AKX_livestemc_to_deadstemc_p_acc (m) = 0._r8 + AKX_livecrootc_to_deadcrootc_p_acc (m) = 0._r8 + + AKX_leafc_st_to_leafc_xf_p_acc (m) = 0._r8 + AKX_frootc_st_to_frootc_xf_p_acc (m) = 0._r8 + AKX_livestemc_st_to_livestemc_xf_p_acc (m) = 0._r8 + AKX_deadstemc_st_to_deadstemc_xf_p_acc (m) = 0._r8 + AKX_livecrootc_st_to_livecrootc_xf_p_acc(m) = 0._r8 + AKX_deadcrootc_st_to_deadcrootc_xf_p_acc(m) = 0._r8 + AKX_grainc_st_to_grainc_xf_p_acc (m) = 0._r8 + + AKX_leafc_exit_p_acc (m) = 0._r8 + AKX_frootc_exit_p_acc (m) = 0._r8 + AKX_livestemc_exit_p_acc (m) = 0._r8 + AKX_deadstemc_exit_p_acc (m) = 0._r8 + AKX_livecrootc_exit_p_acc (m) = 0._r8 + AKX_deadcrootc_exit_p_acc (m) = 0._r8 + AKX_grainc_exit_p_acc (m) = 0._r8 + + AKX_leafc_st_exit_p_acc (m) = 0._r8 + AKX_frootc_st_exit_p_acc (m) = 0._r8 + AKX_livestemc_st_exit_p_acc (m) = 0._r8 + AKX_deadstemc_st_exit_p_acc (m) = 0._r8 + AKX_livecrootc_st_exit_p_acc (m) = 0._r8 + AKX_deadcrootc_st_exit_p_acc (m) = 0._r8 + AKX_grainc_st_exit_p_acc (m) = 0._r8 + + AKX_leafc_xf_exit_p_acc (m) = 0._r8 + AKX_frootc_xf_exit_p_acc (m) = 0._r8 + AKX_livestemc_xf_exit_p_acc (m) = 0._r8 + AKX_deadstemc_xf_exit_p_acc (m) = 0._r8 + AKX_livecrootc_xf_exit_p_acc (m) = 0._r8 + AKX_deadcrootc_xf_exit_p_acc (m) = 0._r8 + AKX_grainc_xf_exit_p_acc (m) = 0._r8 + + AKX_leafn_xf_to_leafn_p_acc (m) = 0._r8 + AKX_frootn_xf_to_frootn_p_acc (m) = 0._r8 + AKX_livestemn_xf_to_livestemn_p_acc (m) = 0._r8 + AKX_deadstemn_xf_to_deadstemn_p_acc (m) = 0._r8 + AKX_livecrootn_xf_to_livecrootn_p_acc (m) = 0._r8 + AKX_deadcrootn_xf_to_deadcrootn_p_acc (m) = 0._r8 + AKX_grainn_xf_to_grainn_p_acc (m) = 0._r8 + AKX_livestemn_to_deadstemn_p_acc (m) = 0._r8 + AKX_livecrootn_to_deadcrootn_p_acc (m) = 0._r8 + + AKX_leafn_st_to_leafn_xf_p_acc (m) = 0._r8 + AKX_frootn_st_to_frootn_xf_p_acc (m) = 0._r8 + AKX_livestemn_st_to_livestemn_xf_p_acc (m) = 0._r8 + AKX_deadstemn_st_to_deadstemn_xf_p_acc (m) = 0._r8 + AKX_livecrootn_st_to_livecrootn_xf_p_acc(m) = 0._r8 + AKX_deadcrootn_st_to_deadcrootn_xf_p_acc(m) = 0._r8 + AKX_grainn_st_to_grainn_xf_p_acc (m) = 0._r8 + + AKX_leafn_to_retransn_p_acc (m) = 0._r8 + AKX_frootn_to_retransn_p_acc (m) = 0._r8 + AKX_livestemn_to_retransn_p_acc (m) = 0._r8 + AKX_livecrootn_to_retransn_p_acc (m) = 0._r8 + + AKX_retransn_to_leafn_p_acc (m) = 0._r8 + AKX_retransn_to_frootn_p_acc (m) = 0._r8 + AKX_retransn_to_livestemn_p_acc (m) = 0._r8 + AKX_retransn_to_deadstemn_p_acc (m) = 0._r8 + AKX_retransn_to_livecrootn_p_acc (m) = 0._r8 + AKX_retransn_to_deadcrootn_p_acc (m) = 0._r8 + AKX_retransn_to_grainn_p_acc (m) = 0._r8 + + AKX_retransn_to_leafn_st_p_acc (m) = 0._r8 + AKX_retransn_to_frootn_st_p_acc (m) = 0._r8 + AKX_retransn_to_livestemn_st_p_acc (m) = 0._r8 + AKX_retransn_to_deadstemn_st_p_acc (m) = 0._r8 + AKX_retransn_to_livecrootn_st_p_acc (m) = 0._r8 + AKX_retransn_to_deadcrootn_st_p_acc (m) = 0._r8 + AKX_retransn_to_grainn_st_p_acc (m) = 0._r8 + + AKX_leafn_exit_p_acc (m) = 0._r8 + AKX_frootn_exit_p_acc (m) = 0._r8 + AKX_livestemn_exit_p_acc (m) = 0._r8 + AKX_deadstemn_exit_p_acc (m) = 0._r8 + AKX_livecrootn_exit_p_acc (m) = 0._r8 + AKX_deadcrootn_exit_p_acc (m) = 0._r8 + AKX_grainn_exit_p_acc (m) = 0._r8 + AKX_retransn_exit_p_acc (m) = 0._r8 + + AKX_leafn_st_exit_p_acc (m) = 0._r8 + AKX_frootn_st_exit_p_acc (m) = 0._r8 + AKX_livestemn_st_exit_p_acc (m) = 0._r8 + AKX_deadstemn_st_exit_p_acc (m) = 0._r8 + AKX_livecrootn_st_exit_p_acc (m) = 0._r8 + AKX_deadcrootn_st_exit_p_acc (m) = 0._r8 + AKX_grainn_st_exit_p_acc (m) = 0._r8 + + AKX_leafn_xf_exit_p_acc (m) = 0._r8 + AKX_frootn_xf_exit_p_acc (m) = 0._r8 + AKX_livestemn_xf_exit_p_acc (m) = 0._r8 + AKX_deadstemn_xf_exit_p_acc (m) = 0._r8 + AKX_livecrootn_xf_exit_p_acc (m) = 0._r8 + AKX_deadcrootn_xf_exit_p_acc (m) = 0._r8 + AKX_grainn_xf_exit_p_acc (m) = 0._r8 + ENDDO + + DO j=1,nl_soil + AKX_met_exit_c_vr_acc (j,i) = 0._r8 + AKX_cel_exit_c_vr_acc (j,i) = 0._r8 + AKX_lig_exit_c_vr_acc (j,i) = 0._r8 + AKX_cwd_exit_c_vr_acc (j,i) = 0._r8 + AKX_soil1_exit_c_vr_acc (j,i) = 0._r8 + AKX_soil2_exit_c_vr_acc (j,i) = 0._r8 + AKX_soil3_exit_c_vr_acc (j,i) = 0._r8 + + AKX_met_to_soil1_c_vr_acc (j,i) = 0._r8 + AKX_cel_to_soil1_c_vr_acc (j,i) = 0._r8 + AKX_lig_to_soil2_c_vr_acc (j,i) = 0._r8 + AKX_soil1_to_soil2_c_vr_acc(j,i) = 0._r8 + AKX_cwd_to_cel_c_vr_acc (j,i) = 0._r8 + AKX_cwd_to_lig_c_vr_acc (j,i) = 0._r8 + AKX_soil1_to_soil3_c_vr_acc(j,i) = 0._r8 + AKX_soil2_to_soil1_c_vr_acc(j,i) = 0._r8 + AKX_soil2_to_soil3_c_vr_acc(j,i) = 0._r8 + AKX_soil3_to_soil1_c_vr_acc(j,i) = 0._r8 + + diagVX_c_vr_acc (j,i_met_lit,i) = 0._r8 + diagVX_c_vr_acc (j,i_cel_lit,i) = 0._r8 + diagVX_c_vr_acc (j,i_lig_lit,i) = 0._r8 + diagVX_c_vr_acc (j,i_cwd ,i) = 0._r8 + diagVX_c_vr_acc (j,i_soil1 ,i) = 0._r8 + diagVX_c_vr_acc (j,i_soil2 ,i) = 0._r8 + diagVX_c_vr_acc (j,i_soil3 ,i) = 0._r8 + + upperVX_c_vr_acc (j,i_met_lit,i) = 0._r8 + upperVX_c_vr_acc (j,i_cel_lit,i) = 0._r8 + upperVX_c_vr_acc (j,i_lig_lit,i) = 0._r8 + upperVX_c_vr_acc (j,i_cwd ,i) = 0._r8 + upperVX_c_vr_acc (j,i_soil1 ,i) = 0._r8 + upperVX_c_vr_acc (j,i_soil2 ,i) = 0._r8 + upperVX_c_vr_acc (j,i_soil3 ,i) = 0._r8 + + lowerVX_c_vr_acc (j,i_met_lit,i) = 0._r8 + lowerVX_c_vr_acc (j,i_cel_lit,i) = 0._r8 + lowerVX_c_vr_acc (j,i_lig_lit,i) = 0._r8 + lowerVX_c_vr_acc (j,i_cwd ,i) = 0._r8 + lowerVX_c_vr_acc (j,i_soil1 ,i) = 0._r8 + lowerVX_c_vr_acc (j,i_soil2 ,i) = 0._r8 + lowerVX_c_vr_acc (j,i_soil3 ,i) = 0._r8 + + AKX_met_exit_n_vr_acc (j,i) = 0._r8 + AKX_cel_exit_n_vr_acc (j,i) = 0._r8 + AKX_lig_exit_n_vr_acc (j,i) = 0._r8 + AKX_cwd_exit_n_vr_acc (j,i) = 0._r8 + AKX_soil1_exit_n_vr_acc (j,i) = 0._r8 + AKX_soil2_exit_n_vr_acc (j,i) = 0._r8 + AKX_soil3_exit_n_vr_acc (j,i) = 0._r8 + + AKX_met_to_soil1_n_vr_acc (j,i) = 0._r8 + AKX_cel_to_soil1_n_vr_acc (j,i) = 0._r8 + AKX_lig_to_soil2_n_vr_acc (j,i) = 0._r8 + AKX_soil1_to_soil2_n_vr_acc(j,i) = 0._r8 + AKX_cwd_to_cel_n_vr_acc (j,i) = 0._r8 + AKX_cwd_to_lig_n_vr_acc (j,i) = 0._r8 + AKX_soil1_to_soil3_n_vr_acc(j,i) = 0._r8 + AKX_soil2_to_soil1_n_vr_acc(j,i) = 0._r8 + AKX_soil2_to_soil3_n_vr_acc(j,i) = 0._r8 + AKX_soil3_to_soil1_n_vr_acc(j,i) = 0._r8 + + diagVX_n_vr_acc (j,i_met_lit,i) = 0._r8 + diagVX_n_vr_acc (j,i_cel_lit,i) = 0._r8 + diagVX_n_vr_acc (j,i_lig_lit,i) = 0._r8 + diagVX_n_vr_acc (j,i_cwd ,i) = 0._r8 + diagVX_n_vr_acc (j,i_soil1 ,i) = 0._r8 + diagVX_n_vr_acc (j,i_soil2 ,i) = 0._r8 + diagVX_n_vr_acc (j,i_soil3 ,i) = 0._r8 + + upperVX_n_vr_acc (j,i_met_lit,i) = 0._r8 + upperVX_n_vr_acc (j,i_cel_lit,i) = 0._r8 + upperVX_n_vr_acc (j,i_lig_lit,i) = 0._r8 + upperVX_n_vr_acc (j,i_cwd ,i) = 0._r8 + upperVX_n_vr_acc (j,i_soil1 ,i) = 0._r8 + upperVX_n_vr_acc (j,i_soil2 ,i) = 0._r8 + upperVX_n_vr_acc (j,i_soil3 ,i) = 0._r8 + + lowerVX_n_vr_acc (j,i_met_lit,i) = 0._r8 + lowerVX_n_vr_acc (j,i_cel_lit,i) = 0._r8 + lowerVX_n_vr_acc (j,i_lig_lit,i) = 0._r8 + lowerVX_n_vr_acc (j,i_cwd ,i) = 0._r8 + lowerVX_n_vr_acc (j,i_soil1 ,i) = 0._r8 + lowerVX_n_vr_acc (j,i_soil2 ,i) = 0._r8 + lowerVX_n_vr_acc (j,i_soil3 ,i) = 0._r8 + + I_met_c_vr_acc(j,i) = 0._r8 + I_cel_c_vr_acc(j,i) = 0._r8 + I_lig_c_vr_acc(j,i) = 0._r8 + I_cwd_c_vr_acc(j,i) = 0._r8 + + I_met_n_vr_acc(j,i) = 0._r8 + I_cel_n_vr_acc(j,i) = 0._r8 + I_lig_n_vr_acc(j,i) = 0._r8 + I_cwd_n_vr_acc(j,i) = 0._r8 + ENDDO + ENDIF + + END SUBROUTINE CNSASU + + SUBROUTINE inverse(a,c,n) + + ! !DESCRIPTION: + ! Inverse matrix + ! Method: Based on Doolittle LU factorization for Ax=b + ! Alex G. December 2009 + !----------------------------------------------------------- + ! input ... + ! a(n,n) - array of coefficients for matrix A + ! n - dimension + ! output ... + ! c(n,n) - inverse matrix of A + ! comments ... + ! the original matrix a(n,n) will be destroyed + ! during the calculation + + IMPLICIT NONE + ! Arguments + integer,intent(in) :: n ! Size of matrix + real(r8),intent(in) :: a(:,:) ! Input matrix to fine the inverse of + real(r8),intent(out) :: c(:,:) ! Output inverse + ! Local variables + real(r8) :: L(n,n) ! matrix of the elimination coefficient + real(r8) :: U(n,n) ! Upper triangular part of input matrix A + real(r8) :: aa(n,n) ! Temporary equal to input matrix a + real(r8) :: b(n) ! Temporary vector + real(r8) :: d(n) ! Temporary vector (solution of L*d) + real(r8) :: x(n) ! Temporary vector (U*x = d) + real(r8) :: coeff ! coefficient + integer i, j, k ! Indices + character(len=*), parameter :: subname = 'inverse' + + DO k=1,n + IF ( a(k,k) == 0.0_r8 )THEN + CALL CoLM_stop('BGC SASU matrix is singular.') + ENDIF + ENDDO + ! + ! step 0: initialization for matrices L and U and b + ! Fortran 90/95 aloows such operations on matrices + ! + L=0.0 + U=0.0 + b=0.0 + + aa=a + ! + ! Step 1: forward elimination + ! + DO k=1, n-1 + DO i=k+1,n + ! Already verifieid that divisor isn't zero + coeff=aa(i,k)/aa(k,k) + L(i,k) = coeff + DO j=k+1,n + aa(i,j) = aa(i,j)-coeff*aa(k,j) + ENDDO + ENDDO + ENDDO + + ! + ! Step 2: prepare L and U matrices + ! L matrix is a matrix of the elimination coefficient + ! + the diagonal elements are 1.0 + ! + DO i=1,n + L(i,i) = 1.0 + ENDDO + ! + ! U matrix is the upper triangular part of A + ! + DO j=1,n + DO i=1,j + U(i,j) = aa(i,j) + ENDDO + ENDDO + ! + ! Step 3: compute columns of the inverse matrix C + ! + DO k=1,n + b(k)=1.0 + d(1) = b(1) + ! Step 3a: Solve Ld=b using the forward substitution + DO i=2,n + d(i)=b(i) + DO j=1,i-1 + d(i) = d(i) - L(i,j)*d(j) + ENDDO + ENDDO + ! Step 3b: Solve Ux=d using the back substitution + x(n)=d(n)/U(n,n) + DO i = n-1,1,-1 + x(i) = d(i) + DO j=n,i+1,-1 + x(i)=x(i)-U(i,j)*x(j) + ENDDO + ! Already verifieid that divisor isn't zero + x(i) = x(i)/u(i,i) + ENDDO + ! Step 3c: fill the solutions x(n) into column k of C + DO i=1,n + c(i,k) = x(i) + ENDDO + b(k)=0.0 + ENDDO + + END SUBROUTINE inverse + +END MODULE MOD_BGC_CNSASU + +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 new file mode 100644 index 0000000000..78227a6b84 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSummary.F90 @@ -0,0 +1,919 @@ +#include +#ifdef BGC +MODULE MOD_BGC_CNSummary + +!------------------------------------------------------------------------------------------ +! !DESCRIPTION: +! bgc_CNSummaryMod calculates following statistics: +! 1) total CN fluxes and pool sizes from individual contribution of each pool. +! 2) aggregate the PFT-level fluxes and pool sizes into Column-level fluxes and pool sizes. +! 3) PFT-level leaf pool sizes, GPP and crop production. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF, DEF_USE_DiagMatrix + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_Vars_PFTimeVariables, only:irrig_method_p, lai_p + USE MOD_Vars_TimeInvariants, only: BD_all + USE MOD_BGC_Vars_TimeVariables, only: & + totlitc, totsomc, totcwdc, decomp_cpools, decomp_cpools_vr, ctrunc_soil,ctrunc_veg, ctrunc_vr, & + totlitn, totsomn, totcwdn, decomp_npools, decomp_npools_vr, ntrunc_soil,ntrunc_veg, ntrunc_vr, & + totvegc, totvegn, totcolc, totcoln, sminn, sminn_vr, totsoiln_vr, & + leafc, frootc, livestemc, deadstemc, livecrootc, deadcrootc, leafc_storage, frootc_storage, livestemc_storage, & + deadstemc_storage, livecrootc_storage, deadcrootc_storage, leafc_xfer, frootc_xfer, livestemc_xfer, & + deadstemc_xfer, livecrootc_xfer, deadcrootc_xfer, xsmrpool, & + leafcCap, frootcCap, livestemcCap, deadstemcCap, livecrootcCap, deadcrootcCap, leafc_storageCap, frootc_storageCap, & + livestemc_storageCap, deadstemc_storageCap, livecrootc_storageCap, deadcrootc_storageCap, leafc_xferCap, & + frootc_xferCap, livestemc_xferCap, deadstemc_xferCap, livecrootc_xferCap, deadcrootc_xferCap, & +#ifdef CROP + grainc, grainc_storage, grainc_xfer, & + cropseedc_deficit, cropprod1c, cphase, hui, vf, gddplant, gddmaturity, & + manunitro, fertnitro_corn, fertnitro_swheat, fertnitro_wwheat, fertnitro_soybean, & + fertnitro_cotton, fertnitro_rice1, fertnitro_rice2, fertnitro_sugarcane, & + grainn, grainn_storage, grainn_xfer, plantdate, & +#endif + leafn, frootn, livestemn, deadstemn, livecrootn, deadcrootn, leafn_storage, frootn_storage, livestemn_storage, & + deadstemn_storage, livecrootn_storage, deadcrootn_storage, leafn_xfer, frootn_xfer, livestemn_xfer, & + deadstemn_xfer, livecrootn_xfer, deadcrootn_xfer, retransn, downreg, lag_npp, & + leafnCap, frootnCap, livestemnCap, deadstemnCap, livecrootnCap, deadcrootnCap, leafn_storageCap, frootn_storageCap, & + livestemn_storageCap, deadstemn_storageCap, livecrootn_storageCap, deadcrootn_storageCap, leafn_xferCap, & + frootn_xferCap, livestemn_xferCap, deadstemn_xferCap, livecrootn_xferCap, deadcrootn_xferCap + USE MOD_BGC_Vars_TimeInvariants, only: & + is_litter, is_soil, is_cwd, nfix_timeconst + USE MOD_BGC_Vars_PFTimeVariables, only: & + leafc_p, frootc_p, livestemc_p, deadstemc_p, livecrootc_p, deadcrootc_p, & + leafc_storage_p, frootc_storage_p, livestemc_storage_p, & + deadstemc_storage_p, livecrootc_storage_p, deadcrootc_storage_p, gresp_storage_p, & + leafc_xfer_p, frootc_xfer_p, livestemc_xfer_p, & + deadstemc_xfer_p, livecrootc_xfer_p, deadcrootc_xfer_p, gresp_xfer_p, xsmrpool_p, & + leafcCap_p, frootcCap_p, livestemcCap_p, deadstemcCap_p, livecrootcCap_p, deadcrootcCap_p, & + leafc_storageCap_p, frootc_storageCap_p, livestemc_storageCap_p, & + deadstemc_storageCap_p, livecrootc_storageCap_p, deadcrootc_storageCap_p, & + leafc_xferCap_p, frootc_xferCap_p, livestemc_xferCap_p, & + deadstemc_xferCap_p, livecrootc_xferCap_p, deadcrootc_xferCap_p, & +#ifdef CROP + grainc_p, grainc_storage_p, grainc_xfer_p, & +#endif + ctrunc_p, totvegc_p, & + cropseedc_deficit_p, cropprod1c_p, cpool_p, & +#ifdef CROP + plantdate_p, cphase_p, manunitro_p, fertnitro_p, hui_p, gddmaturity_p, gddplant_p, vf_p, & + grainn_p, grainn_storage_p, grainn_xfer_p, cropseedn_deficit_p, & +#endif + leafn_p, frootn_p, livestemn_p, deadstemn_p, livecrootn_p, deadcrootn_p, & + leafn_storage_p, frootn_storage_p, livestemn_storage_p, & + deadstemn_storage_p, livecrootn_storage_p, deadcrootn_storage_p, & + leafn_xfer_p, frootn_xfer_p, livestemn_xfer_p, & + deadstemn_xfer_p, livecrootn_xfer_p, deadcrootn_xfer_p, retransn_p, npool_p, & + leafnCap_p, frootnCap_p, livestemnCap_p, deadstemnCap_p, livecrootnCap_p, deadcrootnCap_p, & + leafn_storageCap_p, frootn_storageCap_p, livestemn_storageCap_p, & + deadstemn_storageCap_p, livecrootn_storageCap_p, deadcrootn_storageCap_p, & + leafn_xferCap_p, frootn_xferCap_p, livestemn_xferCap_p, & + deadstemn_xferCap_p, livecrootn_xferCap_p, deadcrootn_xferCap_p, & + ntrunc_p, totvegn_p, downreg_p + USE MOD_Vars_PFTimeInvariants, only: pftfrac + USE MOD_BGC_Vars_1DFluxes, only: & + gpp_enftemp, gpp_enfboreal, gpp_dnfboreal, gpp_ebftrop, gpp_ebftemp, gpp_dbftrop, gpp_dbftemp, & + gpp_dbfboreal, gpp_ebstemp, gpp_dbstemp, gpp_dbsboreal, gpp_c3arcgrass, gpp_c3grass, gpp_c4grass, & + leafc_enftemp, leafc_enfboreal, leafc_dnfboreal, leafc_ebftrop, leafc_ebftemp, leafc_dbftrop, leafc_dbftemp, & + leafc_dbfboreal, leafc_ebstemp, leafc_dbstemp, leafc_dbsboreal, leafc_c3arcgrass, leafc_c3grass, leafc_c4grass, & + decomp_hr, decomp_hr_vr, gpp, ar, er, supplement_to_sminn, supplement_to_sminn_vr, & + npp_enftemp, npp_enfboreal, npp_dnfboreal, npp_ebftrop, npp_ebftemp, npp_dbftrop, npp_dbftemp, & + npp_dbfboreal, npp_ebstemp, npp_dbstemp, npp_dbsboreal, npp_c3arcgrass, npp_c3grass, npp_c4grass, & + npptoleafc_enftemp, npptoleafc_enfboreal, npptoleafc_dnfboreal, npptoleafc_ebftrop, & + npptoleafc_ebftemp, npptoleafc_dbftrop, npptoleafc_dbftemp, npptoleafc_dbfboreal, npptoleafc_ebstemp, & + npptoleafc_dbstemp, npptoleafc_dbsboreal, npptoleafc_c3arcgrass, npptoleafc_c3grass, npptoleafc_c4grass, & +#ifdef CROP + cropprod1c_loss, grainc_to_cropprodc, grainc_to_seed, grainn_to_cropprodn, & +#endif + sminn_leached, sminn_leached_vr, smin_no3_leached, smin_no3_leached_vr, smin_no3_runoff, smin_no3_runoff_vr, & + f_n2o_nit, f_n2o_nit_vr, decomp_cpools_transport_tendency, decomp_npools_transport_tendency, & + denit, f_denit_vr, fire_closs, hrv_xsmrpool_to_atm, som_c_leached, som_n_leached, sminn_to_denit_excess_vr, & + sminn_to_denit_decomp_vr + USE MOD_BGC_Vars_1DPFTFluxes, only: & + psn_to_cpool_p, leaf_mr_p, froot_mr_p, livestem_mr_p, livecroot_mr_p, & + cpool_leaf_gr_p, cpool_froot_gr_p, cpool_livestem_gr_p, cpool_deadstem_gr_p, & + cpool_livecroot_gr_p, cpool_deadcroot_gr_p, transfer_leaf_gr_p, transfer_froot_gr_p, & + transfer_livestem_gr_p, transfer_deadstem_gr_p, & + transfer_livecroot_gr_p, transfer_deadcroot_gr_p, & + cpool_leaf_storage_gr_p, cpool_froot_storage_gr_p, & + cpool_livestem_storage_gr_p, cpool_deadstem_storage_gr_p, & + cpool_livecroot_storage_gr_p, cpool_deadcroot_storage_gr_p, & + grain_mr_p, xsmrpool_to_atm_p, cpool_grain_gr_p, & + transfer_grain_gr_p, cpool_grain_storage_gr_p, soil_change_p, & + fire_closs_p, hrv_xsmrpool_to_atm_p, & + cpool_to_leafc_p, cpool_to_leafc_storage_p, & +#ifdef CROP + cropprod1c_loss_p, grainc_to_seed_p, grainc_to_food_p, grainn_to_food_p, & +#endif + m_leafc_to_fire_p, m_leafc_storage_to_fire_p, m_leafc_xfer_to_fire_p, & + m_frootc_to_fire_p, m_frootc_storage_to_fire_p, m_frootc_xfer_to_fire_p, & + m_livestemc_to_fire_p, m_livestemc_storage_to_fire_p, m_livestemc_xfer_to_fire_p, & + m_deadstemc_to_fire_p, m_deadstemc_storage_to_fire_p, m_deadstemc_xfer_to_fire_p, & + m_livecrootc_to_fire_p, m_livecrootc_storage_to_fire_p, m_livecrootc_xfer_to_fire_p, & + m_deadcrootc_to_fire_p, m_deadcrootc_storage_to_fire_p, m_deadcrootc_xfer_to_fire_p, & + m_gresp_storage_to_fire_p, m_gresp_xfer_to_fire_p + USE MOD_Vars_TimeVariables, only: & + irrig_method_corn , irrig_method_swheat, irrig_method_wwheat, irrig_method_soybean , & + irrig_method_cotton, irrig_method_rice1 , irrig_method_rice2 , irrig_method_sugarcane, & + lai_enftemp, lai_enfboreal, lai_dnfboreal, lai_ebftrop, lai_ebftemp, lai_dbftrop, lai_dbftemp, & + lai_dbfboreal, lai_ebstemp, lai_dbstemp, lai_dbsboreal, lai_c3arcgrass, lai_c3grass, lai_c4grass + + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_Vars_Global, only: spval + USE MOD_MPAS_MPI + + IMPLICIT NONE + + PUBLIC CNDriverSummarizeStates + PUBLIC CNDriverSummarizeFluxes + + PRIVATE soilbiogeochem_carbonstate_summary + PRIVATE soilbiogeochem_nitrogenstate_summary + PRIVATE cnveg_carbonstate_summary + PRIVATE cnveg_nitrogenstate_summary + PRIVATE soilbiogeochem_carbonflux_summary + PRIVATE soilbiogeochem_nitrogenflux_summary + PRIVATE cnveg_carbonflux_summary + PRIVATE cnveg_nitrogenflux_summary + +CONTAINS + + SUBROUTINE CNDriverSummarizeStates(i,ps,pe,nl_soil,dz_soi,ndecomp_pools,init) + +! !DESCRIPTION: +! summarizes CN state varaibles for veg and soil. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + integer, intent(in) :: nl_soil ! number of total soil + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_pools ! number of total soil & litter pools + logical, intent(in) :: init + + CALL soilbiogeochem_carbonstate_summary(i,nl_soil,dz_soi,ndecomp_pools) + CALL soilbiogeochem_nitrogenstate_summary(i,nl_soil,dz_soi,ndecomp_pools) + + CALL cnveg_carbonstate_summary(i,ps,pe,init) + CALL cnveg_nitrogenstate_summary(i,ps,pe) + + END SUBROUTINE CNDriverSummarizeStates + + SUBROUTINE CNDriverSummarizeFluxes(i,ps,pe,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools,deltim) + +! !DESCRIPTION: +! summarizes CN flux varaibles for veg and soil. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + integer, intent(in) :: ndecomp_pools ! number of tootal soil & litter pools + real(r8),intent(in) :: deltim ! time step in seconds + + CALL soilbiogeochem_carbonflux_summary(i,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools) + + CALL soilbiogeochem_nitrogenflux_summary(i,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools) + + CALL cnveg_carbonflux_summary(i,ps,pe,deltim) + + CALL cnveg_nitrogenflux_summary(i,ps,pe) + + END SUBROUTINE CNDriverSummarizeFluxes + + SUBROUTINE soilbiogeochem_carbonstate_summary(i,nl_soil,dz_soi, ndecomp_pools) + +! !DESCRIPTION +! summarizes soil C state varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_pools ! number of tootal soil & litter pools + + integer :: l,j + + totsomc(i) = 0._r8 + totlitc(i) = 0._r8 + totcwdc(i) = 0._r8 + ctrunc_soil(i) = 0._r8 + + DO l = 1, ndecomp_pools + decomp_cpools(l,i) = 0._r8 + DO j = 1, nl_soil + decomp_cpools(l,i) = decomp_cpools(l,i) + decomp_cpools_vr(j,l,i) * dz_soi(j) + ENDDO + ENDDO + + DO l = 1, ndecomp_pools + IF(is_litter(l))THEN + totlitc(i) = totlitc(i) + decomp_cpools(l,i) + ENDIF + IF(is_soil(l))THEN + totsomc(i) = totsomc(i) + decomp_cpools(l,i) + ENDIF + IF(is_cwd(l))THEN + totcwdc(i) = totcwdc(i) + decomp_cpools(l,i) + ENDIF + ENDDO + + DO j = 1, nl_soil + ctrunc_soil(i) = ctrunc_soil(i) + ctrunc_vr(j,i) * dz_soi(j) + ENDDO + + END SUBROUTINE soilbiogeochem_carbonstate_summary + + SUBROUTINE soilbiogeochem_nitrogenstate_summary(i,nl_soil,dz_soi,ndecomp_pools) + +! !DESCRIPTION +! summarizes soil N state varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_pools ! number of tootal soil & litter pools + + integer :: l,j + + totsomn(i) = 0._r8 + totlitn(i) = 0._r8 + totcwdn(i) = 0._r8 + sminn(i) = 0._r8 + ntrunc_soil(i) = 0._r8 + totsoiln_vr(1:nl_soil,i) = 0 ! soil total nitrogen (gN/gsoil * 100%) + + DO l = 1, ndecomp_pools + decomp_npools(l,i) = 0._r8 + DO j = 1, nl_soil + decomp_npools(l,i) = decomp_npools(l,i) + decomp_npools_vr(j,l,i) * dz_soi(j) + totsoiln_vr(j,i) = totsoiln_vr(j,i) + decomp_npools_vr(j,l,i) / (BD_all(j,i) * 1000) * 100 !(unit %) + ENDDO + ENDDO + + DO j = 1, nl_soil + sminn(i) = sminn(i) + sminn_vr(j,i) * dz_soi(j) + totsoiln_vr(j,i) = totsoiln_vr(j,i) + sminn_vr(j,i) / (BD_all(j,i) * 1000) * 100 !(unit %) + ENDDO + + DO l = 1, ndecomp_pools + IF(is_litter(l))THEN + totlitn(i) = totlitn(i) + decomp_npools(l,i) + ENDIF + IF(is_soil(l))THEN + totsomn(i) = totsomn(i) + decomp_npools(l,i) + ENDIF + IF(is_cwd(l))THEN + totcwdn(i) = totcwdn(i) + decomp_npools(l,i) + ENDIF + ENDDO + + DO j = 1, nl_soil + ntrunc_soil(i) = ntrunc_soil(i) + ntrunc_vr(j,i) * dz_soi(j) + ENDDO + + END SUBROUTINE soilbiogeochem_nitrogenstate_summary + + SUBROUTINE cnveg_carbonstate_summary(i,ps,pe,init) + +! !DESCRIPTION +! summarizes vegetation C state varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + logical, intent(in) :: init + + integer m + + leafc(i) = sum(leafc_p(ps:pe) * pftfrac(ps:pe)) + leafc_storage(i) = sum(leafc_storage_p(ps:pe) * pftfrac(ps:pe)) + leafc_xfer(i) = sum(leafc_xfer_p(ps:pe) * pftfrac(ps:pe)) + frootc(i) = sum(frootc_p(ps:pe) * pftfrac(ps:pe)) + frootc_storage(i) = sum(frootc_storage_p(ps:pe) * pftfrac(ps:pe)) + frootc_xfer(i) = sum(frootc_xfer_p(ps:pe) * pftfrac(ps:pe)) + livestemc(i) = sum(livestemc_p(ps:pe) * pftfrac(ps:pe)) + livestemc_storage(i) = sum(livestemc_storage_p(ps:pe) * pftfrac(ps:pe)) + livestemc_xfer(i) = sum(livestemc_xfer_p(ps:pe) * pftfrac(ps:pe)) + deadstemc(i) = sum(deadstemc_p(ps:pe) * pftfrac(ps:pe)) + deadstemc_storage(i) = sum(deadstemc_storage_p(ps:pe) * pftfrac(ps:pe)) + deadstemc_xfer(i) = sum(deadstemc_xfer_p(ps:pe) * pftfrac(ps:pe)) + livecrootc(i) = sum(livecrootc_p(ps:pe) * pftfrac(ps:pe)) + livecrootc_storage(i) = sum(livecrootc_storage_p(ps:pe) * pftfrac(ps:pe)) + livecrootc_xfer(i) = sum(livecrootc_xfer_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc(i) = sum(deadcrootc_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc_storage(i) = sum(deadcrootc_storage_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc_xfer(i) = sum(deadcrootc_xfer_p(ps:pe) * pftfrac(ps:pe)) + xsmrpool(i) = sum(xsmrpool_p(ps:pe) * pftfrac(ps:pe)) +#ifdef CROP + grainc(i) = sum(grainc_p(ps:pe) * pftfrac(ps:pe)) + grainc_storage(i) = sum(grainc_storage_p(ps:pe) * pftfrac(ps:pe)) + grainc_xfer(i) = sum(grainc_xfer_p(ps:pe) * pftfrac(ps:pe)) + cropseedc_deficit(i) = sum(cropseedc_deficit_p(ps:pe) * pftfrac(ps:pe)) + cropprod1c(i) = sum(cropprod1c_p(ps:pe) * pftfrac(ps:pe)) + cphase(i) = sum(cphase_p(ps:pe) * pftfrac(ps:pe)) + hui(i) = hui_p(ps) + gddplant(i) = sum(gddplant_p(ps:pe) * pftfrac(ps:pe)) + gddmaturity(i) = sum(gddmaturity_p(ps:pe) * pftfrac(ps:pe)) + vf(i) = sum(vf_p(ps:pe) * pftfrac(ps:pe)) + + fertnitro_corn(i) = 0._r8 + fertnitro_swheat(i) = 0._r8 + fertnitro_wwheat(i) = 0._r8 + fertnitro_soybean(i) = 0._r8 + fertnitro_cotton(i) = 0._r8 + fertnitro_rice1(i) = 0._r8 + fertnitro_rice2(i) = 0._r8 + fertnitro_sugarcane(i)= 0._r8 + + manunitro(i) = sum(manunitro_p(ps:pe) * pftfrac(ps:pe)) + +#endif + IF(DEF_USE_DiagMatrix)THEN + leafcCap(i) = sum(leafcCap_p(ps:pe) * pftfrac(ps:pe)) + leafc_storageCap(i) = sum(leafc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + leafc_xferCap(i) = sum(leafc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + frootcCap(i) = sum(frootcCap_p(ps:pe) * pftfrac(ps:pe)) + frootc_storageCap(i) = sum(frootc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + frootc_xferCap(i) = sum(frootc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + livestemcCap(i) = sum(livestemcCap_p(ps:pe) * pftfrac(ps:pe)) + livestemc_storageCap(i) = sum(livestemc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + livestemc_xferCap(i) = sum(livestemc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemcCap(i) = sum(deadstemcCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemc_storageCap(i) = sum(deadstemc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemc_xferCap(i) = sum(deadstemc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootcCap(i) = sum(livecrootcCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootc_storageCap(i) = sum(livecrootc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootc_xferCap(i) = sum(livecrootc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootcCap(i) = sum(deadcrootcCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc_storageCap(i) = sum(deadcrootc_storageCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootc_xferCap(i) = sum(deadcrootc_xferCap_p(ps:pe) * pftfrac(ps:pe)) + ENDIF + DO m = ps, pe + totvegc_p(m) = leafc_p(m) + frootc_p(m) + livestemc_p(m) & + + deadstemc_p(m) + livecrootc_p(m) + deadcrootc_p(m) & + + leafc_storage_p(m) + frootc_storage_p(m) + livestemc_storage_p(m) & + + deadstemc_storage_p(m) + livecrootc_storage_p(m) + deadcrootc_storage_p(m) & + + leafc_xfer_p(m) + frootc_xfer_p(m) + livestemc_xfer_p(m) & + + deadstemc_xfer_p(m) + livecrootc_xfer_p(m) + deadcrootc_xfer_p(m) & +#ifdef CROP + + grainc_p(m) + grainc_storage_p(m) + grainc_xfer_p(m) & + + cropseedc_deficit_p(m) & +#endif + + gresp_storage_p(m) + gresp_xfer_p(m) + xsmrpool_p(m) + cpool_p(m) + +#ifdef CROP + IF( pftclass(m) .eq. 17 .or. pftclass(m) .eq. 18 .or. pftclass(m) .eq. 63 .or. pftclass(m) .eq. 64)THEN + fertnitro_corn (i) = fertnitro_p (m) + irrig_method_corn (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 19 .or. pftclass(m) .eq. 20)THEN + fertnitro_swheat (i) = fertnitro_p (m) + irrig_method_swheat(i) = irrig_method_p (m) + ELSE IF(pftclass(m) .eq. 21 .or. pftclass(m) .eq. 22)THEN + fertnitro_wwheat (i) = fertnitro_p (m) + irrig_method_wwheat (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 23 .or. pftclass(m) .eq. 24 .or. pftclass(m) .eq. 77 .or. pftclass(m) .eq. 78)THEN + fertnitro_soybean (i) = fertnitro_p (m) + irrig_method_soybean (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 41 .or. pftclass(m) .eq. 42)THEN + fertnitro_cotton (i) = fertnitro_p (m) + irrig_method_cotton (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 61 .or. pftclass(m) .eq. 62)THEN + fertnitro_rice1 (i) = fertnitro_p (m) + fertnitro_rice2 (i) = fertnitro_p (m) + irrig_method_rice1 (i) = irrig_method_p(m) + irrig_method_rice2 (i) = irrig_method_p(m) + ELSE IF(pftclass(m) .eq. 67 .or. pftclass(m) .eq. 68)THEN + fertnitro_sugarcane (i) = fertnitro_p (m) + irrig_method_sugarcane(i) = irrig_method_p(m) + ENDIF +#endif + ENDDO + + IF(.not. init)THEN + leafc_enftemp (i) = 0._r8 + leafc_enfboreal (i) = 0._r8 + leafc_dnfboreal (i) = 0._r8 + leafc_ebftrop (i) = 0._r8 + leafc_ebftemp (i) = 0._r8 + leafc_dbftrop (i) = 0._r8 + leafc_dbftemp (i) = 0._r8 + leafc_dbfboreal (i) = 0._r8 + leafc_ebstemp (i) = 0._r8 + leafc_dbstemp (i) = 0._r8 + leafc_dbsboreal (i) = 0._r8 + leafc_c3arcgrass (i) = 0._r8 + leafc_c3grass (i) = 0._r8 + leafc_c4grass (i) = 0._r8 + lai_enftemp (i) = 0._r8 + lai_enfboreal (i) = 0._r8 + lai_dnfboreal (i) = 0._r8 + lai_ebftrop (i) = 0._r8 + lai_ebftemp (i) = 0._r8 + lai_dbftrop (i) = 0._r8 + lai_dbftemp (i) = 0._r8 + lai_dbfboreal (i) = 0._r8 + lai_ebstemp (i) = 0._r8 + lai_dbstemp (i) = 0._r8 + lai_dbsboreal (i) = 0._r8 + lai_c3arcgrass (i) = 0._r8 + lai_c3grass (i) = 0._r8 + lai_c4grass (i) = 0._r8 + DO m = ps, pe + IF(pftclass (m) .eq. 1)THEN + leafc_enftemp (i) = leafc_p(m) + lai_enftemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 2)THEN + leafc_enfboreal (i) = leafc_p(m) + lai_enfboreal (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 3)THEN + leafc_dnfboreal (i) = leafc_p(m) + lai_dnfboreal (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 4)THEN + leafc_ebftrop (i) = leafc_p(m) + lai_ebftrop (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 5)THEN + leafc_ebftemp (i) = leafc_p(m) + lai_ebftemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 6)THEN + leafc_dbftrop (i) = leafc_p(m) + lai_dbftrop (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 7)THEN + leafc_dbftemp (i) = leafc_p(m) + lai_dbftemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 8)THEN + leafc_dbfboreal (i) = leafc_p(m) + lai_dbfboreal (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 9)THEN + leafc_ebstemp (i) = leafc_p(m) + lai_ebstemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 10)THEN + leafc_dbstemp (i) = leafc_p(m) + lai_dbstemp (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 11)THEN + leafc_dbsboreal (i) = leafc_p(m) + lai_dbsboreal (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 12)THEN + leafc_c3arcgrass(i)= leafc_p(m) + lai_c3arcgrass (i)= lai_p(m) + ELSE IF(pftclass (m) .eq. 13)THEN + leafc_c3grass (i) = leafc_p(m) + lai_c3grass (i) = lai_p(m) + ELSE IF(pftclass (m) .eq. 14)THEN + leafc_c4grass (i) = leafc_p(m) + lai_c4grass (i) = lai_p(m) + ENDIF + ENDDO + ENDIF + totvegc(i) = sum(totvegc_p(ps:pe)*pftfrac(ps:pe)) + ctrunc_veg(i) = sum(ctrunc_p(ps:pe) *pftfrac(ps:pe)) + totcolc(i) = totvegc(i) + totcwdc(i) + totlitc(i) + totsomc(i) + ctrunc_veg(i) +ctrunc_soil(i) + + + END SUBROUTINE cnveg_carbonstate_summary + + SUBROUTINE cnveg_nitrogenstate_summary(i,ps,pe) + +! !DESCRIPTION +! summarizes vegetation N state varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + + integer m + + leafn(i) = sum(leafn_p(ps:pe) * pftfrac(ps:pe)) + leafn_storage(i) = sum(leafn_storage_p(ps:pe) * pftfrac(ps:pe)) + leafn_xfer(i) = sum(leafn_xfer_p(ps:pe) * pftfrac(ps:pe)) + frootn(i) = sum(frootn_p(ps:pe) * pftfrac(ps:pe)) + frootn_storage(i) = sum(frootn_storage_p(ps:pe) * pftfrac(ps:pe)) + frootn_xfer(i) = sum(frootn_xfer_p(ps:pe) * pftfrac(ps:pe)) + livestemn(i) = sum(livestemn_p(ps:pe) * pftfrac(ps:pe)) + livestemn_storage(i) = sum(livestemn_storage_p(ps:pe) * pftfrac(ps:pe)) + livestemn_xfer(i) = sum(livestemn_xfer_p(ps:pe) * pftfrac(ps:pe)) + deadstemn(i) = sum(deadstemn_p(ps:pe) * pftfrac(ps:pe)) + deadstemn_storage(i) = sum(deadstemn_storage_p(ps:pe) * pftfrac(ps:pe)) + deadstemn_xfer(i) = sum(deadstemn_xfer_p(ps:pe) * pftfrac(ps:pe)) + livecrootn(i) = sum(livecrootn_p(ps:pe) * pftfrac(ps:pe)) + livecrootn_storage(i) = sum(livecrootn_storage_p(ps:pe) * pftfrac(ps:pe)) + livecrootn_xfer(i) = sum(livecrootn_xfer_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn(i) = sum(deadcrootn_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn_storage(i) = sum(deadcrootn_storage_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn_xfer(i) = sum(deadcrootn_xfer_p(ps:pe) * pftfrac(ps:pe)) +#ifdef CROP + grainn(i) = sum(grainn_p(ps:pe) * pftfrac(ps:pe)) + grainn_storage(i) = sum(grainn_storage_p(ps:pe) * pftfrac(ps:pe)) + grainn_xfer(i) = sum(grainn_xfer_p(ps:pe) * pftfrac(ps:pe)) +#endif + retransn(i) = sum(retransn_p(ps:pe) * pftfrac(ps:pe)) + + IF(DEF_USE_DiagMatrix)THEN + leafnCap(i) = sum(leafnCap_p(ps:pe) * pftfrac(ps:pe)) + leafn_storageCap(i) = sum(leafn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + leafn_xferCap(i) = sum(leafn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + frootnCap(i) = sum(frootnCap_p(ps:pe) * pftfrac(ps:pe)) + frootn_storageCap(i) = sum(frootn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + frootn_xferCap(i) = sum(frootn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + livestemnCap(i) = sum(livestemnCap_p(ps:pe) * pftfrac(ps:pe)) + livestemn_storageCap(i) = sum(livestemn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + livestemn_xferCap(i) = sum(livestemn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemnCap(i) = sum(deadstemnCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemn_storageCap(i) = sum(deadstemn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + deadstemn_xferCap(i) = sum(deadstemn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootnCap(i) = sum(livecrootnCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootn_storageCap(i) = sum(livecrootn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + livecrootn_xferCap(i) = sum(livecrootn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootnCap(i) = sum(deadcrootnCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn_storageCap(i) = sum(deadcrootn_storageCap_p(ps:pe) * pftfrac(ps:pe)) + deadcrootn_xferCap(i) = sum(deadcrootn_xferCap_p(ps:pe) * pftfrac(ps:pe)) + ENDIF + DO m = ps, pe + totvegn_p(m) = leafn_p(m) + frootn_p(m) + livestemn_p(m) & + + deadstemn_p(m) + livecrootn_p(m) + deadcrootn_p(m) & + + leafn_storage_p(m) + frootn_storage_p(m) + livestemn_storage_p(m) & + + deadstemn_storage_p(m) + livecrootn_storage_p(m) + deadcrootn_storage_p(m) & + + leafn_xfer_p(m) + frootn_xfer_p(m) + livestemn_xfer_p(m) & + + deadstemn_xfer_p(m) + livecrootn_xfer_p(m) + deadcrootn_xfer_p(m) & +#ifdef CROP + + grainn_p(m) + grainn_storage_p(m) + grainn_xfer_p(m) & + + cropseedn_deficit_p(m) & +#endif + + npool_p(m) + retransn_p(m) + ENDDO + + totvegn(i) = sum(totvegn_p(ps:pe)*pftfrac(ps:pe)) + ntrunc_veg(i) = sum(ntrunc_p(ps:pe) *pftfrac(ps:pe)) + totcoln(i) = totvegn(i) + totcwdn(i) + totlitn(i) + totsomn(i) + sminn(i) + ntrunc_veg(i) + ntrunc_soil(i) + + END SUBROUTINE cnveg_nitrogenstate_summary + + SUBROUTINE soilbiogeochem_carbonflux_summary(i,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools) + +! !DESCRIPTION +! summarizes soil C flux varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + integer, intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + + integer k,j,l + + DO k = 1, ndecomp_transitions + DO j = 1, nl_soil + decomp_hr(i) = decomp_hr(i) & + + decomp_hr_vr(j,k,i) * dz_soi(j) + ENDDO + ENDDO + + DO l = 1, ndecomp_pools + DO j = 1, nl_soil + som_c_leached(i) = som_c_leached(i) + decomp_cpools_transport_tendency(j,l,i) * dz_soi(j) + ENDDO + ENDDO + + + END SUBROUTINE soilbiogeochem_carbonflux_summary + + SUBROUTINE soilbiogeochem_nitrogenflux_summary(i,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools) + +! !DESCRIPTION +! summarizes soil N flux varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + integer, intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + integer, intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + + integer j,l,k + + DO l = 1, ndecomp_pools + DO j = 1, nl_soil + som_n_leached(i) = som_n_leached(i) + decomp_npools_transport_tendency(j,l,i) * dz_soi(j) + ENDDO + ENDDO + + DO j = 1, nl_soil + supplement_to_sminn(i) = supplement_to_sminn(i) + supplement_to_sminn_vr(j,i) * dz_soi(j) + smin_no3_leached(i) = smin_no3_leached(i) + smin_no3_leached_vr(j,i) * dz_soi(j) + smin_no3_runoff(i) = smin_no3_runoff(i) + smin_no3_runoff_vr(j,i) * dz_soi(j) + sminn_leached(i) = sminn_leached(i) + sminn_leached_vr(j,i) * dz_soi(j) + f_n2o_nit(i) = f_n2o_nit(i) + f_n2o_nit_vr(j,i) * dz_soi(j) + IF(DEF_USE_NITRIF)THEN + denit(i) = denit(i) + f_denit_vr(j,i) * dz_soi(j) + ELSE + denit(i) = denit(i) + sminn_to_denit_excess_vr(j,i) * dz_soi(j) + ENDIF + + IF(.not. DEF_USE_NITRIF)THEN + DO k = 1, ndecomp_transitions + denit(i) = denit(i) + sminn_to_denit_decomp_vr(j,k,i) * dz_soi(j) + ENDDO + ENDIF + ENDDO + + END SUBROUTINE soilbiogeochem_nitrogenflux_summary + + SUBROUTINE cnveg_carbonflux_summary(i,ps,pe,deltim) + +! !DESCRIPTION +! summarizes vegetationi C flux varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8) :: ar_p + + integer m + real(r8) nfixlags + + gpp(i) = sum(psn_to_cpool_p(ps:pe) * pftfrac(ps:pe)) + downreg(i) = sum(downreg_p(ps:pe) * pftfrac(ps:pe)) + ar (i) = sum((leaf_mr_p(ps:pe) + froot_mr_p(ps:pe) & + + livestem_mr_p(ps:pe) + livecroot_mr_p(ps:pe) & + + cpool_leaf_gr_p(ps:pe) + cpool_froot_gr_p(ps:pe) & + + cpool_livestem_gr_p(ps:pe) + cpool_deadstem_gr_p(ps:pe) & + + cpool_livecroot_gr_p(ps:pe) + cpool_deadcroot_gr_p(ps:pe) & + + transfer_leaf_gr_p(ps:pe) + transfer_froot_gr_p(ps:pe) & + + transfer_livestem_gr_p(ps:pe) + transfer_deadstem_gr_p(ps:pe) & + + transfer_livecroot_gr_p(ps:pe) + transfer_deadcroot_gr_p(ps:pe) & + + cpool_leaf_storage_gr_p(ps:pe) + cpool_froot_storage_gr_p(ps:pe) & + + cpool_livestem_storage_gr_p(ps:pe) + cpool_deadstem_storage_gr_p(ps:pe) & + + cpool_livecroot_storage_gr_p(ps:pe) + cpool_deadcroot_storage_gr_p(ps:pe) & + + grain_mr_p(ps:pe) + xsmrpool_to_atm_p(ps:pe) & + + cpool_grain_gr_p(ps:pe) + transfer_grain_gr_p(ps:pe) & + + cpool_grain_storage_gr_p(ps:pe)) * pftfrac(ps:pe)) + gpp_enftemp (i) = 0._r8 + gpp_enfboreal (i) = 0._r8 + gpp_dnfboreal (i) = 0._r8 + gpp_ebftrop (i) = 0._r8 + gpp_ebftemp (i) = 0._r8 + gpp_dbftrop (i) = 0._r8 + gpp_dbftemp (i) = 0._r8 + gpp_dbfboreal (i) = 0._r8 + gpp_ebstemp (i) = 0._r8 + gpp_dbstemp (i) = 0._r8 + gpp_dbsboreal (i) = 0._r8 + gpp_c3arcgrass (i) = 0._r8 + gpp_c3grass (i) = 0._r8 + gpp_c4grass (i) = 0._r8 + npp_enftemp (i) = 0._r8 + npp_enfboreal (i) = 0._r8 + npp_dnfboreal (i) = 0._r8 + npp_ebftrop (i) = 0._r8 + npp_ebftemp (i) = 0._r8 + npp_dbftrop (i) = 0._r8 + npp_dbftemp (i) = 0._r8 + npp_dbfboreal (i) = 0._r8 + npp_ebstemp (i) = 0._r8 + npp_dbstemp (i) = 0._r8 + npp_dbsboreal (i) = 0._r8 + npp_c3arcgrass (i) = 0._r8 + npp_c3grass (i) = 0._r8 + npp_c4grass (i) = 0._r8 + npptoleafc_enftemp (i) = 0._r8 + npptoleafc_enfboreal (i) = 0._r8 + npptoleafc_dnfboreal (i) = 0._r8 + npptoleafc_ebftrop (i) = 0._r8 + npptoleafc_ebftemp (i) = 0._r8 + npptoleafc_dbftrop (i) = 0._r8 + npptoleafc_dbftemp (i) = 0._r8 + npptoleafc_dbfboreal (i) = 0._r8 + npptoleafc_ebstemp (i) = 0._r8 + npptoleafc_dbstemp (i) = 0._r8 + npptoleafc_dbsboreal (i) = 0._r8 + npptoleafc_c3arcgrass (i) = 0._r8 + npptoleafc_c3grass (i) = 0._r8 + npptoleafc_c4grass (i) = 0._r8 + DO m = ps, pe + ar_p = (leaf_mr_p(m) + froot_mr_p(m) & + + livestem_mr_p(m) + livecroot_mr_p(m) & + + cpool_leaf_gr_p(m) + cpool_froot_gr_p(m) & + + cpool_livestem_gr_p(m) + cpool_deadstem_gr_p(m) & + + cpool_livecroot_gr_p(m) + cpool_deadcroot_gr_p(m) & + + transfer_leaf_gr_p(m) + transfer_froot_gr_p(m) & + + transfer_livestem_gr_p(m) + transfer_deadstem_gr_p(m) & + + transfer_livecroot_gr_p(m) + transfer_deadcroot_gr_p(m) & + + cpool_leaf_storage_gr_p(m) + cpool_froot_storage_gr_p(m) & + + cpool_livestem_storage_gr_p(m) + cpool_deadstem_storage_gr_p(m) & + + cpool_livecroot_storage_gr_p(m) + cpool_deadcroot_storage_gr_p(m) & + + grain_mr_p(m) + xsmrpool_to_atm_p(m) & + + cpool_grain_gr_p(m) + transfer_grain_gr_p(m) & + + cpool_grain_storage_gr_p(m)) + IF(pftclass (m) .eq. 1)THEN + gpp_enftemp (i) = psn_to_cpool_p(m) + npp_enftemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_enftemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 2)THEN + gpp_enfboreal (i) = psn_to_cpool_p(m) + npp_enfboreal (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_enfboreal (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 3)THEN + gpp_dnfboreal (i) = psn_to_cpool_p(m) + npp_dnfboreal (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dnfboreal (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 4)THEN + gpp_ebftrop (i) = psn_to_cpool_p(m) + npp_ebftrop (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_ebftrop (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 5)THEN + gpp_ebftemp (i) = psn_to_cpool_p(m) + npp_ebftemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_ebftemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 6)THEN + gpp_dbftrop (i) = psn_to_cpool_p(m) + npp_dbftrop (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbftrop (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 7)THEN + gpp_dbftemp (i) = psn_to_cpool_p(m) + npp_dbftemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbftemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 8)THEN + gpp_dbfboreal (i) = psn_to_cpool_p(m) + npp_dbfboreal (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbfboreal (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 9)THEN + gpp_ebstemp (i) = psn_to_cpool_p(m) + npp_ebstemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_ebstemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 10)THEN + gpp_dbstemp (i) = psn_to_cpool_p(m) + npp_dbstemp (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbstemp (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 11)THEN + gpp_dbsboreal (i) = psn_to_cpool_p(m) + npp_dbsboreal (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_dbsboreal (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 12)THEN + gpp_c3arcgrass (i) = psn_to_cpool_p(m) + npp_c3arcgrass (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_c3arcgrass(i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 13)THEN + gpp_c3grass (i) = psn_to_cpool_p(m) + npp_c3grass (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_c3grass (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ELSE IF(pftclass (m) .eq. 14)THEN + gpp_c4grass (i) = psn_to_cpool_p(m) + npp_c4grass (i) = psn_to_cpool_p(m) - ar_p + npptoleafc_c4grass (i) = cpool_to_leafc_p(m) + cpool_to_leafc_storage_p(m) + ENDIF + ENDDO + + +#ifdef FUN + ar(i) = ar(i) + sum(soil_change_p(ps:pe) * pftfrac(ps:pe)) +#endif + er(i) = ar(i) + decomp_hr(i) +#ifdef CROP + IF(patchclass(i) .eq. 12)THEN + IF(ps .ne. pe)THEN + write(*,*) 'Error: crop patch CONTAINS multiple pfts:',mpas_rank,'i=',i,'ps',ps,'does not equal to pe',pe + CALL CoLM_stop('A crop patch contains more than one PFT.') + ELSE + cropprod1c_loss (i) = cropprod1c_loss_p(ps) + grainc_to_cropprodc (i) = grainc_to_food_p (ps) + grainc_to_seed (i) = grainc_to_seed_p (ps) + plantdate (i) = plantdate_p (ps) + ENDIF + ELSE + cropprod1c_loss (i) = 0._r8 + grainc_to_cropprodc (i) = 0._r8 + grainc_to_seed (i) = 0._r8 + ENDIF +#endif + + !fire module is not activated yet. + DO m = ps, pe + fire_closs_p(m) = m_leafc_to_fire_p(m) & + + m_leafc_storage_to_fire_p(m) & + + m_leafc_xfer_to_fire_p(m) & + + m_frootc_to_fire_p(m) & + + m_frootc_storage_to_fire_p(m) & + + m_frootc_xfer_to_fire_p(m) & + + m_livestemc_to_fire_p(m) & + + m_livestemc_storage_to_fire_p(m) & + + m_livestemc_xfer_to_fire_p(m) & + + m_deadstemc_to_fire_p(m) & + + m_deadstemc_storage_to_fire_p(m) & + + m_deadstemc_xfer_to_fire_p(m) & + + m_livecrootc_to_fire_p(m) & + + m_livecrootc_storage_to_fire_p(m) & + + m_livecrootc_xfer_to_fire_p(m) & + + m_deadcrootc_to_fire_p(m) & + + m_deadcrootc_storage_to_fire_p(m) & + + m_deadcrootc_xfer_to_fire_p(m) & + + m_gresp_storage_to_fire_p(m) & + + m_gresp_xfer_to_fire_p(m) + ENDDO + + fire_closs(i) = sum(fire_closs_p(ps:pe) * pftfrac(ps:pe)) + hrv_xsmrpool_to_atm(i) = sum(hrv_xsmrpool_to_atm_p(ps:pe) * pftfrac(ps:pe)) + + nfixlags = nfix_timeconst * 86400._r8 + IF(lag_npp(i) /= spval)THEN + lag_npp(i) = lag_npp(i) * exp(-deltim/nfixlags) + & + (gpp(i) - ar(i)) * (1._r8 - exp(-deltim/nfixlags)) + ELSE + lag_npp(i) = gpp(i) - ar(i) + ENDIF + + END SUBROUTINE cnveg_carbonflux_summary + + SUBROUTINE cnveg_nitrogenflux_summary(i,ps,pe) + +! !DESCRIPTION +! summarizes vegetationi N flux varaibles. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! end pft index + +#ifdef CROP + IF(patchclass(i) .eq. 12)THEN + IF(ps .ne. pe)THEN + write(*,*) 'Error: crop patch contains multiple pfts:',mpas_rank,'i=',i,'ps',ps,'does not equal to pe',pe + CALL CoLM_stop('A crop patch contains more than one PFT.') + ELSE + grainn_to_cropprodn (i) = grainn_to_food_p (ps) + ENDIF + ELSE + grainn_to_cropprodn (i) = 0._r8 + ENDIF +#endif + END SUBROUTINE cnveg_nitrogenflux_summary + +END MODULE MOD_BGC_CNSummary + + +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNZeroFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNZeroFluxes.F90 new file mode 100644 index 0000000000..a56282a884 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNZeroFluxes.F90 @@ -0,0 +1,838 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_CNZeroFluxes + +!---------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE reset flux variable to 0 at begining of each time step to avoid miscalculating from last step. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + m_leafc_to_litter_p , & + m_frootc_to_litter_p , & + m_leafc_storage_to_litter_p , & + m_frootc_storage_to_litter_p , & + m_livestemc_storage_to_litter_p , & + m_deadstemc_storage_to_litter_p , & + m_livecrootc_storage_to_litter_p , & + m_deadcrootc_storage_to_litter_p , & + m_leafc_xfer_to_litter_p , & + m_frootc_xfer_to_litter_p , & + m_livestemc_xfer_to_litter_p , & + m_deadstemc_xfer_to_litter_p , & + m_livecrootc_xfer_to_litter_p , & + m_deadcrootc_xfer_to_litter_p , & + m_livestemc_to_litter_p , & + m_deadstemc_to_litter_p , & + m_livecrootc_to_litter_p , & + m_deadcrootc_to_litter_p , & + m_gresp_storage_to_litter_p , & + m_gresp_xfer_to_litter_p , & + m_leafc_to_fire_p , & + m_leafc_storage_to_fire_p , & + m_leafc_xfer_to_fire_p , & + m_livestemc_to_fire_p , & + m_livestemc_storage_to_fire_p , & + m_livestemc_xfer_to_fire_p , & + m_deadstemc_to_fire_p , & + m_deadstemc_storage_to_fire_p , & + m_deadstemc_xfer_to_fire_p , & + m_frootc_to_fire_p , & + m_frootc_storage_to_fire_p , & + m_frootc_xfer_to_fire_p , & + m_livecrootc_to_fire_p , & + m_livecrootc_storage_to_fire_p , & + m_livecrootc_xfer_to_fire_p , & + m_deadcrootc_to_fire_p , & + m_deadcrootc_storage_to_fire_p , & + m_deadcrootc_xfer_to_fire_p , & + m_gresp_storage_to_fire_p , & + m_gresp_xfer_to_fire_p , & + + m_leafc_to_litter_fire_p , & + m_leafc_storage_to_litter_fire_p , & + m_leafc_xfer_to_litter_fire_p , & + m_livestemc_to_litter_fire_p , & + m_livestemc_storage_to_litter_fire_p , & + m_livestemc_xfer_to_litter_fire_p , & + m_livestemc_to_deadstemc_fire_p , & + m_deadstemc_to_litter_fire_p , & + m_deadstemc_storage_to_litter_fire_p , & + m_deadstemc_xfer_to_litter_fire_p , & + m_frootc_to_litter_fire_p , & + m_frootc_storage_to_litter_fire_p , & + m_frootc_xfer_to_litter_fire_p , & + m_livecrootc_to_litter_fire_p , & + m_livecrootc_storage_to_litter_fire_p, & + m_livecrootc_xfer_to_litter_fire_p , & + m_livecrootc_to_deadcrootc_fire_p , & + m_deadcrootc_to_litter_fire_p , & + m_deadcrootc_storage_to_litter_fire_p, & + m_deadcrootc_xfer_to_litter_fire_p , & + m_gresp_storage_to_litter_fire_p , & + m_gresp_xfer_to_litter_fire_p , & + + leafc_xfer_to_leafc_p , & + frootc_xfer_to_frootc_p , & + livestemc_xfer_to_livestemc_p , & + deadstemc_xfer_to_deadstemc_p , & + livecrootc_xfer_to_livecrootc_p , & + deadcrootc_xfer_to_deadcrootc_p , & + leafc_to_litter_p , & + frootc_to_litter_p , & + + leaf_mr_p , & + froot_mr_p , & + livestem_mr_p , & + livecroot_mr_p , & + grain_mr_p , & + leaf_curmr_p , & + froot_curmr_p , & + livestem_curmr_p , & + livecroot_curmr_p , & + grain_curmr_p , & + leaf_xsmr_p , & + froot_xsmr_p , & + livestem_xsmr_p , & + livecroot_xsmr_p , & + grain_xsmr_p , & + psn_to_cpool_p , & + cpool_to_xsmrpool_p , & + cpool_to_leafc_p , & + cpool_to_leafc_storage_p , & + cpool_to_frootc_p , & + cpool_to_frootc_storage_p , & + cpool_to_livestemc_p , & + cpool_to_livestemc_storage_p , & + cpool_to_deadstemc_p , & + cpool_to_deadstemc_storage_p , & + cpool_to_livecrootc_p , & + cpool_to_livecrootc_storage_p , & + cpool_to_deadcrootc_p , & + cpool_to_deadcrootc_storage_p , & + cpool_to_gresp_storage_p , & + cpool_leaf_gr_p , & + cpool_leaf_storage_gr_p , & + transfer_leaf_gr_p , & + cpool_froot_gr_p , & + cpool_froot_storage_gr_p , & + transfer_froot_gr_p , & + cpool_livestem_gr_p , & + cpool_livestem_storage_gr_p , & + transfer_livestem_gr_p , & + cpool_deadstem_gr_p , & + cpool_deadstem_storage_gr_p , & + transfer_deadstem_gr_p , & + cpool_livecroot_gr_p , & + cpool_livecroot_storage_gr_p , & + transfer_livecroot_gr_p , & + cpool_deadcroot_gr_p , & + cpool_deadcroot_storage_gr_p , & + transfer_deadcroot_gr_p , & + leafc_storage_to_xfer_p , & + frootc_storage_to_xfer_p , & + livestemc_storage_to_xfer_p , & + deadstemc_storage_to_xfer_p , & + livecrootc_storage_to_xfer_p , & + deadcrootc_storage_to_xfer_p , & + gresp_storage_to_xfer_p , & + livestemc_to_deadstemc_p , & + livecrootc_to_deadcrootc_p , & + crop_seedc_to_leaf_p , & + + hrv_xsmrpool_to_atm_p , & + + xsmrpool_to_atm_p , & + livestemc_to_litter_p , & + grainc_to_food_p , & + grainc_to_seed_p , & + grainc_xfer_to_grainc_p , & + cpool_to_grainc_p , & + cpool_to_grainc_storage_p , & + cpool_grain_gr_p , & + cpool_grain_storage_gr_p , & + transfer_grain_gr_p , & + grainc_storage_to_xfer_p , & + + gpp_p, & + + m_leafn_to_litter_p , & + m_frootn_to_litter_p , & + m_leafn_storage_to_litter_p , & + m_frootn_storage_to_litter_p , & + m_livestemn_storage_to_litter_p , & + m_deadstemn_storage_to_litter_p , & + m_livecrootn_storage_to_litter_p , & + m_deadcrootn_storage_to_litter_p , & + m_leafn_xfer_to_litter_p , & + m_frootn_xfer_to_litter_p , & + m_livestemn_xfer_to_litter_p , & + m_deadstemn_xfer_to_litter_p , & + m_livecrootn_xfer_to_litter_p , & + m_deadcrootn_xfer_to_litter_p , & + m_livestemn_to_litter_p , & + m_deadstemn_to_litter_p , & + m_livecrootn_to_litter_p , & + m_deadcrootn_to_litter_p , & + m_retransn_to_litter_p , & + + m_leafn_to_fire_p , & + m_leafn_storage_to_fire_p , & + m_leafn_xfer_to_fire_p , & + m_livestemn_to_fire_p , & + m_livestemn_storage_to_fire_p , & + m_livestemn_xfer_to_fire_p , & + m_deadstemn_to_fire_p , & + m_deadstemn_storage_to_fire_p , & + m_deadstemn_xfer_to_fire_p , & + m_frootn_to_fire_p , & + m_frootn_storage_to_fire_p , & + m_frootn_xfer_to_fire_p , & + m_livecrootn_to_fire_p , & + m_livecrootn_storage_to_fire_p , & + m_livecrootn_xfer_to_fire_p , & + m_deadcrootn_to_fire_p , & + m_deadcrootn_storage_to_fire_p , & + m_deadcrootn_xfer_to_fire_p , & + m_retransn_to_fire_p , & + + m_leafn_to_litter_fire_p , & + m_leafn_storage_to_litter_fire_p , & + m_leafn_xfer_to_litter_fire_p , & + m_livestemn_to_litter_fire_p , & + m_livestemn_storage_to_litter_fire_p , & + m_livestemn_xfer_to_litter_fire_p , & + m_livestemn_to_deadstemn_fire_p , & + m_deadstemn_to_litter_fire_p , & + m_deadstemn_storage_to_litter_fire_p , & + m_deadstemn_xfer_to_litter_fire_p , & + m_frootn_to_litter_fire_p , & + m_frootn_storage_to_litter_fire_p , & + m_frootn_xfer_to_litter_fire_p , & + m_livecrootn_to_litter_fire_p , & + m_livecrootn_storage_to_litter_fire_p, & + m_livecrootn_xfer_to_litter_fire_p , & + m_livecrootn_to_deadcrootn_fire_p , & + m_deadcrootn_to_litter_fire_p , & + m_deadcrootn_storage_to_litter_fire_p, & + m_deadcrootn_xfer_to_litter_fire_p , & + m_retransn_to_litter_fire_p , & + + leafn_xfer_to_leafn_p , & + frootn_xfer_to_frootn_p , & + livestemn_xfer_to_livestemn_p , & + deadstemn_xfer_to_deadstemn_p , & + livecrootn_xfer_to_livecrootn_p , & + deadcrootn_xfer_to_deadcrootn_p , & + leafn_to_litter_p , & + leafn_to_retransn_p , & + frootn_to_litter_p , & + retransn_to_npool_p , & + free_retransn_to_npool_p , & + sminn_to_npool_p , & + npool_to_leafn_p , & + npool_to_leafn_storage_p , & + npool_to_frootn_p , & + npool_to_frootn_storage_p , & + npool_to_livestemn_p , & + npool_to_livestemn_storage_p , & + npool_to_deadstemn_p , & + npool_to_deadstemn_storage_p , & + npool_to_livecrootn_p , & + npool_to_livecrootn_storage_p , & + npool_to_deadcrootn_p , & + npool_to_deadcrootn_storage_p , & + leafn_storage_to_xfer_p , & + frootn_storage_to_xfer_p , & + livestemn_storage_to_xfer_p , & + deadstemn_storage_to_xfer_p , & + livecrootn_storage_to_xfer_p , & + deadcrootn_storage_to_xfer_p , & + livestemn_to_deadstemn_p , & + livestemn_to_retransn_p , & + livecrootn_to_deadcrootn_p , & + livecrootn_to_retransn_p , & + + crop_seedn_to_leaf_p , & + + livestemn_to_litter_p , & + grainn_to_food_p , & + grainn_to_seed_p , & + grainn_xfer_to_grainn_p , & + npool_to_grainn_p , & + npool_to_grainn_storage_p , & + grainn_storage_to_xfer_p , & + frootn_to_retransn_p , & + + fire_closs_p , & + fire_nloss_p , & + wood_harvestc_p , & + wood_harvestn_p , & + grainc_to_cropprodc_p , & + grainn_to_cropprodn_p , & + soyfixn_p + + USE MOD_BGC_Vars_1DFluxes, only: & + + ! phenologgy + phenology_to_met_c , & + phenology_to_cel_c , & + phenology_to_lig_c , & + + ! gap mortality + gap_mortality_to_met_c , & + gap_mortality_to_cel_c , & + gap_mortality_to_lig_c , & + gap_mortality_to_cwdc , & + + ! fire + fire_mortality_to_cwdc , & + fire_mortality_to_met_c , & + fire_mortality_to_cel_c , & + fire_mortality_to_lig_c , & + + m_decomp_cpools_to_fire_vr , & + + ! phenologgy + phenology_to_met_n , & + phenology_to_cel_n , & + phenology_to_lig_n , & + + ! gap mortality + gap_mortality_to_met_n , & + gap_mortality_to_cel_n , & + gap_mortality_to_lig_n , & + gap_mortality_to_cwdn , & + + ! fire + fire_mortality_to_cwdn , & + fire_mortality_to_met_n , & + fire_mortality_to_cel_n , & + fire_mortality_to_lig_n , & + + m_decomp_npools_to_fire_vr , & + + fire_closs , & + fire_nloss , & + wood_harvestc , & + wood_harvestn , & + grainc_to_cropprodc , & + grainn_to_cropprodn , & + + decomp_hr , & + decomp_hr_vr , & + decomp_ctransfer_vr , & + + decomp_cpools_transport_tendency , & + decomp_cpools_sourcesink , & + + somc_fire , & + som_c_leached , & + + sminn_to_denit_excess_vr , & + sminn_leached_vr , & + sminn_to_plant_fun_vr , & + + f_nit_vr , & + f_denit_vr , & + smin_no3_leached_vr , & + smin_no3_runoff_vr , & + n2_n2o_ratio_denit_vr , & + pot_f_nit_vr , & + pot_f_denit_vr , & + actual_immob_no3_vr , & + actual_immob_nh4_vr , & + smin_no3_to_plant_vr , & + smin_nh4_to_plant_vr , & + f_n2o_denit_vr , & + f_n2o_nit_vr , & + + potential_immob_vr , & + actual_immob_vr , & + sminn_to_plant , & + sminn_to_plant_vr , & + supplement_to_sminn_vr , & + gross_nmin_vr , & + net_nmin_vr , & + sminn_to_plant_fun_no3_vr , & + sminn_to_plant_fun_nh4_vr , & + + nfix_to_sminn , & + ffix_to_sminn , & + fert_to_sminn , & + soyfixn_to_sminn , & + sminn_to_plant , & + supplement_to_sminn , & + gross_nmin , & + net_nmin , & + denit , & + f_n2o_nit , & + smin_no3_leached , & + smin_no3_runoff , & + sminn_leached , & + som_n_leached , & + + decomp_npools_transport_tendency , & + + decomp_ntransfer_vr , & + decomp_sminn_flux_vr , & + sminn_to_denit_decomp_vr , & + + decomp_npools_sourcesink + + USE MOD_BGC_Vars_TimeVariables, only: & + decomp_k + + IMPLICIT NONE + + PUBLIC CNZeroFluxes + +CONTAINS + + SUBROUTINE CNZeroFluxes (i,ps,pe,nl_soil,ndecomp_pools,ndecomp_transitions) + + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! end pft index + integer, intent(in) :: nl_soil ! number of total soil layers + integer, intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + integer, intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + + integer j,k, m + + DO m = ps , pe + ! CNVegCarbonFluxes set zero + m_leafc_to_litter_p(m) = 0._r8 + m_frootc_to_litter_p(m) = 0._r8 + m_leafc_storage_to_litter_p(m) = 0._r8 + m_frootc_storage_to_litter_p(m) = 0._r8 + m_livestemc_storage_to_litter_p(m) = 0._r8 + m_deadstemc_storage_to_litter_p(m) = 0._r8 + m_livecrootc_storage_to_litter_p(m) = 0._r8 + m_deadcrootc_storage_to_litter_p(m) = 0._r8 + m_leafc_xfer_to_litter_p(m) = 0._r8 + m_frootc_xfer_to_litter_p(m) = 0._r8 + m_livestemc_xfer_to_litter_p(m) = 0._r8 + m_deadstemc_xfer_to_litter_p(m) = 0._r8 + m_livecrootc_xfer_to_litter_p(m) = 0._r8 + m_deadcrootc_xfer_to_litter_p(m) = 0._r8 + m_livestemc_to_litter_p(m) = 0._r8 + m_deadstemc_to_litter_p(m) = 0._r8 + m_livecrootc_to_litter_p(m) = 0._r8 + m_deadcrootc_to_litter_p(m) = 0._r8 + m_gresp_storage_to_litter_p(m) = 0._r8 + m_gresp_xfer_to_litter_p(m) = 0._r8 + m_leafc_to_fire_p(m) = 0._r8 + m_leafc_storage_to_fire_p(m) = 0._r8 + m_leafc_xfer_to_fire_p(m) = 0._r8 + m_livestemc_to_fire_p(m) = 0._r8 + m_livestemc_storage_to_fire_p(m) = 0._r8 + m_livestemc_xfer_to_fire_p(m) = 0._r8 + m_deadstemc_to_fire_p(m) = 0._r8 + m_deadstemc_storage_to_fire_p(m) = 0._r8 + m_deadstemc_xfer_to_fire_p(m) = 0._r8 + m_frootc_to_fire_p(m) = 0._r8 + m_frootc_storage_to_fire_p(m) = 0._r8 + m_frootc_xfer_to_fire_p(m) = 0._r8 + m_livecrootc_to_fire_p(m) = 0._r8 + m_livecrootc_storage_to_fire_p(m) = 0._r8 + m_livecrootc_xfer_to_fire_p(m) = 0._r8 + m_deadcrootc_to_fire_p(m) = 0._r8 + m_deadcrootc_storage_to_fire_p(m) = 0._r8 + m_deadcrootc_xfer_to_fire_p(m) = 0._r8 + m_gresp_storage_to_fire_p(m) = 0._r8 + m_gresp_xfer_to_fire_p(m) = 0._r8 + + m_leafc_to_litter_fire_p(m) = 0._r8 + m_leafc_storage_to_litter_fire_p(m) = 0._r8 + m_leafc_xfer_to_litter_fire_p(m) = 0._r8 + m_livestemc_to_litter_fire_p(m) = 0._r8 + m_livestemc_storage_to_litter_fire_p(m) = 0._r8 + m_livestemc_xfer_to_litter_fire_p(m) = 0._r8 + m_livestemc_to_deadstemc_fire_p(m) = 0._r8 + m_deadstemc_to_litter_fire_p(m) = 0._r8 + m_deadstemc_storage_to_litter_fire_p(m) = 0._r8 + m_deadstemc_xfer_to_litter_fire_p(m) = 0._r8 + m_frootc_to_litter_fire_p(m) = 0._r8 + m_frootc_storage_to_litter_fire_p(m) = 0._r8 + m_frootc_xfer_to_litter_fire_p(m) = 0._r8 + m_livecrootc_to_litter_fire_p(m) = 0._r8 + m_livecrootc_storage_to_litter_fire_p(m) = 0._r8 + m_livecrootc_xfer_to_litter_fire_p(m) = 0._r8 + m_livecrootc_to_deadcrootc_fire_p(m) = 0._r8 + m_deadcrootc_to_litter_fire_p(m) = 0._r8 + m_deadcrootc_storage_to_litter_fire_p(m) = 0._r8 + m_deadcrootc_xfer_to_litter_fire_p(m) = 0._r8 + m_gresp_storage_to_litter_fire_p(m) = 0._r8 + m_gresp_xfer_to_litter_fire_p(m) = 0._r8 + leafc_xfer_to_leafc_p(m) = 0._r8 + frootc_xfer_to_frootc_p(m) = 0._r8 + livestemc_xfer_to_livestemc_p(m) = 0._r8 + deadstemc_xfer_to_deadstemc_p(m) = 0._r8 + livecrootc_xfer_to_livecrootc_p(m) = 0._r8 + deadcrootc_xfer_to_deadcrootc_p(m) = 0._r8 + leafc_to_litter_p(m) = 0._r8 + frootc_to_litter_p(m) = 0._r8 + leaf_mr_p(m) = 0._r8 + froot_mr_p(m) = 0._r8 + livestem_mr_p(m) = 0._r8 + livecroot_mr_p(m) = 0._r8 + grain_mr_p(m) = 0._r8 + leaf_curmr_p(m) = 0._r8 + froot_curmr_p(m) = 0._r8 + livestem_curmr_p(m) = 0._r8 + livecroot_curmr_p(m) = 0._r8 + grain_curmr_p(m) = 0._r8 + leaf_xsmr_p(m) = 0._r8 + froot_xsmr_p(m) = 0._r8 + livestem_xsmr_p(m) = 0._r8 + livecroot_xsmr_p(m) = 0._r8 + grain_xsmr_p(m) = 0._r8 + psn_to_cpool_p(m) = 0._r8 + cpool_to_xsmrpool_p(m) = 0._r8 + cpool_to_leafc_p(m) = 0._r8 + cpool_to_leafc_storage_p(m) = 0._r8 + cpool_to_frootc_p(m) = 0._r8 + cpool_to_frootc_storage_p(m) = 0._r8 + cpool_to_livestemc_p(m) = 0._r8 + cpool_to_livestemc_storage_p(m) = 0._r8 + cpool_to_deadstemc_p(m) = 0._r8 + cpool_to_deadstemc_storage_p(m) = 0._r8 + cpool_to_livecrootc_p(m) = 0._r8 + cpool_to_livecrootc_storage_p(m) = 0._r8 + cpool_to_deadcrootc_p(m) = 0._r8 + cpool_to_deadcrootc_storage_p(m) = 0._r8 + cpool_to_gresp_storage_p(m) = 0._r8 + cpool_leaf_gr_p(m) = 0._r8 + cpool_leaf_storage_gr_p(m) = 0._r8 + transfer_leaf_gr_p(m) = 0._r8 + cpool_froot_gr_p(m) = 0._r8 + cpool_froot_storage_gr_p(m) = 0._r8 + transfer_froot_gr_p(m) = 0._r8 + cpool_livestem_gr_p(m) = 0._r8 + cpool_livestem_storage_gr_p(m) = 0._r8 + transfer_livestem_gr_p(m) = 0._r8 + cpool_deadstem_gr_p(m) = 0._r8 + cpool_deadstem_storage_gr_p(m) = 0._r8 + transfer_deadstem_gr_p(m) = 0._r8 + cpool_livecroot_gr_p(m) = 0._r8 + cpool_livecroot_storage_gr_p(m) = 0._r8 + transfer_livecroot_gr_p(m) = 0._r8 + cpool_deadcroot_gr_p(m) = 0._r8 + cpool_deadcroot_storage_gr_p(m) = 0._r8 + transfer_deadcroot_gr_p(m) = 0._r8 + leafc_storage_to_xfer_p(m) = 0._r8 + frootc_storage_to_xfer_p(m) = 0._r8 + livestemc_storage_to_xfer_p(m) = 0._r8 + deadstemc_storage_to_xfer_p(m) = 0._r8 + livecrootc_storage_to_xfer_p(m) = 0._r8 + deadcrootc_storage_to_xfer_p(m) = 0._r8 + gresp_storage_to_xfer_p(m) = 0._r8 + livestemc_to_deadstemc_p(m) = 0._r8 + livecrootc_to_deadcrootc_p(m) = 0._r8 + crop_seedc_to_leaf_p(m) = 0._r8 + + hrv_xsmrpool_to_atm_p(m) = 0._r8 + + xsmrpool_to_atm_p(m) = 0._r8 + livestemc_to_litter_p(m) = 0._r8 + grainc_to_food_p(m) = 0._r8 + grainc_to_seed_p(m) = 0._r8 + grainc_xfer_to_grainc_p(m) = 0._r8 + cpool_to_grainc_p(m) = 0._r8 + cpool_to_grainc_storage_p(m) = 0._r8 + cpool_grain_gr_p(m) = 0._r8 + cpool_grain_storage_gr_p(m) = 0._r8 + transfer_grain_gr_p(m) = 0._r8 + grainc_storage_to_xfer_p(m) = 0._r8 + ENDDO + + DO j=1,nl_soil + phenology_to_met_c(j,i) = 0._r8 + phenology_to_cel_c(j,i) = 0._r8 + phenology_to_lig_c(j,i) = 0._r8 + + gap_mortality_to_met_c(j,i) = 0._r8 + gap_mortality_to_cel_c(j,i) = 0._r8 + gap_mortality_to_lig_c(j,i) = 0._r8 + gap_mortality_to_cwdc(j,i) = 0._r8 + + fire_mortality_to_cwdc(j,i) = 0._r8 + fire_mortality_to_met_c(j,i) = 0._r8 + fire_mortality_to_cel_c(j,i) = 0._r8 + fire_mortality_to_lig_c(j,i) = 0._r8 + + DO k=1,ndecomp_pools + m_decomp_cpools_to_fire_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + + fire_closs(i) = 0._r8 + fire_nloss(i) = 0._r8 + wood_harvestc(i) = 0._r8 + wood_harvestn(i) = 0._r8 + grainc_to_cropprodc(i) = 0._r8 + grainn_to_cropprodn(i) = 0._r8 + + DO m = ps, pe + gpp_p(m) = 0._r8 + wood_harvestc_p(m) = 0._r8 + wood_harvestn_p(m) = 0._r8 + grainc_to_cropprodc_p(m) = 0._r8 + grainn_to_cropprodn_p(m) = 0._r8 + soyfixn_p(m) = 0._r8 + + fire_closs_p(m) = 0._r8 + fire_nloss_p(m) = 0._r8 + + ! CNVegNitrogenFluxes set zero + + m_leafn_to_litter_p(m) = 0._r8 + m_frootn_to_litter_p(m) = 0._r8 + m_leafn_storage_to_litter_p(m) = 0._r8 + m_frootn_storage_to_litter_p(m) = 0._r8 + m_livestemn_storage_to_litter_p(m) = 0._r8 + m_deadstemn_storage_to_litter_p(m) = 0._r8 + m_livecrootn_storage_to_litter_p(m) = 0._r8 + m_deadcrootn_storage_to_litter_p(m) = 0._r8 + m_leafn_xfer_to_litter_p(m) = 0._r8 + m_frootn_xfer_to_litter_p(m) = 0._r8 + m_livestemn_xfer_to_litter_p(m) = 0._r8 + m_deadstemn_xfer_to_litter_p(m) = 0._r8 + m_livecrootn_xfer_to_litter_p(m) = 0._r8 + m_deadcrootn_xfer_to_litter_p(m) = 0._r8 + m_livestemn_to_litter_p(m) = 0._r8 + m_deadstemn_to_litter_p(m) = 0._r8 + m_livecrootn_to_litter_p(m) = 0._r8 + m_deadcrootn_to_litter_p(m) = 0._r8 + m_retransn_to_litter_p(m) = 0._r8 + + m_leafn_to_fire_p(m) = 0._r8 + m_leafn_storage_to_fire_p(m) = 0._r8 + m_leafn_xfer_to_fire_p(m) = 0._r8 + m_livestemn_to_fire_p(m) = 0._r8 + m_livestemn_storage_to_fire_p(m) = 0._r8 + m_livestemn_xfer_to_fire_p(m) = 0._r8 + m_deadstemn_to_fire_p(m) = 0._r8 + m_deadstemn_storage_to_fire_p(m) = 0._r8 + m_deadstemn_xfer_to_fire_p(m) = 0._r8 + m_frootn_to_fire_p(m) = 0._r8 + m_frootn_storage_to_fire_p(m) = 0._r8 + m_frootn_xfer_to_fire_p(m) = 0._r8 + m_livecrootn_to_fire_p(m) = 0._r8 + m_livecrootn_storage_to_fire_p(m) = 0._r8 + m_livecrootn_xfer_to_fire_p(m) = 0._r8 + m_deadcrootn_to_fire_p(m) = 0._r8 + m_deadcrootn_storage_to_fire_p(m) = 0._r8 + m_deadcrootn_xfer_to_fire_p(m) = 0._r8 + m_retransn_to_fire_p(m) = 0._r8 + + + m_leafn_to_litter_fire_p(m) = 0._r8 + m_leafn_storage_to_litter_fire_p(m) = 0._r8 + m_leafn_xfer_to_litter_fire_p(m) = 0._r8 + m_livestemn_to_litter_fire_p(m) = 0._r8 + m_livestemn_storage_to_litter_fire_p(m) = 0._r8 + m_livestemn_xfer_to_litter_fire_p(m) = 0._r8 + m_livestemn_to_deadstemn_fire_p(m) = 0._r8 + m_deadstemn_to_litter_fire_p(m) = 0._r8 + m_deadstemn_storage_to_litter_fire_p(m) = 0._r8 + m_deadstemn_xfer_to_litter_fire_p(m) = 0._r8 + m_frootn_to_litter_fire_p(m) = 0._r8 + m_frootn_storage_to_litter_fire_p(m) = 0._r8 + m_frootn_xfer_to_litter_fire_p(m) = 0._r8 + m_livecrootn_to_litter_fire_p(m) = 0._r8 + m_livecrootn_storage_to_litter_fire_p(m) = 0._r8 + m_livecrootn_xfer_to_litter_fire_p(m) = 0._r8 + m_livecrootn_to_deadcrootn_fire_p(m) = 0._r8 + m_deadcrootn_to_litter_fire_p(m) = 0._r8 + m_deadcrootn_storage_to_litter_fire_p(m) = 0._r8 + m_deadcrootn_xfer_to_litter_fire_p(m) = 0._r8 + m_retransn_to_litter_fire_p(m) = 0._r8 + + leafn_xfer_to_leafn_p(m) = 0._r8 + frootn_xfer_to_frootn_p(m) = 0._r8 + livestemn_xfer_to_livestemn_p(m) = 0._r8 + deadstemn_xfer_to_deadstemn_p(m) = 0._r8 + livecrootn_xfer_to_livecrootn_p(m) = 0._r8 + deadcrootn_xfer_to_deadcrootn_p(m) = 0._r8 + leafn_to_litter_p(m) = 0._r8 + leafn_to_retransn_p(m) = 0._r8 + frootn_to_litter_p(m) = 0._r8 + retransn_to_npool_p(m) = 0._r8 + free_retransn_to_npool_p(m) = 0._r8 + sminn_to_npool_p(m) = 0._r8 + npool_to_leafn_p(m) = 0._r8 + npool_to_leafn_storage_p(m) = 0._r8 + npool_to_frootn_p(m) = 0._r8 + npool_to_frootn_storage_p(m) = 0._r8 + npool_to_livestemn_p(m) = 0._r8 + npool_to_livestemn_storage_p(m) = 0._r8 + npool_to_deadstemn_p(m) = 0._r8 + npool_to_deadstemn_storage_p(m) = 0._r8 + npool_to_livecrootn_p(m) = 0._r8 + npool_to_livecrootn_storage_p(m) = 0._r8 + npool_to_deadcrootn_p(m) = 0._r8 + npool_to_deadcrootn_storage_p(m) = 0._r8 + leafn_storage_to_xfer_p(m) = 0._r8 + frootn_storage_to_xfer_p(m) = 0._r8 + livestemn_storage_to_xfer_p(m) = 0._r8 + deadstemn_storage_to_xfer_p(m) = 0._r8 + livecrootn_storage_to_xfer_p(m) = 0._r8 + deadcrootn_storage_to_xfer_p(m) = 0._r8 + livestemn_to_deadstemn_p(m) = 0._r8 + livestemn_to_retransn_p(m) = 0._r8 + livecrootn_to_deadcrootn_p(m) = 0._r8 + livecrootn_to_retransn_p(m) = 0._r8 + + crop_seedn_to_leaf_p(m) = 0._r8 + + livestemn_to_litter_p(m) = 0._r8 + grainn_to_food_p(m) = 0._r8 + grainn_to_seed_p(m) = 0._r8 + grainn_xfer_to_grainn_p(m) = 0._r8 + npool_to_grainn_p(m) = 0._r8 + npool_to_grainn_storage_p(m) = 0._r8 + grainn_storage_to_xfer_p(m) = 0._r8 + frootn_to_retransn_p(m) = 0._r8 + ENDDO + + DO j=1,nl_soil + + ! phenology: litterfall and crop fluxes associated wit + phenology_to_met_n(j,i) = 0._r8 + phenology_to_cel_n(j,i) = 0._r8 + phenology_to_lig_n(j,i) = 0._r8 + + ! gap mortality + gap_mortality_to_met_n(j,i) = 0._r8 + gap_mortality_to_cel_n(j,i) = 0._r8 + gap_mortality_to_lig_n(j,i) = 0._r8 + gap_mortality_to_cwdn(j,i) = 0._r8 + + ! fire + fire_mortality_to_cwdn(j,i) = 0._r8 + fire_mortality_to_met_n(j,i) = 0._r8 + fire_mortality_to_cel_n(j,i) = 0._r8 + fire_mortality_to_lig_n(j,i) = 0._r8 + + ENDDO + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + m_decomp_npools_to_fire_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + + DO k=1,ndecomp_transitions + DO j=1,nl_soil + decomp_hr_vr(j,k,i) = 0._r8 + decomp_ctransfer_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_cpools_transport_tendency(j,k,i) = 0._r8 + decomp_cpools_sourcesink(j,k,i) = 0._r8 + decomp_k(j,k,i) = 0._r8 + ENDDO + ENDDO + + somc_fire(i) = 0._r8 + som_c_leached(i) = 0._r8 + decomp_hr(i) = 0._r8 + + + + IF(.not. DEF_USE_NITRIF)THEN + DO j = 1, nl_soil + sminn_to_denit_excess_vr(j,i) = 0._r8 + sminn_leached_vr(j,i) = 0._r8 + sminn_to_plant_fun_vr(j,i) = 0._r8 + ENDDO + ELSE + DO j = 1, nl_soil + f_nit_vr(j,i) = 0._r8 + f_denit_vr(j,i) = 0._r8 + smin_no3_leached_vr(j,i) = 0._r8 + smin_no3_runoff_vr(j,i) = 0._r8 + n2_n2o_ratio_denit_vr(j,i) = 0._r8 + pot_f_nit_vr(j,i) = 0._r8 + pot_f_denit_vr(j,i) = 0._r8 + actual_immob_no3_vr(j,i) = 0._r8 + actual_immob_nh4_vr(j,i) = 0._r8 + smin_no3_to_plant_vr(j,i) = 0._r8 + smin_nh4_to_plant_vr(j,i) = 0._r8 + f_n2o_denit_vr(j,i) = 0._r8 + f_n2o_nit_vr(j,i) = 0._r8 + ENDDO + ENDIF + + DO j = 1, nl_soil + potential_immob_vr(j,i) = 0._r8 + actual_immob_vr(j,i) = 0._r8 + sminn_to_plant(i) = 0._r8 + sminn_to_plant_vr(j,i) = 0._r8 + supplement_to_sminn_vr(j,i) = 0._r8 + gross_nmin_vr(j,i) = 0._r8 + net_nmin_vr(j,i) = 0._r8 + sminn_to_plant_fun_no3_vr(j,i) = 0._r8 + sminn_to_plant_fun_nh4_vr(j,i) = 0._r8 + ENDDO + + nfix_to_sminn(i) = 0._r8 + ffix_to_sminn(i) = 0._r8 + fert_to_sminn(i) = 0._r8 + soyfixn_to_sminn(i) = 0._r8 + supplement_to_sminn(i) = 0._r8 + gross_nmin(i) = 0._r8 + net_nmin(i) = 0._r8 + denit(i) = 0._r8 + f_n2o_nit(i) = 0._r8 + smin_no3_leached(i) = 0._r8 + smin_no3_runoff(i) = 0._r8 + sminn_leached(i) = 0._r8 + som_n_leached(i) = 0._r8 + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_npools_transport_tendency(j,k,i) = 0._r8 + ENDDO + ENDDO + + DO k = 1, ndecomp_transitions + DO j = 1, nl_soil + decomp_ntransfer_vr(j,k,i) = 0._r8 + decomp_sminn_flux_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + + IF(.not. DEF_USE_NITRIF)THEN + DO k = 1, ndecomp_transitions + DO j = 1, nl_soil + sminn_to_denit_decomp_vr(j,k,i) = 0._r8 + ENDDO + ENDDO + ENDIF + + DO k = 1, ndecomp_pools + DO j = 1, nl_soil + decomp_npools_sourcesink(j,k,i) = 0._r8 + ENDDO + ENDDO + + END SUBROUTINE CNZeroFluxes + +END MODULE MOD_BGC_CNZeroFluxes +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Daylength.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Daylength.F90 new file mode 100644 index 0000000000..e37fcd3871 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Daylength.F90 @@ -0,0 +1,90 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Daylength + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Computes day length and solar declination angle based on given latitude and date. +! +! ! ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! REVISION: +! Xingjie Lu, 2022, modify original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + IMPLICIT NONE + SAVE + PRIVATE + + PUBLIC :: daylength ! function to compute daylength + PRIVATE :: declin_angle ! function to compute solar decliation angle + ! + !----------------------------------------------------------------------- + +CONTAINS + + !----------------------------------------------------------------------- + real(r8) FUNCTION daylength(dlat, idate2) +! +! !DESCRIPTION: +! Computes daylength (in seconds) +! +! Latitude and solar declination angle should both be specified in radians. decl must +! be strictly less than pi/2; lat must be less than pi/2 within a small tolerance. +! + real(r8), intent(in) :: dlat ! latitude (degrees) + integer , intent(in) :: idate2 ! day of the year + + real(r8),parameter :: PI = 4.*atan(1.)! + ! !LOCAL VARIABLES: + real(r8) :: my_lat ! local version of lat, possibly adjusted slightly + real(r8) :: temp ! temporary variable + real(r8) :: decl + + ! number of seconds per radian of hour-angle + real(r8), parameter :: secs_per_radian = 13750.9871_r8 + + ! epsilon for defining latitudes "near" the pole + real(r8), parameter :: lat_epsilon = 10._r8 * epsilon(1._r8) + + ! Define an offset pole as slightly less than pi/2 to avoid problems with cos(lat) being negative + real(r8), parameter :: pole = PI/2.0_r8 + real(r8), parameter :: offset_pole = pole - lat_epsilon + !----------------------------------------------------------------------- + + decl=declin_angle(idate2) + + ! lat must be less than pi/2 within a small tolerance + IF (abs(dlat/180*PI) >= (pole + lat_epsilon)) THEN + daylength = -9999 + write(*,*)"error in latitude",dlat + + ! decl must be strictly less than pi/2 + ELSE IF (abs(decl) >= pole) THEN + daylength = -9999 + write(*,*)"error in idate:",idate2 + + ! normal case + ELSE + ! Ensure that latitude isn't too close to pole, to avoid problems with cos(lat) being negative + my_lat = min(offset_pole, max(-1._r8 * offset_pole, dlat/180*PI)) + + temp = -(sin(my_lat)*sin(decl))/(cos(my_lat) * cos(decl)) + temp = min(1._r8,max(-1._r8,temp)) + daylength = 2.0_r8 * secs_per_radian * acos(temp) + ENDIF + + END FUNCTION daylength + + real(r8) FUNCTION declin_angle(idate2) + + integer ,intent(in) :: idate2 ! day of the year + real(r8),parameter :: PI = 4.*atan(1.) ! circular constant + + declin_angle=-23.44_r8/180._r8*PI*cos(2*PI/365*(idate2+10)) + + END FUNCTION declin_angle + +END MODULE MOD_BGC_Daylength +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemCompetition.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemCompetition.F90 new file mode 100644 index 0000000000..6438b71cf8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemCompetition.F90 @@ -0,0 +1,469 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemCompetition + +!--------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate the soil mineral nitrogen competition between soil microbial (immobilisation) and plant (N uptake). +! Note that there is no non-linear microbial model in CoLM-BGC. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Vars_Global, only: npcropmin + USE MOD_Namelist, only: DEF_USE_NITRIF, DEF_USE_NOSTRESSNITROGEN + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_BGC_Vars_1DFluxes, only: & + pot_f_nit_vr, potential_immob_vr, sminn_to_plant_vr, sminn_to_denit_excess_vr, plant_ndemand, & + actual_immob_vr, sminn_to_plant, pot_f_nit_vr, actual_immob_nh4_vr, f_nit_vr, & + smin_nh4_to_plant_vr, pot_f_denit_vr, actual_immob_no3_vr, f_denit_vr, smin_no3_to_plant_vr, & + n2_n2o_ratio_denit_vr, f_n2o_nit_vr, f_n2o_denit_vr, supplement_to_sminn_vr + USE MOD_BGC_Vars_TimeVariables, only: & + sminn_vr, smin_no3_vr, smin_nh4_vr, nfixation_prof, fpi_vr, fpi, fpg + USE MOD_BGC_Vars_TimeInvariants,only: & + bdnr, compet_plant_no3, compet_plant_nh4, compet_decomp_no3, compet_decomp_nh4, compet_denit, compet_nit, & + nitrif_n2o_loss_frac + + IMPLICIT NONE + + PUBLIC SoilBiogeochemCompetition + +CONTAINS + + SUBROUTINE SoilBiogeochemCompetition(i,deltim,nl_soil,dz_soi) + + integer ,intent(in) :: i ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + + + integer :: p,l,pi,j ! indices + real(r8) :: fpi_no3_vr(1:nl_soil) ! fraction of potential immobilization supplied by no3(no units) + real(r8) :: fpi_nh4_vr(1:nl_soil) ! fraction of potential immobilization supplied by nh4 (no units) + real(r8) :: sum_nh4_demand(1:nl_soil) + real(r8) :: sum_nh4_demand_scaled(1:nl_soil) + real(r8) :: sum_no3_demand(1:nl_soil) + real(r8) :: sum_no3_demand_scaled(1:nl_soil) + real(r8) :: sum_ndemand_vr( 1:nl_soil) !total column N demand (gN/m3/s) at a given level + real(r8) :: nuptake_prof( 1:nl_soil) + real(r8) :: sminn_tot + integer :: nlimit(1:nl_soil) !flag for N limitation + integer :: nlimit_no3(1:nl_soil) !flag for NO3 limitation + integer :: nlimit_nh4(1:nl_soil) !flag for NH4 limitation + real(r8) :: residual_sminn_vr( 1:nl_soil) + real(r8) :: residual_sminn + real(r8) :: residual_smin_nh4_vr( 1:nl_soil) + real(r8) :: residual_smin_no3_vr( 1:nl_soil) + real(r8) :: residual_smin_nh4 + real(r8) :: residual_smin_no3 + real(r8) :: residual_plant_ndemand + real(r8) :: sminn_to_plant_new + real(r8) :: actual_immob + real(r8) :: potential_immob + integer :: ivt, ps, pe, m + !----------------------------------------------------------------------- + + sminn_to_plant_new = 0._r8 + + IF(.not. DEF_USE_NITRIF)THEN + + ! init sminn_tot + sminn_tot = 0. + + DO j = 1, nl_soil + sminn_tot = sminn_tot + sminn_vr(j,i) * dz_soi(j) + ENDDO + + DO j = 1, nl_soil + IF (sminn_tot > 0.) THEN + nuptake_prof(j) = sminn_vr(j,i) / sminn_tot + ELSE + nuptake_prof(j) = nfixation_prof(j,i) + ENDIF + ENDDO + + DO j = 1, nl_soil + sum_ndemand_vr(j) = plant_ndemand(i) * nuptake_prof(j) + potential_immob_vr(j,i) + ENDDO + + DO j = 1, nl_soil + IF (sum_ndemand_vr(j)*deltim < sminn_vr(j,i)) THEN + + ! N availability is not limiting immobilization or plant + ! uptake, and both can proceed at their potential rates + nlimit(j) = 0 + fpi_vr(j,i) = 1.0_r8 + actual_immob_vr(j,i) = potential_immob_vr(j,i) + sminn_to_plant_vr(j,i) = plant_ndemand(i) * nuptake_prof(j) + ELSE + ! N availability can not satisfy the sum of immobilization and + ! plant growth demands, so these two demands compete for available + ! soil mineral N resource. + + nlimit(j) = 1 + IF (sum_ndemand_vr(j) > 0.0_r8) THEN + actual_immob_vr(j,i) = (sminn_vr(j,i)/deltim)*(potential_immob_vr(j,i) / sum_ndemand_vr(j)) + ELSE + actual_immob_vr(j,i) = 0.0_r8 + ENDIF + + IF (potential_immob_vr(j,i) > 0.0_r8) THEN + fpi_vr(j,i) = actual_immob_vr(j,i) / potential_immob_vr(j,i) + ELSE + fpi_vr(j,i) = 0.0_r8 + ENDIF + + sminn_to_plant_vr(j,i) = (sminn_vr(j,i)/deltim) - actual_immob_vr(j,i) + ENDIF + + IF (DEF_USE_NOSTRESSNITROGEN) THEN + ps = patch_pft_s(i) + pe = patch_pft_e(i) + DO m = ps, pe + ivt = pftclass(m) + IF (ivt >= npcropmin) THEN + nlimit(j) = 1 + fpi_vr(j,i) = 1.0_r8 + actual_immob_vr(j,i) = potential_immob_vr(j,i) + sminn_to_plant_vr(j,i) = plant_ndemand(i) * nuptake_prof(j) + supplement_to_sminn_vr(j,i) = sum_ndemand_vr(j) - (sminn_vr(j,i)/deltim) + ENDIF + ENDDO + ENDIF + ENDDO + + ! sum up N fluxes to plant + DO j = 1, nl_soil + sminn_to_plant(i) = sminn_to_plant(i) + sminn_to_plant_vr(j,i) * dz_soi(j) + ENDDO + + ! give plants a second pass to see IF there is any mineral N left over with which to satisfy residual N demand. + residual_sminn = 0._r8 + + ! sum up total N left over after initial plant and immobilization fluxes + residual_plant_ndemand = plant_ndemand(i) - sminn_to_plant(i) + + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF (nlimit(j) .eq. 0) THEN + residual_sminn_vr(j) = max(sminn_vr(j,i) - (actual_immob_vr(j,i) + sminn_to_plant_vr(j,i) ) * deltim, 0._r8) + residual_sminn = residual_sminn + residual_sminn_vr(j) * dz_soi(j) + ELSE + residual_sminn_vr(j) = 0._r8 + ENDIF + ENDIF + ENDDO + + ! distribute residual N to plants + DO j = 1, nl_soil + IF ( residual_plant_ndemand > 0._r8 .and. residual_sminn > 0._r8 .and. nlimit(j) .eq. 0) THEN + sminn_to_plant_vr(j,i) = sminn_to_plant_vr(j,i) + residual_sminn_vr(j) * & + min(( residual_plant_ndemand * deltim ) / residual_sminn, 1._r8) / deltim + ENDIF + ENDDO + + ! re-sum up N fluxes to plant + sminn_to_plant(i) = 0._r8 + DO j = 1, nl_soil + sminn_to_plant(i) = sminn_to_plant(i) + sminn_to_plant_vr(j,i) * dz_soi(j) + sum_ndemand_vr(j) = potential_immob_vr(j,i) + sminn_to_plant_vr(j,i) + ENDDO + + ! under conditions of excess N, some proportion is assumed to + ! be lost to denitrification, in addition to the constant + ! proportion lost in the decomposition pathways + DO j = 1, nl_soil + IF ((sminn_to_plant_vr(j,i) + actual_immob_vr(j,i))*deltim < sminn_vr(j,i)) THEN + sminn_to_denit_excess_vr(j,i) = max(bdnr*deltim/86400._r8*((sminn_vr(j,i)/deltim) - sum_ndemand_vr(j)),0._r8) + ELSE + sminn_to_denit_excess_vr(j,i) = 0._r8 + ENDIF + ENDDO + + ! sum up N fluxes to immobilization + actual_immob = 0._r8 + potential_immob = 0._r8 + DO j = 1, nl_soil + actual_immob = actual_immob + actual_immob_vr(j,i) * dz_soi(j) + potential_immob = potential_immob + potential_immob_vr(j,i) * dz_soi(j) + ENDDO + + ! calculate the fraction of potential growth that can be + ! achieved with the N available to plants + IF (plant_ndemand(i) > 0.0_r8) THEN + fpg(i) = sminn_to_plant(i) / plant_ndemand(i) + ELSE + fpg(i) = 1.0_r8 + ENDIF + + ! calculate the fraction of immobilization realized (for diagnostic purposes) + IF (potential_immob > 0.0_r8) THEN + fpi(i) = actual_immob / potential_immob + ELSE + fpi(i) = 1.0_r8 + ENDIF + + ELSE + ! init total mineral N pools + sminn_tot = 0. + + ! sum up total mineral N pools + DO j = 1, nl_soil + sminn_tot = sminn_tot + (smin_no3_vr(j,i) + smin_nh4_vr(j,i)) * dz_soi(j) + ENDDO + + ! define N uptake profile for initial vertical distribution of plant N uptake, assuming plant seeks N from WHERE it is most abundant + DO j = 1, nl_soil + IF (sminn_tot > 0.) THEN + nuptake_prof(j) = sminn_vr(j,i) / sminn_tot + ELSE + nuptake_prof(j) = nfixation_prof(j,i) + ENDIF + ENDDO + + ! main column/vertical loop + DO j = 1, nl_soil + ! first compete for nh4 + sum_nh4_demand(j) = plant_ndemand(i) * nuptake_prof(j) + potential_immob_vr(j,i) + pot_f_nit_vr(j,i) + sum_nh4_demand_scaled(j) = plant_ndemand(i)* nuptake_prof(j) * compet_plant_nh4 + & + potential_immob_vr(j,i)*compet_decomp_nh4 + pot_f_nit_vr(j,i)*compet_nit + + IF (sum_nh4_demand(j)*deltim < smin_nh4_vr(j,i)) THEN + + ! NH4 availability is not limiting immobilization or plant + ! uptake, and all can proceed at their potential rates + nlimit_nh4(j) = 0 + fpi_nh4_vr(j) = 1.0_r8 + actual_immob_nh4_vr(j,i) = potential_immob_vr(j,i) + !RF added new term. + + f_nit_vr(j,i) = pot_f_nit_vr(j,i) + + smin_nh4_to_plant_vr(j,i) = plant_ndemand(i) * nuptake_prof(j) + + ELSE + + ! NH4 availability can not satisfy the sum of immobilization, nitrification, and + ! plant growth demands, so these three demands compete for available + ! soil mineral NH4 resource. + nlimit_nh4(j) = 1 + IF (sum_nh4_demand(j) > 0.0_r8) THEN + ! RF microbes compete based on the hypothesised plant demand. + actual_immob_nh4_vr(j,i) = min((smin_nh4_vr(j,i)/deltim)*(potential_immob_vr(j,i)* & + compet_decomp_nh4 / sum_nh4_demand_scaled(j)), potential_immob_vr(j,i)) + + f_nit_vr(j,i) = min((smin_nh4_vr(j,i)/deltim)*(pot_f_nit_vr(j,i)*compet_nit / & + sum_nh4_demand_scaled(j)), pot_f_nit_vr(j,i)) + + smin_nh4_to_plant_vr(j,i) = min((smin_nh4_vr(j,i)/deltim)*(plant_ndemand(i)* & + nuptake_prof(j)*compet_plant_nh4 / sum_nh4_demand_scaled(j)), plant_ndemand(i)*nuptake_prof(j)) + + ELSE + actual_immob_nh4_vr(j,i) = 0.0_r8 + smin_nh4_to_plant_vr(j,i) = 0.0_r8 + f_nit_vr(j,i) = 0.0_r8 + ENDIF + + IF (potential_immob_vr(j,i) > 0.0_r8) THEN + fpi_nh4_vr(j) = actual_immob_nh4_vr(j,i) / potential_immob_vr(j,i) + ELSE + fpi_nh4_vr(j) = 0.0_r8 + ENDIF + + ENDIF + sum_no3_demand(j) = (plant_ndemand(i)*nuptake_prof(j)-smin_nh4_to_plant_vr(j,i)) & + + (potential_immob_vr(j,i)-actual_immob_nh4_vr(j,i)) + pot_f_denit_vr(j,i) + sum_no3_demand_scaled(j) = (plant_ndemand(i)*nuptake_prof(j) & + - smin_nh4_to_plant_vr(j,i))*compet_plant_no3 & + + (potential_immob_vr(j,i)-actual_immob_nh4_vr(j,i))*compet_decomp_no3 + pot_f_denit_vr(j,i)*compet_denit + + IF (sum_no3_demand(j)*deltim < smin_no3_vr(j,i)) THEN + + ! NO3 availability is not limiting immobilization or plant + ! uptake, and all can proceed at their potential rates + nlimit_no3(j) = 0 + fpi_no3_vr(j) = 1.0_r8 - fpi_nh4_vr(j) + actual_immob_no3_vr(j,i) = (potential_immob_vr(j,i)-actual_immob_nh4_vr(j,i)) + + f_denit_vr(j,i) = pot_f_denit_vr(j,i) + + smin_no3_to_plant_vr(j,i) = (plant_ndemand(i)*nuptake_prof(j)-smin_nh4_to_plant_vr(j,i)) + ELSE + + ! NO3 availability can not satisfy the sum of immobilization, denitrification, and + ! plant growth demands, so these three demands compete for available + ! soil mineral NO3 resource. + nlimit_no3(j) = 1 + + IF (sum_no3_demand(j) > 0.0_r8) THEN + actual_immob_no3_vr(j,i) = min((smin_no3_vr(j,i)/deltim)*((potential_immob_vr(j,i) & + - actual_immob_nh4_vr(j,i))*compet_decomp_no3 / sum_no3_demand_scaled(j)), & + potential_immob_vr(j,i)-actual_immob_nh4_vr(j,i)) + + smin_no3_to_plant_vr(j,i) = min((smin_no3_vr(j,i)/deltim)*((plant_ndemand(i) & + * nuptake_prof(j)-smin_nh4_to_plant_vr(j,i))*compet_plant_no3 / sum_no3_demand_scaled(j)), & + plant_ndemand(i)*nuptake_prof(j)-smin_nh4_to_plant_vr(j,i)) + + f_denit_vr(j,i) = min((smin_no3_vr(j,i)/deltim)*(pot_f_denit_vr(j,i)*compet_denit / & + sum_no3_demand_scaled(j)), pot_f_denit_vr(j,i)) + + ELSE ! no no3 demand. no uptake fluxes. + actual_immob_no3_vr(j,i) = 0.0_r8 + smin_no3_to_plant_vr(j,i) = 0.0_r8 + f_denit_vr(j,i) = 0.0_r8 + + ENDIF !any no3 demand? + + IF (potential_immob_vr(j,i) > 0.0_r8) THEN + fpi_no3_vr(j) = actual_immob_no3_vr(j,i) / potential_immob_vr(j,i) + ELSE + fpi_no3_vr(j) = 0.0_r8 + ENDIF + + ENDIF + + ! n2o emissions: n2o from nitr is const fraction, n2o from denitr is calculated in nitrif_denitrif + f_n2o_nit_vr(j,i) = f_nit_vr(j,i) * nitrif_n2o_loss_frac + f_n2o_denit_vr(j,i) = f_denit_vr(j,i) / (1._r8 + n2_n2o_ratio_denit_vr(j,i)) + + + ! this code block controls the addition of N to sminn pool + ! to eliminate any N limitation, when Carbon_Only is set. This lets the + ! model behave essentially as a carbon-only model, but with the + ! benefit of keeping track of the N additions needed to + ! eliminate N limitations, so there is still a diagnostic quantity + ! that describes the degree of N limitation at steady-state. + IF (DEF_USE_NOSTRESSNITROGEN) THEN + ps = patch_pft_s(i) + pe = patch_pft_e(i) + DO m = ps, pe + ivt = pftclass(m) + IF (ivt >= npcropmin) THEN + IF (fpi_no3_vr(j) + fpi_nh4_vr(j) < 1._r8) THEN + fpi_nh4_vr(j) = 1.0_r8 - fpi_no3_vr(j) + supplement_to_sminn_vr(j,i) = (potential_immob_vr(j,i) & + - actual_immob_no3_vr(j,i)) - actual_immob_nh4_vr(j,i) + ! update to new values that satisfy demand + actual_immob_nh4_vr(j,i) = potential_immob_vr(j,i) - actual_immob_no3_vr(j,i) + ENDIF + IF (smin_no3_to_plant_vr(j,i) + smin_nh4_to_plant_vr(j,i) < plant_ndemand(i)*nuptake_prof(j)) THEN + supplement_to_sminn_vr(j,i) = supplement_to_sminn_vr(j,i) + & + (plant_ndemand(i)*nuptake_prof(j) - smin_no3_to_plant_vr(j,i)) - smin_nh4_to_plant_vr(j,i) ! use old values + smin_nh4_to_plant_vr(j,i) = plant_ndemand(i)*nuptake_prof(j) - smin_no3_to_plant_vr(j,i) + ENDIF + sminn_to_plant_vr(j,i) = smin_no3_to_plant_vr(j,i) + smin_nh4_to_plant_vr(j,i) + ENDIF + ENDDO + ENDIF + ! sum up no3 and nh4 fluxes + fpi_vr(j,i) = fpi_no3_vr(j) + fpi_nh4_vr(j) + sminn_to_plant_vr(j,i) = smin_no3_to_plant_vr(j,i) + smin_nh4_to_plant_vr(j,i) + actual_immob_vr(j,i) = actual_immob_no3_vr(j,i) + actual_immob_nh4_vr(j,i) + ENDDO + + ! sum up N fluxes to plant after initial competition + sminn_to_plant(i) = 0._r8 + DO j = 1, nl_soil + sminn_to_plant(i) = sminn_to_plant(i) + sminn_to_plant_vr(j,i) * dz_soi(j) + ENDDO + ! give plants a second pass to see IF there is any mineral N left over with which to satisfy residual N demand. + ! first take frm nh4 pool; THEN take from no3 pool + residual_plant_ndemand = plant_ndemand(i) - sminn_to_plant(i) + residual_smin_nh4 = 0._r8 + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF (nlimit_nh4(j) .eq. 0) THEN + residual_smin_nh4_vr(j) = max(smin_nh4_vr(j,i) - (actual_immob_nh4_vr(j,i) + & + smin_nh4_to_plant_vr(j,i) + f_nit_vr(j,i) ) * deltim, 0._r8) + + residual_smin_nh4 = residual_smin_nh4 + residual_smin_nh4_vr(j) * dz_soi(j) + ELSE + residual_smin_nh4_vr(j) = 0._r8 + ENDIF + ENDIF + ENDDO + + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF ( residual_smin_nh4 > 0._r8 .and. nlimit_nh4(j) .eq. 0 ) THEN + smin_nh4_to_plant_vr(j,i) = smin_nh4_to_plant_vr(j,i) + residual_smin_nh4_vr(j) * & + min(( residual_plant_ndemand * deltim ) / residual_smin_nh4, 1._r8) / deltim + ENDIF + ENDIF + ENDDO + + ! re-sum up N fluxes to plant after second pass for nh4 + sminn_to_plant(i) = 0._r8 + DO j = 1, nl_soil + sminn_to_plant_vr(j,i) = smin_nh4_to_plant_vr(j,i) + smin_no3_to_plant_vr(j,i) + sminn_to_plant(i) = sminn_to_plant(i) + (sminn_to_plant_vr(j,i)) * dz_soi(j) + ENDDO + + ! + ! and now DO second pass for no3 + residual_plant_ndemand = plant_ndemand(i) - sminn_to_plant(i) + residual_smin_no3 = 0._r8 + + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF (nlimit_no3(j) .eq. 0) THEN + residual_smin_no3_vr(j) = max(smin_no3_vr(j,i) - (actual_immob_no3_vr(j,i) + & + smin_no3_to_plant_vr(j,i) + f_denit_vr(j,i) ) * deltim, 0._r8) + residual_smin_no3 = residual_smin_no3 + residual_smin_no3_vr(j) * dz_soi(j) + ELSE + residual_smin_no3_vr(j) = 0._r8 + ENDIF + ENDIF + ENDDO + + DO j = 1, nl_soil + IF (residual_plant_ndemand > 0._r8 ) THEN + IF ( residual_smin_no3 > 0._r8 .and. nlimit_no3(j) .eq. 0) THEN + smin_no3_to_plant_vr(j,i) = smin_no3_to_plant_vr(j,i) + residual_smin_no3_vr(j) * & + min(( residual_plant_ndemand * deltim ) / residual_smin_no3, 1._r8) / deltim + ENDIF + ENDIF + ENDDO + + ! re-sum up N fluxes to plant after second passes of both no3 and nh4 + sminn_to_plant(i) = 0._r8 + DO j = 1, nl_soil + sminn_to_plant_vr(j,i) = smin_nh4_to_plant_vr(j,i) + smin_no3_to_plant_vr(j,i) + sminn_to_plant(i) = sminn_to_plant(i) + (sminn_to_plant_vr(j,i)) * dz_soi(j) + ENDDO + + ! sum up N fluxes to immobilization + actual_immob = 0._r8 + potential_immob = 0._r8 + DO j = 1, nl_soil + actual_immob = actual_immob + actual_immob_vr(j,i) * dz_soi(j) + potential_immob = potential_immob + potential_immob_vr(j,i) * dz_soi(j) + ENDDO + + ! calculate the fraction of potential growth that can be + ! achieved with the N available to plants + ! calculate the fraction of immobilization realized (for diagnostic purposes) + + IF (plant_ndemand(i) > 0.0_r8) THEN + fpg(i) = sminn_to_plant(i) / plant_ndemand(i) + ELSE + fpg(i) = 1._r8 + ENDIF + + IF (potential_immob > 0.0_r8) THEN + fpi(i) = actual_immob / potential_immob + ELSE + fpi(i) = 1._r8 + ENDIF + ENDIF + + END SUBROUTINE SoilBiogeochemCompetition + +END MODULE MOD_BGC_Soil_BiogeochemCompetition +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecomp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecomp.F90 new file mode 100644 index 0000000000..0ba34efc97 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecomp.F90 @@ -0,0 +1,122 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemDecomp + +!----------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE calculates the CN transfer fluxes between different soil and litter pools, +! which includes CN transfer fluxes (decomp_ctransfer or decomp_ntransfer), heterotrophic respiration (decomp_hr), +! net mineralisation and gross mineralisation. Denitrification flux will be also calculated when nitrification model +! is activated. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2021, revised original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF + USE MOD_BGC_Vars_TimeInvariants, only: & + floating_cn_ratio, initial_cn_ratio, dnp, rf_decomp, receiver_pool, donor_pool, i_atm + + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition carbon & nitrogen pools + decomp_cpools_vr, decomp_npools_vr, & + + ! other variables + cn_decomp_pools, fpi_vr + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition fluxes variables + decomp_sminn_flux_vr, decomp_hr_vr, decomp_ctransfer_vr, decomp_ntransfer_vr, & + pmnf_decomp, p_decomp_cpool_loss, sminn_to_denit_decomp_vr, & + net_nmin_vr, gross_nmin_vr, net_nmin, gross_nmin + + + IMPLICIT NONE + + PUBLIC SoilBiogeochemDecomp + +CONTAINS + + SUBROUTINE SoilBiogeochemDecomp(i,nl_soil,ndecomp_pools,ndecomp_transitions, dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + integer ,intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer + + integer j,k,l + ! calculate c:n ratios of applicable pools + DO l = 1, ndecomp_pools + IF ( floating_cn_ratio(l) ) THEN + DO j = 1,nl_soil + IF ( decomp_npools_vr(j,l,i) > 0._r8 ) THEN + cn_decomp_pools(j,l,i) = decomp_cpools_vr(j,l,i) / decomp_npools_vr(j,l,i) + ENDIF + ENDDO + ELSE + DO j = 1,nl_soil + cn_decomp_pools(j,l,i) = initial_cn_ratio(l) + ENDDO + ENDIF + ENDDO + + ! column loop to calculate actual immobilization and decomp rates, following + ! resolution of plant/heterotroph competition for mineral N + + ! upon RETURN from SoilBiogeochemCompetition, the fraction of potential immobilization + ! has been set (soilbiogeochem_state_inst%fpi_vr_col). now finish the decomp calculations. + ! only the immobilization steps are limited by fpi_vr (pmnf > 0) + ! Also calculate denitrification losses as a simple proportion + ! of mineralization flux. + + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + IF (decomp_cpools_vr(j,donor_pool(k),i) > 0._r8) THEN + IF ( pmnf_decomp(j,k,i) > 0._r8 ) THEN + p_decomp_cpool_loss(j,k,i) = p_decomp_cpool_loss(j,k,i) * fpi_vr(j,i) + pmnf_decomp(j,k,i) = pmnf_decomp(j,k,i) * fpi_vr(j,i) + IF(.not. DEF_USE_NITRIF)THEN + sminn_to_denit_decomp_vr(j,k,i) = 0._r8 + ENDIF + ELSE + IF(.not. DEF_USE_NITRIF)THEN + sminn_to_denit_decomp_vr(j,k,i) = -dnp * pmnf_decomp(j,k,i) + ENDIF + ENDIF + decomp_hr_vr(j,k,i) = rf_decomp(j,k,i) * p_decomp_cpool_loss(j,k,i) + decomp_ctransfer_vr(j,k,i) = (1._r8 - rf_decomp(j,k,i)) * p_decomp_cpool_loss(j,k,i) + IF (decomp_npools_vr(j,donor_pool(k),i) > 0._r8 .and. receiver_pool(k) /= i_atm) THEN + decomp_ntransfer_vr(j,k,i) = p_decomp_cpool_loss(j,k,i) / cn_decomp_pools(j,donor_pool(k),i) + ELSE + decomp_ntransfer_vr(j,k,i) = 0._r8 + ENDIF + IF ( receiver_pool(k) /= 0 ) THEN + decomp_sminn_flux_vr(j,k,i) = pmnf_decomp(j,k,i) + ELSE ! keep sign convention negative for terminal pools + decomp_sminn_flux_vr(j,k,i) = - pmnf_decomp(j,k,i) + ENDIF + net_nmin_vr(j,i) = net_nmin_vr(j,i) - pmnf_decomp(j,k,i) + ELSE + decomp_ntransfer_vr(j,k,i) = 0._r8 + IF(.not. DEF_USE_NITRIF)THEN + sminn_to_denit_decomp_vr(j,k,i) = 0._r8 + ENDIF + decomp_sminn_flux_vr(j,k,i) = 0._r8 + ENDIF + + ENDDO + ENDDO + + DO j = 1,nl_soil + net_nmin(i) = net_nmin(i) + net_nmin_vr(j,i) * dz_soi(j) + gross_nmin(i) = gross_nmin(i) + gross_nmin_vr(j,i) * dz_soi(j) + ENDDO + + END SUBROUTINE SoilBiogeochemDecomp + +END MODULE MOD_BGC_Soil_BiogeochemDecomp +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecompCascadeBGC.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecompCascadeBGC.F90 new file mode 100644 index 0000000000..23f23f2056 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemDecompCascadeBGC.F90 @@ -0,0 +1,122 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemDecompCascadeBGC + +!--------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate the soil decomposition rate according to soil temperature, soil matric potential, and depth +! +! !REFERENCES: +! Koven, C.D., Riley, W.J., Subin, Z.M., Tang, J.Y., Torn, M.S., Collins, W.D., Bonan, G.B., Lawrence, +! D.M. and Swenson, S.C., 2013. The effect of vertically resolved soil biogeochemistry and alternate +! soil C and N models on C dynamics of CLM4. Biogeosciences, 10(11), 7109-7131. +! Thornton, P.E., Law, B.E., Gholz, H.L., Clark, K.L., Falge, E., Ellsworth, D.S., Goldstein, A.H., Monson, +! R.K., Hollinger, D., Falk, M. and Chen, J., 2002. Modeling and measuring the effects of disturbance +! history and climate on carbon and water budgets in evergreen needleleaf forests. +! Agricultural and forest meteorology, 113(1-4), 185-222. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Vars_TimeInvariants, only: & + Q10, smpmax_hr, smpmin_hr, tau_l1, tau_l2_l3, tau_s1, tau_s2, tau_s3, tau_cwd, froz_q10, & + i_met_lit,i_cel_lit,i_lig_lit ,i_cwd,i_soil1,i_soil2,i_soil3 + USE MOD_Vars_TimeVariables, only: & + smp, t_soisno, t_scalar, w_scalar, o_scalar, depth_scalar, decomp_k + USE MOD_Vars_Global, only: PI + + IMPLICIT NONE + + PUBLIC decomp_rate_constants_bgc + +CONTAINS + + SUBROUTINE decomp_rate_constants_bgc(i,nl_soil,z_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: z_soi(1:nl_soil) ! depth of each soil layer + + real(r8) normalization_factor ! factor by which to offset the decomposition rates frm century to a q10 formulation + real(r8),parameter :: decomp_depth_efolding = 10._r8 + real(r8) k_l1, k_l2_l3, k_s1, k_s2, k_s3, k_frag + real(r8) psi + integer j + real(r8) catanf + real(r8) catanf_30 + real(r8) t1 + + catanf(t1) = 11.75_r8 +(29.7_r8 / PI) * atan( PI * 0.031_r8 * ( t1 - 15.4_r8 )) + + ! translate to per-second time constant + k_l1 = 1._r8 / (86400._r8 * 365._r8 * tau_l1) + k_l2_l3 = 1._r8 / (86400._r8 * 365._r8 * tau_l2_l3) + k_s1 = 1._r8 / (86400._r8 * 365._r8 * tau_s1) + k_s2 = 1._r8 / (86400._r8 * 365._r8 * tau_s2) + k_s3 = 1._r8 / (86400._r8 * 365._r8 * tau_s3) + k_frag = 1._r8 / (86400._r8 * 365._r8 * tau_cwd) + + ! calc ref rate + catanf_30 = catanf(30._r8) + + DO j = 1, nl_soil + IF (t_soisno(j,i) >= 273.15_r8) THEN + t_scalar(j,i)= (Q10**((t_soisno(j,i)-(273.15_r8+25._r8))/10._r8)) + ELSE + t_scalar(j,i)= (Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(j,i)-273.15_r8)/10._r8)) + ENDIF + ENDDO + + ! calculate the rate constant scalar for soil water content. + ! Uses the log relationship with water potential given in + ! Andren, O., and K. Paustian, 1987. Barley straw decomposition in the field: + ! a comparison of models. Ecology, 68(5):1190-1200. + ! and supported by data in + ! Orchard, V.A., and F.J. Cook, 1983. Relationship between soil respiration + ! and soil moisture. Soil Biol. Biochem., 15(4):447-453. + + DO j = 1,nl_soil + psi = min(smp(j,i),smpmax_hr) + ! decomp only IF soilpsi is higher than minpsi + IF (psi > smpmin_hr) THEN + w_scalar(j,i) = (log(smpmin_hr/psi)/log(smpmin_hr/smpmax_hr)) + ELSE + w_scalar(j,i) = 0.001_r8 + ! update froot_prof_p for root carbon turnover when soil is frozen + ENDIF + ENDDO + + o_scalar(1:nl_soil,i) = 1._r8 + + ! scale all decomposition rates by a constant to compensate for offset between original CENTURY temp func and Q10 + normalization_factor = (catanf(15._r8)/catanf_30) / (Q10**((15._r8-25._r8)/10._r8)) + DO j = 1, nl_soil + t_scalar(j,i) = t_scalar(j,i) * normalization_factor + ENDDO + + DO j = 1, nl_soil + depth_scalar(j,i) = exp(-z_soi(j)/decomp_depth_efolding) + ENDDO + + DO j = 1, nl_soil + decomp_k(j,i_met_lit,i) = k_l1 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_cel_lit,i) = k_l2_l3 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_lig_lit,i) = k_l2_l3 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_soil1 ,i) = k_s1 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_soil2 ,i) = k_s2 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + decomp_k(j,i_soil3 ,i) = k_s3 * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * o_scalar(j,i) !& + ENDDO + + DO j = 1,nl_soil + decomp_k(j,i_cwd,i) = k_frag * t_scalar(j,i) * w_scalar(j,i) * depth_scalar(j,i) * & + o_scalar(j,i) + ENDDO + + END SUBROUTINE decomp_rate_constants_bgc + +END MODULE MOD_BGC_Soil_BiogeochemDecompCascadeBGC +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemLittVertTransp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemLittVertTransp.F90 new file mode 100644 index 0000000000..27a2cb36e3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemLittVertTransp.F90 @@ -0,0 +1,333 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemLittVertTransp + +!---------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Simulate the soil and litter CN vertical mixing (diffusion and advection) processes. Solve the dynamics +! of soil and litter vertical profile with a tridiagonal matrix. +! +! !REFERENCES: +! Koven, C.D., Riley, W.J., Subin, Z.M., Tang, J.Y., Torn, M.S., Collins, W.D., Bonan, G.B., Lawrence, +! D.M. and Swenson, S.C., 2013. The effect of vertically resolved soil biogeochemistry and alternate +! soil C and N models on C dynamics of CLM4. Biogeosciences, 10(11), 7109-7131. +! Thornton, P.E., Law, B.E., Gholz, H.L., Clark, K.L., Falge, E., Ellsworth, D.S., Goldstein, A.H., Monson, +! R.K., Hollinger, D., Falk, M. and Chen, J., 2002. Modeling and measuring the effects of disturbance +! history and climate on carbon and water budgets in evergreen needleleaf forests. +! Agricultural and forest meteorology, 113(1-4), 185-222. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, 1) Revised the CLM5 code to be compatible with CoLM code structure. +! 2) Record accumulated organic CN vertical transfer rates for semi-analytic spin-up. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_BGC_Vars_TimeInvariants, only: & + is_cwd, som_adv_flux, som_diffus, cryoturb_diffusion_k, max_altdepth_cryoturbation, max_depth_cryoturb + USE MOD_BGC_Vars_TimeVariables, only: & + altmax, altmax_lastyear, som_adv_coef, som_diffus_coef, & + decomp_cpools_vr, decomp_npools_vr, & + diagVX_c_vr_acc, upperVX_c_vr_acc, lowerVX_c_vr_acc, & + diagVX_n_vr_acc, upperVX_n_vr_acc, lowerVX_n_vr_acc + USE MOD_BGC_Vars_1DFluxes, only: & + decomp_cpools_sourcesink, decomp_npools_sourcesink, & + decomp_cpools_transport_tendency, decomp_npools_transport_tendency + USE MOD_Utils, only: tridia + + IMPLICIT NONE + + PUBLIC SoilBiogeochemLittVertTransp + +CONTAINS + + SUBROUTINE SoilBiogeochemLittVertTransp(i,deltim,nl_soil,nl_soil_full,ndecomp_pools,nbedrock,z_soi,zi_soi,dz_soi) + + integer ,intent(in) :: i ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: nl_soil_full ! number of total soil layers plus bedrock layers + integer ,intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + integer ,intent(in) :: nbedrock ! where bedrock layer starts + real(r8),intent(in) :: z_soi (1:nl_soil_full) ! depth of each soil layer (m) + real(r8),intent(in) :: zi_soi(0:nl_soil_full) ! interface level below a zsoi level (m) + real(r8),intent(in) :: dz_soi(1:nl_soil_full) ! thicknesses of each soil layer (m) + + ! !LOCAL VARIABLES: + real(r8) :: diffus (1:nl_soil+1) ! diffusivity (m2/s) (includes spinup correction, if any) + real(r8) :: adv_flux(1:nl_soil+1) ! advective flux (m/s) (includes spinup correction, if any) + real(r8) :: aaa ! "A" function in Patankar + real(r8) :: pe ! Pe for "A" function in Patankar + real(r8) :: w_m1, w_p1 ! Weights for calculating harmonic mean of diffusivity + real(r8) :: d_m1, d_p1 ! Harmonic mean of diffusivity + real(r8) :: a_tri(0:nl_soil+1) ! "a" vector for tridiagonal matrix + real(r8) :: b_tri(0:nl_soil+1) ! "b" vector for tridiagonal matrix + real(r8) :: c_tri(0:nl_soil+1) ! "c" vector for tridiagonal matrix + real(r8) :: r_tri_c(0:nl_soil+1) ! "r" vector for tridiagonal solution for soil C + real(r8) :: r_tri_n(0:nl_soil+1) ! "r" vector for tridiagonal solution for soil N + real(r8) :: d_p1_zp1(1:nl_soil+1) ! diffusivity/delta_z for next j (set to zero for no diffusion) + real(r8) :: d_m1_zm1(1:nl_soil+1) ! diffusivity/delta_z for previous j (set to zero for no diffusion) + real(r8) :: f_p1(1:nl_soil+1) ! water flux for next j + real(r8) :: f_m1(1:nl_soil+1) ! water flux for previous j + real(r8) :: pe_p1(1:nl_soil+1) ! Peclet # for next j + real(r8) :: pe_m1(1:nl_soil+1) ! Peclet # for previous j + real(r8) :: dz_node(1:nl_soil+1) ! difference between nodes + real(r8) :: conc_trcr_c(0:nl_soil+1) ! dummy term + real(r8) :: conc_trcr_n(0:nl_soil+1) ! dummy term + real(r8) :: a_p_0 + integer :: s,j,l ! indices + integer :: jtop ! top level at each column + real(r8) :: spinup_term ! spinup accelerated decomposition factor, used to accelerate transport as well + real(r8) :: epsilon ! small number + + aaa (pe) = max (0._r8, (1._r8 - 0.1_r8 * abs(pe))**5) ! A function from Patankar, Table 5.2, pg 95 + + epsilon = 1.e-30 + spinup_term = 1._r8 + + IF (( max(altmax(i), altmax_lastyear(i)) <= max_altdepth_cryoturbation ) .and. & + ( max(altmax(i), altmax_lastyear(i)) > 0._r8) ) THEN + ! use mixing profile modified slightly from Koven et al. (2009): constant through active layer, linear decrease from base of active layer to zero at a fixed depth + DO j = 1,nl_soil+1 + IF ( j <= nbedrock+1 ) THEN + IF ( zi_soi(j) < max(altmax(i), altmax_lastyear(i)) ) THEN + som_diffus_coef(j,i) = cryoturb_diffusion_k + som_adv_coef(j,i) = 0._r8 + ELSE + som_diffus_coef(j,i) = max(cryoturb_diffusion_k * & + ( 1._r8 - ( zi_soi(j) - max(altmax(i), altmax_lastyear(i)) ) / & + ( min(max_depth_cryoturb, zi_soi(nbedrock+1)) - max(altmax(i), altmax_lastyear(i)) ) ), 0._r8) ! go linearly to zero between ALT and max_depth_cryoturb + som_adv_coef(j,i) = 0._r8 + ENDIF + ELSE + som_adv_coef(j,i) = 0._r8 + som_diffus_coef(j,i) = 0._r8 + ENDIF + ENDDO + ELSEIF ( max(altmax(i), altmax_lastyear(i)) > 0._r8 ) THEN + ! constant advection, constant diffusion + DO j = 1,nl_soil+1 + IF ( j <= nbedrock+1 ) THEN + som_adv_coef(j,i) = som_adv_flux + som_diffus_coef(j,i) = som_diffus + ELSE + som_adv_coef(j,i) = 0._r8 + som_diffus_coef(j,i) = 0._r8 + ENDIF + ENDDO + ELSE + ! completely frozen soils--no mixing + DO j = 1,nl_soil+1 + som_adv_coef(j,i) = 0._r8 + som_diffus_coef(j,i) = 0._r8 + ENDDO + ENDIF + + ! Set the distance between the node and the one ABOVE it + dz_node(1) = z_soi(1) + DO j = 2, nl_soil+1 + dz_node(j)= z_soi(j) - z_soi(j-1) + ENDDO + + DO s = 1, ndecomp_pools + IF ( .not. is_cwd(s) ) THEN + DO j = 1,nl_soil+1 + IF ( abs(som_adv_coef(j,i)) * spinup_term < epsilon ) THEN + adv_flux(j) = epsilon + ELSE + adv_flux(j) = som_adv_coef(j,i) * spinup_term + ENDIF + ! + IF ( abs(som_diffus_coef(j,i)) * spinup_term < epsilon ) THEN + diffus(j) = epsilon + ELSE + diffus(j) = som_diffus_coef(j,i) * spinup_term + ENDIF + ! + ENDDO + + ! Set Pe (Peclet #) and D/dz throughout column + conc_trcr_c(0) = 0._r8 + conc_trcr_n(0) = 0._r8 + conc_trcr_c(nbedrock+1:nl_soil+1) = 0._r8 + conc_trcr_n(nbedrock+1:nl_soil+1) = 0._r8 + + DO j = 1,nl_soil+1 + conc_trcr_c(j) = decomp_cpools_vr(j,s,i) + conc_trcr_n(j) = decomp_npools_vr(j,s,i) + + ! dz_tracer below is the difference between gridcell edges (dz_soi) + ! dz_node_tracer is difference between cell centers + + ! Calculate the D and F terms in the Patankar algorithm + IF (j == 1) THEN + d_m1_zm1(j) = 0._r8 + w_p1 = (z_soi(j+1) - zi_soi(j)) / dz_node(j+1) + IF ( diffus(j+1) > 0._r8 .and. diffus(j) > 0._r8) THEN + d_p1 = 1._r8 / ((1._r8 - w_p1) / diffus(j) + w_p1 / diffus(j+1)) ! Harmonic mean of diffus + ELSE + d_p1 = 0._r8 + ENDIF + d_p1_zp1(j) = d_p1 / dz_node(j+1) + f_m1(j) = adv_flux(j) ! Include infiltration here + f_p1(j) = adv_flux(j+1) + pe_m1(j) = 0._r8 + pe_p1(j) = f_p1(j) / d_p1_zp1(j) ! Peclet # + ELSEIF (j >= nbedrock+1) THEN + ! At the bottom, assume no gradient in d_z (i.e., they're the same) + w_m1 = (zi_soi(j-1) - z_soi(j-1)) / dz_node(j) + IF ( diffus(j) > 0._r8 .and. diffus(j-1) > 0._r8) THEN + d_m1 = 1._r8 / ((1._r8 - w_m1) / diffus(j) + w_m1 / diffus(j-1)) ! Harmonic mean of diffus + ELSE + d_m1 = 0._r8 + ENDIF + d_m1_zm1(j) = d_m1 / dz_node(j) + d_p1_zp1(j) = d_m1_zm1(j) ! Set to be the same + f_m1(j) = adv_flux(j) + f_p1(j) = 0._r8 + pe_m1(j) = f_m1(j) / d_m1_zm1(j) ! Peclet # + pe_p1(j) = f_p1(j) / d_p1_zp1(j) ! Peclet # + ELSE + ! Use distance from j-1 node to interface with j divided by distance between nodes + w_m1 = (zi_soi(j-1) - z_soi(j-1)) / dz_node(j) + IF ( diffus(j-1) > 0._r8 .and. diffus(j) > 0._r8) THEN + d_m1 = 1._r8 / ((1._r8 - w_m1) / diffus(j) + w_m1 / diffus(j-1)) ! Harmonic mean of diffus + ELSE + d_m1 = 0._r8 + ENDIF + w_p1 = (z_soi(j+1) - zi_soi(j)) / dz_node(j+1) + IF ( diffus(j+1) > 0._r8 .and. diffus(j) > 0._r8) THEN + d_p1 = 1._r8 / ((1._r8 - w_p1) / diffus(j) + w_p1 / diffus(j+1)) ! Harmonic mean of diffus + ELSE + d_p1 = (1._r8 - w_p1) * diffus(j) + w_p1 * diffus(j+1) ! Arithmetic mean of diffus + ENDIF + d_m1_zm1(j) = d_m1 / dz_node(j) + d_p1_zp1(j) = d_p1 / dz_node(j+1) + f_m1(j) = adv_flux(j) + f_p1(j) = adv_flux(j+1) + pe_m1(j) = f_m1(j) / d_m1_zm1(j) ! Peclet # + pe_p1(j) = f_p1(j) / d_p1_zp1(j) ! Peclet # + ENDIF + ENDDO ! j; nl_soil + + ! Calculate the tridiagonal coefficients + DO j = 0,nl_soil +1 + + IF (j > 0 .and. j < nl_soil+1) THEN + a_p_0 = dz_soi(j) / deltim + ENDIF + + IF (j == 0) THEN ! top layer (atmosphere) + a_tri(j) = 0._r8 + b_tri(j) = 1._r8 + c_tri(j) = -1._r8 + r_tri_c(j) = 0._r8 + r_tri_n(j) = 0._r8 + ELSEIF (j == 1) THEN + a_tri(j) = -(d_m1_zm1(j) * aaa(pe_m1(j)) + max( f_m1(j), 0._r8)) ! Eqn 5.47 Patankar + c_tri(j) = -(d_p1_zp1(j) * aaa(pe_p1(j)) + max(-f_p1(j), 0._r8)) + b_tri(j) = - a_tri(j) - c_tri(j) + a_p_0 + r_tri_c(j) = decomp_cpools_sourcesink(j,s,i) * dz_soi(j) /deltim + (a_p_0 - adv_flux(j)) * conc_trcr_c(j) + r_tri_n(j) = decomp_npools_sourcesink(j,s,i) * dz_soi(j) /deltim + (a_p_0 - adv_flux(j)) * conc_trcr_n(j) + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + upperVX_c_vr_acc(j,s,i) = upperVX_c_vr_acc(j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j+1)! upwards transfer + diagVX_c_vr_acc (j,s,i) = diagVX_c_vr_acc (j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j)! EXIT flux + upperVX_n_vr_acc(j,s,i) = upperVX_n_vr_acc(j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j+1)! upwards transfer + diagVX_n_vr_acc (j,s,i) = diagVX_n_vr_acc (j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j)! EXIT flux + ENDIF + ELSEIF (j < nl_soil+1) THEN + + a_tri(j) = -(d_m1_zm1(j) * aaa(pe_m1(j)) + max( f_m1(j), 0._r8)) ! Eqn 5.47 Patankar + c_tri(j) = -(d_p1_zp1(j) * aaa(pe_p1(j)) + max(-f_p1(j), 0._r8)) + b_tri(j) = - a_tri(j) - c_tri(j) + a_p_0 + r_tri_c(j) = decomp_cpools_sourcesink(j,s,i) * dz_soi(j) /deltim + a_p_0 * conc_trcr_c(j) + r_tri_n(j) = decomp_npools_sourcesink(j,s,i) * dz_soi(j) /deltim + a_p_0 * conc_trcr_n(j) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + IF(j .le. nbedrock)THEN + lowerVX_c_vr_acc(j,s,i) = lowerVX_c_vr_acc(j,s,i) - a_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j-1) + lowerVX_n_vr_acc(j,s,i) = lowerVX_n_vr_acc(j,s,i) - a_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j-1) + IF(j .ne. nl_soil)THEN + upperVX_c_vr_acc(j,s,i) = upperVX_c_vr_acc(j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j+1) + upperVX_n_vr_acc(j,s,i) = upperVX_n_vr_acc(j,s,i) - c_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j+1) + diagVX_c_vr_acc(j,s,i) = diagVX_c_vr_acc(j,s,i) + (b_tri(j) - a_p_0) / dz_soi(j) * deltim * conc_trcr_c(j) + diagVX_n_vr_acc(j,s,i) = diagVX_n_vr_acc(j,s,i) + (b_tri(j) - a_p_0) / dz_soi(j) * deltim * conc_trcr_n(j) + ELSE + diagVX_c_vr_acc(j,s,i) = diagVX_c_vr_acc (j,s,i) - a_tri(j) / dz_soi(j) * deltim * conc_trcr_c(j) + diagVX_n_vr_acc(j,s,i) = diagVX_n_vr_acc (j,s,i) - a_tri(j) / dz_soi(j) * deltim * conc_trcr_n(j) + ENDIF + ELSE + IF(j .eq. nbedrock + 1 .and. j .ne. nl_soil .and. j .gt. 1)THEN + diagVX_c_vr_acc(j-1,s,i) = diagVX_c_vr_acc(j-1,s,i) + a_tri(j) / dz_soi(j-1) * deltim * conc_trcr_c(j-1) + diagVX_n_vr_acc(j-1,s,i) = diagVX_n_vr_acc(j-1,s,i) + a_tri(j) / dz_soi(j-1) * deltim * conc_trcr_n(j-1) + ENDIF + ENDIF + ENDIF + ELSE ! j==nl_soil+1; 0 concentration gradient at bottom + a_tri(j) = -1._r8 + b_tri(j) = 1._r8 + c_tri(j) = 0._r8 + r_tri_c(j) = 0._r8 + r_tri_n(j) = 0._r8 + ENDIF + ENDDO ! j; nl_soil + + jtop = 0 + + ! subtract initial concentration and source terms for tendency calculation + DO j = 1, nl_soil + decomp_cpools_transport_tendency(j,s,i) = 0.-(conc_trcr_c(j) + decomp_cpools_sourcesink(j,s,i)) + decomp_npools_transport_tendency(j,s,i) = 0.-(conc_trcr_n(j) + decomp_npools_sourcesink(j,s,i)) + ENDDO + + CALL tridia(nl_soil+2, a_tri (:), b_tri(:), c_tri(:), r_tri_c(:), conc_trcr_c(0:nl_soil+1)) + CALL tridia(nl_soil+2, a_tri (:), b_tri(:), c_tri(:), r_tri_n(:), conc_trcr_n(0:nl_soil+1)) + + ! add post-transport concentration to calculate tendency term + DO j = 1, nl_soil + decomp_cpools_transport_tendency(j,s,i) = decomp_cpools_transport_tendency(j,s,i) + conc_trcr_c(j) + decomp_cpools_transport_tendency(j,s,i) = decomp_cpools_transport_tendency(j,s,i) / deltim + decomp_npools_transport_tendency(j,s,i) = decomp_npools_transport_tendency(j,s,i) + conc_trcr_n(j) + decomp_npools_transport_tendency(j,s,i) = decomp_npools_transport_tendency(j,s,i) / deltim + ENDDO + ELSE + ! for CWD pools, just add + DO j = 1,nl_soil + conc_trcr_c(j) = decomp_cpools_vr(j,s,i) + decomp_cpools_sourcesink(j,s,i) + conc_trcr_n(j) = decomp_npools_vr(j,s,i) + decomp_npools_sourcesink(j,s,i) + IF (j > nbedrock .and. decomp_cpools_sourcesink(j,s,i) > 0._r8) THEN + write(*,*) 'C source >0',i,j,s,decomp_cpools_sourcesink(j,s,i) + ENDIF + IF (j > nbedrock .and. decomp_cpools_vr(j,s,i) > 0._r8) THEN + write(*,*) 'C conc_ptr >0',i,j,s,decomp_cpools_vr(j,s,i) + ENDIF + IF (j > nbedrock .and. decomp_npools_sourcesink(j,s,i) > 0._r8) THEN + write(*,*) 'N source >0',i,j,s,decomp_npools_sourcesink(j,s,i) + ENDIF + IF (j > nbedrock .and. decomp_npools_vr(j,s,i) > 0._r8) THEN + write(*,*) 'N conc_ptr >0',i,j,s,decomp_npools_vr(j,s,i) + ENDIF + ENDDO + ENDIF ! not CWD + + DO j = 1,nl_soil + decomp_cpools_vr(j,s,i) = conc_trcr_c(j) + decomp_npools_vr(j,s,i) = conc_trcr_n(j) + ! Correct for small amounts of carbon that leak into bedrock + IF (j > nbedrock) THEN + decomp_cpools_vr(nbedrock,s,i) = decomp_cpools_vr(nbedrock,s,i) + & + conc_trcr_c(j) * (dz_soi(j) / dz_soi(nbedrock)) + decomp_cpools_vr(j,s,i) = 0._r8 + decomp_npools_vr(nbedrock,s,i) = decomp_npools_vr(nbedrock,s,i) + & + conc_trcr_n(j) * (dz_soi(j) / dz_soi(nbedrock)) + decomp_npools_vr(j,s,i) = 0._r8 + ENDIF + ENDDO + ENDDO ! s (pool loop) + + END SUBROUTINE SoilBiogeochemLittVertTransp + +END MODULE MOD_BGC_Soil_BiogeochemLittVertTransp +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNLeaching.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNLeaching.F90 new file mode 100644 index 0000000000..d5f322a15c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNLeaching.F90 @@ -0,0 +1,167 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_Soil_BiogeochemNLeaching + +!---------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculates the soil mineral N loss due to leaching. The leaching flux is a function of +! dissolved N concentration and sub-surface drainage flux. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2021, revised original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_NITRIF + USE MOD_BGC_Vars_TimeInvariants, only: sf, sf_no3 + USE MOD_Vars_TimeVariables, only: wliq_soisno + USE MOD_BGC_Vars_TimeVariables, only: sminn_vr, smin_no3_vr + USE MOD_Vars_1DFluxes, only: rnof, rsur + USE MOD_BGC_Vars_1DFluxes, only: & + sminn_leached_vr, smin_no3_leached_vr, smin_no3_runoff_vr + + IMPLICIT NONE + + PUBLIC SoilBiogeochemNLeaching + +CONTAINS + + SUBROUTINE SoilBiogeochemNLeaching(i,deltim,nl_soil,zi_soi,dz_soi) + + integer ,intent(in) :: i ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: zi_soi(0:nl_soil) ! interface level below a zsoi level (m) + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + + integer :: j ! indices + real(r8) :: disn_conc ! dissolved mineral N concentration (gN/kg water) + real(r8) :: tot_water ! total column liquid water (kg water/m2) + real(r8) :: surface_water ! liquid water to shallow surface depth (kg water/m2) + real(r8) :: drain_tot ! total drainage flux (mm H2O /s) + real(r8), parameter :: depth_runoff_Nloss = 0.05 ! (m) depth over which runoff mixes with soil water for N loss to runoff + + ! calculate the total soil water + tot_water = 0._r8 + DO j = 1,nl_soil + tot_water = tot_water + wliq_soisno(j,i) + ENDDO + + ! for runoff calculation; calculate total water to a given depth + surface_water = 0._r8 + DO j = 1,nl_soil + IF ( zi_soi(j) <= depth_runoff_Nloss) THEN + surface_water = surface_water + wliq_soisno(j,i) + elseif ( zi_soi(j-1) < depth_runoff_Nloss) THEN + surface_water = surface_water + wliq_soisno(j,i) * ( (depth_runoff_Nloss - zi_soi(j-1)) / dz_soi(j)) + ENDIF + ENDDO + + ! Loop through columns + drain_tot = rnof(i) - rsur(i) + + + IF(.not. DEF_USE_NITRIF)THEN + !---------------------------------------- + ! --------- NITRIF_NITRIF OFF------------ + !---------------------------------------- + DO j = 1,nl_soil + ! calculate the dissolved mineral N concentration (gN/kg water) + ! assumes that 10% of mineral nitrogen is soluble + disn_conc = 0._r8 + IF (wliq_soisno(j,i) > 0._r8) THEN + disn_conc = (sf * sminn_vr(j,i) * dz_soi(j) )/(wliq_soisno(j,i) ) + ENDIF + + ! calculate the N leaching flux as a FUNCTION of the dissolved + ! concentration and the sub-surface drainage flux + IF(tot_water > 0._r8)THEN + sminn_leached_vr(j,i) = disn_conc * drain_tot * wliq_soisno(j,i) / ( tot_water * dz_soi(j) ) + ELSE + sminn_leached_vr(j,i) = 0._r8 + ENDIF + + ! limit the flux based on current sminn state + ! only let at most the assumed soluble fraction + ! of sminn be leached on any given timestep + sminn_leached_vr(j,i) = min(sminn_leached_vr(j,i), (sf * sminn_vr(j,i))/deltim) + + ! limit the flux to a positive value + sminn_leached_vr(j,i) = max(sminn_leached_vr(j,i), 0._r8) + + ENDDO + + ELSE + + !---------------------------------------- + ! --------- NITRIF_NITRIF ON------------- + !---------------------------------------- + + DO j = 1,nl_soil + ! calculate the dissolved mineral N concentration (gN/kg water) + ! assumes that 10% of mineral nitrogen is soluble + disn_conc = 0._r8 + IF (wliq_soisno(j,i) > 0._r8) THEN + disn_conc = (sf_no3 * smin_no3_vr(j,i) * dz_soi(j) )/(wliq_soisno(j,i) ) + ENDIF + ! + ! calculate the N leaching flux as a FUNCTION of the dissolved + ! concentration and the sub-surface drainage flux + IF(tot_water > 0._r8)THEN + smin_no3_leached_vr(j,i) = disn_conc * drain_tot * wliq_soisno(j,i) / ( tot_water * dz_soi(j) ) + ELSE + smin_no3_leached_vr(j,i) = 0._r8 + ENDIF + ! + ! ensure that leaching rate isn't larger than soil N pool + smin_no3_leached_vr(j,i) = min(smin_no3_leached_vr(j,i), smin_no3_vr(j,i) / deltim ) + ! + ! limit the leaching flux to a positive value + smin_no3_leached_vr(j,i) = max(smin_no3_leached_vr(j,i), 0._r8) + ! + ! + ! calculate the N loss from surface runoff, assuming a shallow mixing of surface waters into soil and removal based on runoff + IF ( zi_soi(j) <= depth_runoff_Nloss ) THEN + IF(surface_water > 0._r8)THEN + smin_no3_runoff_vr(j,i) = disn_conc * rsur(i) * & + wliq_soisno(j,i) / ( surface_water * dz_soi(j) ) + ELSE + smin_no3_runoff_vr(j,i) = 0._r8 + ENDIF + ELSEIF ( zi_soi(j-1) < depth_runoff_Nloss ) THEN + IF(surface_water > 0._r8)THEN + smin_no3_runoff_vr(j,i) = disn_conc * rsur(i) * & + wliq_soisno(j,i) * ((depth_runoff_Nloss - zi_soi(j-1)) / & + dz_soi(j)) / ( surface_water * (depth_runoff_Nloss-zi_soi(j-1) )) + ELSE + smin_no3_runoff_vr(j,i) = 0._r8 + ENDIF + ELSE + smin_no3_runoff_vr(j,i) = 0._r8 + ENDIF + ! + ! ensure that runoff rate isn't larger than soil N pool + smin_no3_runoff_vr(j,i) = min(smin_no3_runoff_vr(j,i), smin_no3_vr(j,i) / deltim - smin_no3_leached_vr(j,i)) + ! + ! limit the flux to a positive value + smin_no3_runoff_vr(j,i) = max(smin_no3_runoff_vr(j,i), 0._r8) + + + ! limit the flux based on current smin_no3 state + ! only let at most the assumed soluble fraction + ! of smin_no3 be leached on any given timestep + smin_no3_leached_vr(j,i) = min(smin_no3_leached_vr(j,i), (sf_no3 * smin_no3_vr(j,i))/deltim) + + ! limit the flux to a positive value + smin_no3_leached_vr(j,i) = max(smin_no3_leached_vr(j,i), 0._r8) + + ENDDO + ENDIF + + END SUBROUTINE SoilBiogeochemNLeaching + +END MODULE MOD_BGC_Soil_BiogeochemNLeaching +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 new file mode 100644 index 0000000000..9c60ecb83f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNStateUpdate1.F90 @@ -0,0 +1,244 @@ +#include +#ifdef BGC + +MODULE MOD_BGC_Soil_BiogeochemNStateUpdate1 + +!--------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Updates soil mineral nitrogen pool sizes. The dynamics of soil mineral nitrogen pool is +! simulated according to fertilisation, nitrogen deposition, biological fixation, plant uptake, +! mineralisation and immobilisation in this module. IF nitrification is activated, nitrate nitrogen +! has a separated pool against ammonium nitrogen pool. Accumulated nitrogen transfer +! network is also recorded for semi-analytic spinup. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2022, 1) modify original CLM5 to be compatible with CoLM code structure. +! 2) Record accumulated nitrogen transfer network for semi-analytic spinup + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix, DEF_USE_NITRIF, DEF_USE_CNSOYFIXN + USE MOD_BGC_Vars_TimeInvariants, only: & + ! bgc constants + i_met_lit, i_cel_lit, i_lig_lit, i_cwd, i_soil1, i_soil2, i_soil3 + USE MOD_BGC_Vars_TimeInvariants, only: & + receiver_pool, donor_pool, nitrif_n2o_loss_frac + + USE MOD_BGC_Vars_TimeVariables, only: & + ! Mineral nitrogen pools (inout) + sminn_vr , smin_nh4_vr , smin_no3_vr , & + ndep_prof , nfixation_prof , & + AKX_met_to_soil1_n_vr_acc , AKX_cel_to_soil1_n_vr_acc , AKX_lig_to_soil2_n_vr_acc , AKX_soil1_to_soil2_n_vr_acc, & + AKX_cwd_to_cel_n_vr_acc , AKX_cwd_to_lig_n_vr_acc , AKX_soil1_to_soil3_n_vr_acc, AKX_soil2_to_soil1_n_vr_acc, & + AKX_soil2_to_soil3_n_vr_acc, AKX_soil3_to_soil1_n_vr_acc, & + AKX_met_exit_n_vr_acc , AKX_cel_exit_n_vr_acc , AKX_lig_exit_n_vr_acc , AKX_cwd_exit_n_vr_acc , & + AKX_soil1_exit_n_vr_acc , AKX_soil2_exit_n_vr_acc , AKX_soil3_exit_n_vr_acc + + USE MOD_BGC_Vars_1DFluxes, only: & + ! Decomposition fluxes variables (inout) + decomp_npools_sourcesink, decomp_ntransfer_vr , decomp_sminn_flux_vr , sminn_to_denit_decomp_vr, & + gross_nmin_vr , actual_immob_nh4_vr , actual_immob_no3_vr , & + sminn_to_plant_vr , smin_nh4_to_plant_vr , smin_no3_to_plant_vr , supplement_to_sminn_vr, & + sminn_to_plant_fun_vr , sminn_to_plant_fun_nh4_vr, sminn_to_plant_fun_no3_vr, & + sminn_to_denit_excess_vr, f_nit_vr , f_denit_vr , soyfixn_to_sminn, & + ndep_to_sminn , ffix_to_sminn , nfix_to_sminn , fert_to_sminn + USE MOD_MPAS_MPI + + IMPLICIT NONE + + PUBLIC SoilBiogeochemNStateUpdate1 + +CONTAINS + + SUBROUTINE SoilBiogeochemNStateUpdate1(i,deltim,nl_soil,ndecomp_transitions,dz_soi) + + integer ,intent(in) :: i ! patch idnex + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_transitions! number of total transfers between soil and litter pools in the decomposition + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer (m) + + integer j,k + real(r8):: sminflux,minerflux + + IF(.not. DEF_USE_NITRIF)THEN + DO j = 1, nl_soil + ! N deposition and fixation + sminn_vr(j,i) = sminn_vr(j,i) + ndep_to_sminn(i)*deltim * ndep_prof(j,i) + sminn_vr(j,i) = sminn_vr(j,i) + nfix_to_sminn(i)*deltim * nfixation_prof(j,i) + ENDDO + ELSE + DO j = 1, nl_soil + ! N deposition and fixation (put all into NH4 pool) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) + ndep_to_sminn(i)*deltim * ndep_prof(j,i) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) + nfix_to_sminn(i)*deltim * nfixation_prof(j,i) + ENDDO + ENDIF + + ! repeating N dep and fixation for crops +#ifdef CROP + IF(.not. DEF_USE_NITRIF)THEN + DO j = 1, nl_soil + ! column loop + ! N deposition and fixation + sminn_vr(j,i) = sminn_vr(j,i) & + + fert_to_sminn(i) * deltim * ndep_prof(j,i) + ENDDO + IF(DEF_USE_CNSOYFIXN)THEN + DO j = 1, nl_soil + sminn_vr(j,i) = sminn_vr(j,i) & + + soyfixn_to_sminn(i) * deltim * nfixation_prof(j,i) + ENDDO + ENDIF + ELSE + DO j = 1, nl_soil + ! N deposition and fixation (put all into NH4 pool) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) & + + fert_to_sminn(i) * deltim * ndep_prof(j,i) + ENDDO + IF(DEF_USE_CNSOYFIXN)THEN + DO j = 1, nl_soil + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) & + + soyfixn_to_sminn(i) * deltim * nfixation_prof(j,i) + ENDDO + ENDIF + ENDIF +#endif + + ! decomposition fluxes + DO k = 1, ndecomp_transitions + DO j = 1, nl_soil + decomp_npools_sourcesink(j,donor_pool(k),i) = & + decomp_npools_sourcesink(j,donor_pool(k),i) - & + decomp_ntransfer_vr(j,k,i) * deltim + ENDDO + ENDDO + + + DO k = 1, ndecomp_transitions + IF ( receiver_pool(k) /= 0 ) THEN ! skip terminal transitions + DO j = 1, nl_soil + decomp_npools_sourcesink(j,receiver_pool(k),i) = & + decomp_npools_sourcesink(j,receiver_pool(k),i) + & + (decomp_ntransfer_vr(j,k,i) + & + decomp_sminn_flux_vr(j,k,i)) * deltim + ENDDO + ELSE ! terminal transitions + DO j = 1, nl_soil + decomp_npools_sourcesink(j,donor_pool(k),i) = & + decomp_npools_sourcesink(j,donor_pool(k),i) - & + decomp_sminn_flux_vr(j,k,i) * deltim + ENDDO + ENDIF + ENDDO + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + DO j = 1, nl_soil + AKX_met_to_soil1_n_vr_acc (j,i) = AKX_met_to_soil1_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 1,i) + decomp_sminn_flux_vr(j, 1,i)) * deltim + AKX_cel_to_soil1_n_vr_acc (j,i) = AKX_cel_to_soil1_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 2,i) + decomp_sminn_flux_vr(j, 2,i)) * deltim + AKX_lig_to_soil2_n_vr_acc (j,i) = AKX_lig_to_soil2_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 3,i) + decomp_sminn_flux_vr(j, 3,i)) * deltim + AKX_soil1_to_soil2_n_vr_acc(j,i) = AKX_soil1_to_soil2_n_vr_acc(j,i) + (decomp_ntransfer_vr(j, 4,i) + decomp_sminn_flux_vr(j, 4,i)) * deltim + AKX_cwd_to_cel_n_vr_acc (j,i) = AKX_cwd_to_cel_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 5,i) + decomp_sminn_flux_vr(j, 5,i)) * deltim + AKX_cwd_to_lig_n_vr_acc (j,i) = AKX_cwd_to_lig_n_vr_acc (j,i) + (decomp_ntransfer_vr(j, 6,i) + decomp_sminn_flux_vr(j, 6,i)) * deltim + AKX_soil1_to_soil3_n_vr_acc(j,i) = AKX_soil1_to_soil3_n_vr_acc(j,i) + (decomp_ntransfer_vr(j, 7,i) + decomp_sminn_flux_vr(j, 7,i)) * deltim + AKX_soil2_to_soil1_n_vr_acc(j,i) = AKX_soil2_to_soil1_n_vr_acc(j,i) + (decomp_ntransfer_vr(j, 8,i) + decomp_sminn_flux_vr(j, 8,i)) * deltim + AKX_soil2_to_soil3_n_vr_acc(j,i) = AKX_soil2_to_soil3_n_vr_acc(j,i) + (decomp_ntransfer_vr(j, 9,i) + decomp_sminn_flux_vr(j, 9,i)) * deltim + AKX_soil3_to_soil1_n_vr_acc(j,i) = AKX_soil3_to_soil1_n_vr_acc(j,i) + (decomp_ntransfer_vr(j,10,i) + decomp_sminn_flux_vr(j,10,i)) * deltim + + AKX_met_exit_n_vr_acc (j,i) = AKX_met_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 1,i) * deltim + AKX_cel_exit_n_vr_acc (j,i) = AKX_cel_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 2,i) * deltim + AKX_lig_exit_n_vr_acc (j,i) = AKX_lig_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 3,i) * deltim + AKX_soil1_exit_n_vr_acc (j,i) = AKX_soil1_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 4,i) * deltim + AKX_cwd_exit_n_vr_acc (j,i) = AKX_cwd_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 5,i) * deltim + AKX_cwd_exit_n_vr_acc (j,i) = AKX_cwd_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 6,i) * deltim + AKX_soil1_exit_n_vr_acc (j,i) = AKX_soil1_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 7,i) * deltim + AKX_soil2_exit_n_vr_acc (j,i) = AKX_soil2_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 8,i) * deltim + AKX_soil2_exit_n_vr_acc (j,i) = AKX_soil2_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j, 9,i) * deltim + AKX_soil3_exit_n_vr_acc (j,i) = AKX_soil3_exit_n_vr_acc (j,i) + decomp_ntransfer_vr(j,10,i) * deltim + ENDDO + ENDIF + + IF(.not. DEF_USE_NITRIF)THEN + + !-------------------------------------------------------- + !------------- NITRIF_DENITRIF OFF ------------------- + !-------------------------------------------------------- + + ! immobilization/mineralization in litter-to-SOM and SOM-to-SOM fluxes and denitrification fluxes + DO k = 1, ndecomp_transitions + IF ( receiver_pool(k) /= 0 ) THEN ! skip terminal transitions + DO j = 1, nl_soil + sminn_vr(j,i) = sminn_vr(j,i) - & + (sminn_to_denit_decomp_vr(j,k,i) + & + decomp_sminn_flux_vr(j,k,i))* deltim + ENDDO + ELSE + DO j = 1, nl_soil + sminn_vr(j,i) = sminn_vr(j,i) - & + sminn_to_denit_decomp_vr(j,k,i)* deltim + + sminn_vr(j,i) = sminn_vr(j,i) + & + decomp_sminn_flux_vr(j,k,i)* deltim + + ENDDO + ENDIF + ENDDO + + + DO j = 1, nl_soil + ! "bulk denitrification" + sminn_vr(j,i) = sminn_vr(j,i) - sminn_to_denit_excess_vr(j,i) * deltim + + ! total plant uptake from mineral N + sminn_vr(j,i) = sminn_vr(j,i) - sminn_to_plant_vr(j,i)*deltim + ! flux that prevents N limitation (when Carbon_only is set) + sminn_vr(j,i) = sminn_vr(j,i) + supplement_to_sminn_vr(j,i)*deltim + ENDDO + + ELSE + + !-------------------------------------------------------- + !------------- NITRIF_DENITRIF ON -------------------- + !-------------------------------------------------------- + + DO j = 1, nl_soil + + ! mineralization fluxes (divert a fraction of this stream to nitrification flux, add the rest to NH4 pool) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) + gross_nmin_vr(j,i)*deltim + + ! immobilization fluxes + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) - actual_immob_nh4_vr(j,i)*deltim + + smin_no3_vr(j,i) = smin_no3_vr(j,i) - actual_immob_no3_vr(j,i)*deltim + + ! plant uptake fluxes + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) - smin_nh4_to_plant_vr(j,i)*deltim + + smin_no3_vr(j,i) = smin_no3_vr(j,i) - smin_no3_to_plant_vr(j,i)*deltim + + + ! Account for nitrification fluxes + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) - f_nit_vr(j,i) * deltim + + smin_no3_vr(j,i) = smin_no3_vr(j,i) + f_nit_vr(j,i) * deltim & + * (1._r8 - nitrif_n2o_loss_frac) + + ! Account for denitrification fluxes + smin_no3_vr(j,i) = smin_no3_vr(j,i) - f_denit_vr(j,i) * deltim + + ! flux that prevents N limitation (when Carbon_only is set; put all into NH4) + smin_nh4_vr(j,i) = smin_nh4_vr(j,i) + supplement_to_sminn_vr(j,i)*deltim + + ! update diagnostic total + sminn_vr(j,i) = smin_nh4_vr(j,i) + smin_no3_vr(j,i) + + ENDDO + + ENDIF + + END SUBROUTINE SoilBiogeochemNStateUpdate1 + +END MODULE MOD_BGC_Soil_BiogeochemNStateUpdate1 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 new file mode 100644 index 0000000000..54a1f5ec02 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemNitrifDenitrif.F90 @@ -0,0 +1,186 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemNitrifDenitrif + +!-------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate the potential nitrification and dentrification rate. +! +! !REFERENCES: +! Parton, W. et al. 1996. Generalized model for N2 and N2O production from nitrification and +! denitrification. Global Biogeochemical Cycles 10(3):401-412. +! Parton, W.J. et al. 2001. Generalized model for NOx and N2O emissions from soils. J. Geophys. Res. +! 106(D15):17403-17419 +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2021, revised original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_Vars_TimeVariables, only: t_soisno, wliq_soisno, wice_soisno, t_scalar, w_scalar, smp + USE MOD_Vars_TimeInvariants, only: & + porsl, wfc, bsw, BD_all, OM_density + + USE MOD_BGC_Vars_TimeInvariants, only: & + surface_tension_water, rij_kro_a, rij_kro_alpha, rij_kro_beta, rij_kro_gamma, rij_kro_delta, organic_max, & + k_nitr_max, d_con_g21, d_con_g22, d_con_w21, d_con_w22, d_con_w23, & + denit_resp_coef, denit_resp_exp, denit_nitrate_coef, denit_nitrate_exp + + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition carbon & nitrogen pools + to2_decomp_depth_unsat, tconc_o2_unsat, smin_nh4_vr, smin_no3_vr + + + ! other variables + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition fluxes variables + + ! mineral N fluxes + phr_vr, pot_f_nit_vr, pot_f_denit_vr, n2_n2o_ratio_denit_vr + + IMPLICIT NONE + + PUBLIC SoilBiogeochemNitrifDenitrif + +CONTAINS + + SUBROUTINE SoilBiogeochemNitrifDenitrif(i,nl_soil,dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi (1:nl_soil) ! thicknesses of each soil layer (m) + + integer j + + real(r8) :: soil_hr_vr ! total soil respiration rate (g C / m3 / s) + real(r8) :: soil_bulkdensity + real(r8) :: g_per_m3__to__ug_per_gsoil + real(r8) :: g_per_m3_sec__to__ug_per_gsoil_day + real(r8) :: pH + real(r8) :: eps + real(r8) :: f_a + real(r8) :: rho_w = 1.e3_r8 ! (kg/m3) + real(r8) :: r_max + real(r8) :: r_min(1:nl_soil), r_psi(1:nl_soil) + real(r8) :: ratio_diffusivity_water_gas(1:nl_soil) + real(r8) :: om_frac + real(r8) :: diffus + real(r8) :: vol_ice, vol_liq, eff_porosity, anaerobic_frac + real(r8) :: k_nitr_t_vr, k_nitr_ph_vr, k_nitr_h2o_vr, k_nitr_vr + real(r8) :: smin_no3_massdens_vr, soil_co2_prod, fmax_denit_carbonsubstrate_vr, fmax_denit_nitrate_vr + real(r8) :: f_denit_base_vr, ratio_k1, ratio_no3_co2, wfps_vr, fr_WFPS + real(r8),parameter :: PI = 4.*atan(1.) + + pH = 6.5 + + DO j = 1, nl_soil + + f_a = 1._r8 - wfc(j,i) / porsl(j,i) + eps = porsl(j,i)-wfc(j,i) ! Air-filled fraction of total soil volume + + ! use diffusivity calculation including peat + IF (organic_max > 0._r8) THEN + om_frac = min(OM_density(j,i)/organic_max, 1._r8) + ! Use first power, not square as in iniTimeConst + ELSE + om_frac = 1._r8 + ENDIF + diffus = (d_con_g21 + d_con_g22*t_soisno(j,i)) * 1.e-4_r8 * & + (om_frac * f_a**(10._r8/3._r8) / porsl(j,i)**2 + & + (1._r8-om_frac) * eps**2 * f_a**(3._r8 / bsw(j,i)) ) + + ! calculate anoxic fraction of soils + ! use rijtema and kroess model after Riley et al., 2000 + ! caclulated r_psi as a FUNCTION of psi + r_min(j) = 2 * surface_tension_water / (rho_w * 9.80616_r8 * amax1(abs(smp(j,i) * 1.e-5_r8),1.e-10)) + r_max = 2 * surface_tension_water / (rho_w * 9.80616_r8 * 0.1_r8) + r_psi(j) = sqrt(r_min(j) * r_max) + ratio_diffusivity_water_gas(j) = (d_con_g21 + d_con_g22*t_soisno(j,i) ) * 1.e-4_r8 / & + ((d_con_w21 + d_con_w22*t_soisno(j,i) + d_con_w23*t_soisno(j,i)**2) * 1.e-9_r8) + + vol_ice = min(porsl(j,i), wice_soisno(j,i)/(dz_soi(j)*denice)) + eff_porosity = max(0.01, porsl(j,i)-vol_ice) + vol_liq = min(eff_porosity, wliq_soisno(j,i)/(dz_soi(j)*denh2o)) + IF (to2_decomp_depth_unsat(j,i) > 0._r8) THEN + anaerobic_frac = exp(-rij_kro_a * r_psi(j)**(-rij_kro_alpha) * & + to2_decomp_depth_unsat(j,i)**(-rij_kro_beta) * & + tconc_o2_unsat(j,i)**rij_kro_gamma * (vol_liq + ratio_diffusivity_water_gas(j) * & + porsl(j,i))**rij_kro_delta) + ELSE + anaerobic_frac = 0._r8 + ENDIF + + k_nitr_t_vr = min(t_scalar(j,i), 1._r8) + + ! ph function from Parton et al., (2001, 1996) + k_nitr_ph_vr = 0.56 + atan(PI * 0.45 * (-5.+ pH))/PI + + ! moisture function-- assume the same moisture function as limits heterotrophic respiration + ! Parton et al. base their nitrification- soil moisture rate constants based on heterotrophic rates-- can we DO the same? + k_nitr_h2o_vr = w_scalar(j,i) + + ! nitrification constant is a set scalar * temp, moisture, and ph scalars + k_nitr_vr = k_nitr_max * k_nitr_t_vr * k_nitr_h2o_vr * k_nitr_ph_vr + + ! first-order decay of ammonium pool with scalar defined above + pot_f_nit_vr(j,i) = max(smin_nh4_vr(j,i) * k_nitr_vr, 0._r8) + + ! limit to oxic fraction of soils + pot_f_nit_vr(j,i) = pot_f_nit_vr(j,i) * (1._r8 - anaerobic_frac) + + !---------------- denitrification + ! first some input variables an unit conversions + soil_hr_vr = phr_vr(j,i) + + ! CENTURY papers give denitrification in units of per gram soil; need to convert from volumetric to mass-based units here + soil_bulkdensity = BD_all(j,i) + wliq_soisno(j,i)/dz_soi(j) + + g_per_m3__to__ug_per_gsoil = 1.e3_r8 / soil_bulkdensity + + g_per_m3_sec__to__ug_per_gsoil_day = g_per_m3__to__ug_per_gsoil * 86400._r8 + + smin_no3_massdens_vr = max(smin_no3_vr(j,i), 0._r8) * g_per_m3__to__ug_per_gsoil + + soil_co2_prod = (soil_hr_vr * (g_per_m3_sec__to__ug_per_gsoil_day)) + + !! maximum potential denitrification rates based on heterotrophic respiration rates or nitrate concentrations, + !! from (del Grosso et al., 2000) + fmax_denit_carbonsubstrate_vr = (denit_resp_coef * (soil_co2_prod**denit_resp_exp)) & + / g_per_m3_sec__to__ug_per_gsoil_day + ! + fmax_denit_nitrate_vr = (denit_nitrate_coef * smin_no3_massdens_vr**denit_nitrate_exp) & + / g_per_m3_sec__to__ug_per_gsoil_day + + ! find limiting denitrification rate + f_denit_base_vr = max(min(fmax_denit_carbonsubstrate_vr, fmax_denit_nitrate_vr),0._r8) + + ! limit to anoxic fraction of soils + pot_f_denit_vr(j,i) = f_denit_base_vr * anaerobic_frac + + ! now calculate the ratio of N2O to N2 from denitrifictaion, following Del Grosso et al., 2000 + ! diffusivity constant (figure 6b) + ratio_k1 = max(1.7_r8, 38.4_r8 - 350._r8 * diffus) + + ! ratio function (figure 7c) + IF ( soil_co2_prod > 1.0e-9_r8 ) THEN + ratio_no3_co2 = smin_no3_massdens_vr / soil_co2_prod + ELSE + ! fucntion saturates at large no3/co2 ratios, so set as some nominally large number + ratio_no3_co2 = 100._r8 + ENDIF + + ! total water limitation function (Del Grosso et al., 2000, figure 7a) + wfps_vr = max(min(vol_liq/porsl(j,i), 1._r8), 0._r8) * 100._r8 + fr_WFPS = max(0.1_r8, 0.015_r8 * wfps_vr - 0.32_r8) + + ! final ratio expression + n2_n2o_ratio_denit_vr(j,i) = max(0.16*ratio_k1, ratio_k1*exp(-0.8 * ratio_no3_co2)) * fr_WFPS + + ENDDO + END SUBROUTINE SoilBiogeochemNitrifDenitrif +END MODULE MOD_BGC_Soil_BiogeochemNitrifDenitrif +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemPotential.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemPotential.F90 new file mode 100644 index 0000000000..e65bdc2177 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemPotential.F90 @@ -0,0 +1,150 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemPotential + +!--------------------------------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculates the potential C exit flux and the potential N immobilisation and mineralisation flux. The potential C exit flux +! (p_decomp_cpool_loss) equals the product of donor C pool size (decomp_cpools_vr) and transfer pathway fraction (pathfrac_decomp). +! The potential N immobilisation and mineralisation flux (pmnf_decomp) equals: +! the receiver's N demand to immobalize new carbon (p_decomp_cpool_loss * (1 - rf_decomp)/cn_decomp_pools(receiver)) minus actual N +! transfer (p_decomp_cpool_loss * cn_decomp_pools(donor)) +! p_decomp_cpool_loss and pmnf_decomp are THEN used in bgc_soil_SoilBiogeochemDecompMod.F90 +! +! !REFERENCES: +! Thornton, P.E., Law, B.E., Gholz, H.L., Clark, K.L., Falge, E., Ellsworth, D.S., Goldstein, A.H., Monson, +! R.K., Hollinger, D., Falk, M. and Chen, J., 2002. Modeling and measuring the effects of disturbance +! history and climate on carbon and water budgets in evergreen needleleaf forests. +! Agricultural and forest meteorology, 113(1-4), 185-222. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISION: +! Xingjie Lu, 2021, revised original CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_BGC_Vars_TimeInvariants, only: & + floating_cn_ratio, initial_cn_ratio, rf_decomp, receiver_pool, donor_pool, i_atm, pathfrac_decomp + + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition carbon & nitrogen pools + decomp_cpools_vr, decomp_npools_vr, decomp_k, & + + ! other variables + cn_decomp_pools + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition fluxes variables + pmnf_decomp, p_decomp_cpool_loss, gross_nmin_vr, & + + ! mineral N fluxes + potential_immob_vr, phr_vr + + + IMPLICIT NONE + + PUBLIC SoilBiogeochemPotential + +CONTAINS + + SUBROUTINE SoilBiogeochemPotential(i,nl_soil,ndecomp_pools,ndecomp_transitions) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_pools ! number of total soil & litter pools in the decompositions + integer ,intent(in) :: ndecomp_transitions ! number of total transfers between soil and litter pools in the decomposition + + integer j,k,l + real(r8) immob(1:nl_soil) + real(r8) ratio + + p_decomp_cpool_loss(:, :, i) = 0._r8 + pmnf_decomp(:, :, i) = 0._r8 + + ! column loop to calculate potential decomp rates and total immobilization demand + + !! calculate c:n ratios of applicable pools + DO l = 1, ndecomp_pools + IF ( floating_cn_ratio(l) ) THEN + DO j = 1,nl_soil + IF ( decomp_npools_vr(j,l,i) > 0._r8 ) THEN + cn_decomp_pools(j,l,i) = decomp_cpools_vr(j,l,i) / decomp_npools_vr(j,l,i) + ENDIF + ENDDO + ELSE + DO j = 1,nl_soil + cn_decomp_pools(j,l,i) = initial_cn_ratio(l) + ENDDO + ENDIF + ENDDO + + ! calculate the non-nitrogen-limited fluxes + ! these fluxes include the "/ dt" term to put them on a + ! per second basis, since the rate constants have been + ! calculated on a per timestep basis. + + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + + IF (decomp_cpools_vr(j,donor_pool(k),i) > 0._r8 .and. & + decomp_k(j,donor_pool(k),i) > 0._r8 ) THEN + p_decomp_cpool_loss(j,k,i) = decomp_cpools_vr(j,donor_pool(k),i) & + * decomp_k(j,donor_pool(k),i) * pathfrac_decomp(j,k,i) + IF ( .not. floating_cn_ratio(receiver_pool(k)) ) THEN !! not transition of cwd to litter + + IF (receiver_pool(k) /= i_atm ) THEN ! not 100% respiration + ratio = 0._r8 + + IF (decomp_npools_vr(j,donor_pool(k),i) > 0._r8) THEN + ratio = cn_decomp_pools(j,receiver_pool(k),i)/cn_decomp_pools(j,donor_pool(k),i) + ENDIF + + pmnf_decomp(j,k,i) = (p_decomp_cpool_loss(j,k,i) * (1.0_r8 - rf_decomp(j,k,i) - ratio) & + / cn_decomp_pools(j,receiver_pool(k),i) ) + + ELSE ! 100% respiration + pmnf_decomp(j,k,i) = - p_decomp_cpool_loss(j,k,i) / cn_decomp_pools(j,donor_pool(k),i) + ENDIF + + ELSE ! CWD -> litter + pmnf_decomp(j,k,i) = 0._r8 + ENDIF + ENDIF + + ENDDO + ENDDO + + ! Sum up all the potential immobilization fluxes (positive pmnf flux) + ! and all the mineralization fluxes (negative pmnf flux) + DO j = 1,nl_soil + immob(j) = 0._r8 + ENDDO + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + IF (pmnf_decomp(j,k,i) > 0._r8) THEN + immob(j) = immob(j) + pmnf_decomp(j,k,i) + ELSE + gross_nmin_vr(j,i) = gross_nmin_vr(j,i) - pmnf_decomp(j,k,i) + ENDIF + ENDDO + ENDDO + + DO j = 1,nl_soil + potential_immob_vr(j,i) = immob(j) + ENDDO + + ! Add up potential hr for methane calculations + DO j = 1,nl_soil + phr_vr(j,i) = 0._r8 + ENDDO + DO k = 1, ndecomp_transitions + DO j = 1,nl_soil + phr_vr(j,i) = phr_vr(j,i) + rf_decomp(j,k,i) * p_decomp_cpool_loss(j,k,i) + ENDDO + ENDDO + + END SUBROUTINE SoilBiogeochemPotential + +END MODULE MOD_BGC_Soil_BiogeochemPotential +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 new file mode 100644 index 0000000000..12eccccb66 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90 @@ -0,0 +1,238 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Soil_BiogeochemVerticalProfile + +!------------------------------------------------------------------------------------ +! !DESCRIPTION: +! This MODULE calculate soil vertical profile of different C and N inputs, including: +! nitrogen fixation, nitrogen deposition, fine root litter, coarse root litter, +! leaf litter and stem litter. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + + USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop + USE MOD_Const_PFT, only: rootfr_p + USE MOD_BGC_Vars_TimeVariables, only: & + nfixation_prof, ndep_prof, altmax_lastyear_indx, w_scalar + USE MOD_Vars_TimeVariables, only: t_soisno + USE MOD_BGC_Vars_PFTimeVariables, only: & + leaf_prof_p, froot_prof_p, croot_prof_p, stem_prof_p, cinput_rootfr_p + USE MOD_Vars_PFTimeInvariants, only: & + pftclass, pftfrac + IMPLICIT NONE + + PUBLIC SoilBiogeochemVerticalProfile + + real(r8), PUBLIC :: surfprof_exp = 10. ! how steep profile is for surface components (1/ e_folding depth) (1/m) + +CONTAINS + + SUBROUTINE SoilBiogeochemVerticalProfile(i,ps,pe,nl_soil,nl_soil_full,nbedrock,zmin_bedrock,z_soi,dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: nl_soil_full ! number of total soil layers plus bedrock layers + integer ,intent(in) :: nbedrock ! where bedrock layer starts (ith soil layer) + real(r8),intent(in) :: zmin_bedrock ! depth where bedrock layer starts (m) + real(r8),intent(in) :: z_soi (1:nl_soil_full) ! depth of each soil layer (m) + real(r8),intent(in) :: dz_soi(1:nl_soil_full) ! thicknesses of each soil layer (m) + + ! !LOCAL VARIABLES: + real(r8) :: surface_prof(1:nl_soil) + real(r8) :: surface_prof_tot + real(r8) :: rootfr_tot + real(r8) :: col_cinput_rootfr(1:nl_soil_full) + integer :: ivt, m + integer :: j + ! debugging temp variables + real(r8) :: froot_prof_sum + real(r8) :: croot_prof_sum + real(r8) :: leaf_prof_sum + real(r8) :: stem_prof_sum + real(r8) :: ndep_prof_sum + real(r8) :: nfixation_prof_sum + real(r8) :: delta = 1.e-10 + real(r8) :: sumprof + + surface_prof(:) = 0._r8 + DO j = 1, nl_soil + surface_prof(j) = exp(-surfprof_exp * z_soi(j)) / dz_soi(j) + IF (z_soi(j) > zmin_bedrock) THEN + surface_prof(j) = 0._r8 + ENDIF + ENDDO + + ! initialize profiles to zero + col_cinput_rootfr(:) = 0._r8 + nfixation_prof (:,i) = 0._r8 + ndep_prof (:,i) = 0._r8 + DO m = ps , pe + ivt = pftclass(m) + leaf_prof_p (:,m) = 0._r8 + froot_prof_p(:,m) = 0._r8 + croot_prof_p(:,m) = 0._r8 + stem_prof_p (:,m) = 0._r8 + + cinput_rootfr_p(:,m) = 0._r8 + + IF (ivt /= 0) THEN + DO j = 1, nl_soil + cinput_rootfr_p(j,m) = rootfr_p(j,ivt) / dz_soi(j) + ENDDO + + ELSE + cinput_rootfr_p(1,m) = 0. + ENDIF + ENDDO + + DO m = ps , pe + ! integrate rootfr over active layer of soil column + rootfr_tot = 0._r8 + surface_prof_tot = 0._r8 + DO j = 1, min(max(altmax_lastyear_indx(i), 1), nl_soil) + rootfr_tot = rootfr_tot + cinput_rootfr_p(j,m) * dz_soi(j) + surface_prof_tot = surface_prof_tot + surface_prof(j) * dz_soi(j) + ENDDO + IF ( (altmax_lastyear_indx(i) > 0) .and. (rootfr_tot > 0._r8) .and. (surface_prof_tot > 0._r8) ) THEN + ! WHERE there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalnet to integrating over all soil layers outside of permafrost regions + DO j = 1, min(max(altmax_lastyear_indx(i), 1), nl_soil) + froot_prof_p(j,m) = cinput_rootfr_p(j,m) / rootfr_tot + croot_prof_p(j,m) = cinput_rootfr_p(j,m) / rootfr_tot + + IF (j > nbedrock .and. cinput_rootfr_p(j,m) > 0._r8) THEN + write(*,*) 'ERROR: cinput_rootfr_p > 0 in bedrock' + ENDIF + ! set all surface processes to shallower profile + leaf_prof_p(j,m) = surface_prof(j)/ surface_prof_tot + stem_prof_p(j,m) = surface_prof(j)/ surface_prof_tot + ENDDO + ELSE + ! IF fully frozen, or no roots, put everything in the top layer + froot_prof_p(1,m) = 1./dz_soi(1) + croot_prof_p(1,m) = 1./dz_soi(1) + leaf_prof_p(1,m) = 1./dz_soi(1) + stem_prof_p(1,m) = 1./dz_soi(1) + ENDIF + DO j = 1, nl_soil + IF(w_scalar(j,i) .eq. 0._r8 .and. t_soisno(j,i) < 273.15_r8)THEN + froot_prof_p(j,m) = 0._r8 + croot_prof_p(j,m) = 0._r8 + stem_prof_p (j,m) = 0._r8 + leaf_prof_p (j,m) = 0._r8 + ENDIF + ENDDO + sumprof = sum(froot_prof_p(1:nl_soil,m)*dz_soi(1:nl_soil)) + IF(sumprof .ne. 0)THEN + DO j = 1,nl_soil + froot_prof_p(j,m) = froot_prof_p(j,m) / sumprof + ENDDO + ELSE + froot_prof_p(1,m) = 1./dz_soi(1) + ENDIF + sumprof = sum(croot_prof_p(1:nl_soil,m)*dz_soi(1:nl_soil)) + IF(sumprof .ne. 0)THEN + DO j = 1,nl_soil + croot_prof_p(j,m) = croot_prof_p(j,m) / sumprof + ENDDO + ELSE + croot_prof_p(1,m) = 1./dz_soi(1) + ENDIF + sumprof = sum(stem_prof_p(1:nl_soil,m)*dz_soi(1:nl_soil)) + IF(sumprof .ne. 0)THEN + DO j = 1,nl_soil + stem_prof_p(j,m) = stem_prof_p(j,m) / sumprof + ENDDO + ELSE + stem_prof_p(1,m) = 1./dz_soi(1) + ENDIF + sumprof = sum(leaf_prof_p(1:nl_soil,m)*dz_soi(1:nl_soil)) + IF(sumprof .ne. 0)THEN + DO j = 1,nl_soil + leaf_prof_p(j,m) = leaf_prof_p(j,m) / sumprof + ENDDO + ELSE + leaf_prof_p(1,m) = 1./dz_soi(1) + ENDIF + ENDDO + + + + !! aggregate root profile to column + DO m = ps , pe + DO j = 1,nl_soil + col_cinput_rootfr(j) = col_cinput_rootfr(j) + cinput_rootfr_p(j,m) * pftfrac(m) + ENDDO + ENDDO + + ! repeat for column-native profiles: Ndep and Nfix + rootfr_tot = 0._r8 + surface_prof_tot = 0._r8 + ! redo column ntegration over active layer for column-native profiles + DO j = 1, min(max(altmax_lastyear_indx(i), 1), nl_soil) + rootfr_tot = rootfr_tot + col_cinput_rootfr(j) * dz_soi(j) + surface_prof_tot = surface_prof_tot + surface_prof(j) * dz_soi(j) + ENDDO + IF ( (altmax_lastyear_indx(i) > 0) .and. (rootfr_tot > 0._r8) .and. (surface_prof_tot > 0._r8) ) THEN + DO j = 1, min(max(altmax_lastyear_indx(i), 1), nl_soil) + nfixation_prof(j,i) = col_cinput_rootfr(j) / rootfr_tot + ndep_prof(j,i) = surface_prof(j)/ surface_prof_tot + ENDDO + ELSE + nfixation_prof(1,i) = 1./dz_soi(1) + ndep_prof(1,i) = 1./dz_soi(1) + ENDIF + + ! check to make sure integral of all profiles = 1. + ndep_prof_sum = 0. + nfixation_prof_sum = 0. + DO j = 1, nl_soil + ndep_prof_sum = ndep_prof_sum + ndep_prof(j,i) * dz_soi(j) + nfixation_prof_sum = nfixation_prof_sum + nfixation_prof(j,i) * dz_soi(j) + ENDDO + IF ( ( abs(ndep_prof_sum - 1._r8) > delta ) .or. ( abs(nfixation_prof_sum - 1._r8) > delta ) ) THEN + print*,'i',i,delta + write(*,*) 'profile sums:',ndep_prof_sum-1._r8,nfixation_prof_sum-1._r8 + write(*,*) 'altmax_lastyear_indx: ', altmax_lastyear_indx(i) + write(*,*) 'nfixation_prof: ', nfixation_prof(:,i) + write(*,*) 'ndep_prof: ', ndep_prof(:,i) + write(*,*) 'cinput_rootfr: ', cinput_rootfr_p(:,ps:pe) + write(*,*) 'dz_soi: ', dz_soi(:) + write(*,*) 'surface_prof: ', surface_prof(:) + write(*,*) 'p, itype(p) : ', i, pftclass(ps:pe) + write(*,*) 'cinput_rootfr(p,:): ', cinput_rootfr_p(:,ps:pe) + write(*,*) 'ERROR: _prof_sum-1>delta' + CALL CoLM_stop('BGC soil input profiles do not sum to one.') + ENDIF + + DO m = ps , pe + froot_prof_sum = 0. + croot_prof_sum = 0. + leaf_prof_sum = 0. + stem_prof_sum = 0. + DO j = 1, nl_soil + froot_prof_sum = froot_prof_sum + froot_prof_p(j,m) * dz_soi(j) + croot_prof_sum = croot_prof_sum + croot_prof_p(j,m) * dz_soi(j) + leaf_prof_sum = leaf_prof_sum + leaf_prof_p(j,m) * dz_soi(j) + stem_prof_sum = stem_prof_sum + stem_prof_p(j,m) * dz_soi(j) + ENDDO + IF ( ( abs(froot_prof_sum - 1._r8) > delta ) .or. ( abs(croot_prof_sum - 1._r8) > delta ) .or. & + ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) THEN + write(*,*) 'profile sums: ', froot_prof_sum, croot_prof_sum, leaf_prof_sum, stem_prof_sum + write(*,*) ' ERROR: sum-1 > delta' + CALL CoLM_stop('BGC vegetation input profiles do not sum to one.') + ENDIF + ENDDO + + END SUBROUTINE SoilBiogeochemVerticalProfile + +END MODULE MOD_BGC_Soil_BiogeochemVerticalProfile +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 new file mode 100644 index 0000000000..5c6e3d4744 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DFluxes.F90 @@ -0,0 +1,740 @@ +#include + +MODULE MOD_BGC_Vars_1DFluxes +#ifdef BGC +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical flux variables at patch level + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version + + + USE MOD_Precision + IMPLICIT NONE + SAVE + +!--------------------- BGC variables -------------------------------------- +! ecosystem vegetation carbon/nitrogen flux + real(r8), allocatable :: gpp (:) ! gross primary productivity (gC m-2 s-1) + real(r8), allocatable :: gpp_enftemp (:) ! gross primary productivity for needleleaf evergreen temperate tree (gC m-2 s-1) + real(r8), allocatable :: gpp_enfboreal (:) ! gross primary productivity for needleleaf evergreen boreal tree (gC m-2 s-1) + real(r8), allocatable :: gpp_dnfboreal (:) ! gross primary productivity for needleleaf deciduous boreal tree (gC m-2 s-1) + real(r8), allocatable :: gpp_ebftrop (:) ! gross primary productivity for broadleaf evergreen tropical tree (gC m-2 s-1) + real(r8), allocatable :: gpp_ebftemp (:) ! gross primary productivity for broadleaf evergreen temperate tree (gC m-2 s-1) + real(r8), allocatable :: gpp_dbftrop (:) ! gross primary productivity for broadleaf deciduous tropical tree (gC m-2 s-1) + real(r8), allocatable :: gpp_dbftemp (:) ! gross primary productivity for broadleaf deciduous temperate tree (gC m-2 s-1) + real(r8), allocatable :: gpp_dbfboreal (:) ! gross primary productivity for broadleaf deciduous boreal tree (gC m-2 s-1) + real(r8), allocatable :: gpp_ebstemp (:) ! gross primary productivity for broadleaf evergreen temperate shrub (gC m-2 s-1) + real(r8), allocatable :: gpp_dbstemp (:) ! gross primary productivity for broadleaf deciduous temperate shrub (gC m-2 s-1) + real(r8), allocatable :: gpp_dbsboreal (:) ! gross primary productivity for broadleaf deciduous boreal shrub (gC m-2 s-1) + real(r8), allocatable :: gpp_c3arcgrass (:) ! gross primary productivity for c3 arctic grass (gC m-2 s-1) + real(r8), allocatable :: gpp_c3grass (:) ! gross primary productivity for c3 grass (gC m-2 s-1) + real(r8), allocatable :: gpp_c4grass (:) ! gross primary productivity for c4 grass (gC m-2 s-1) + real(r8), allocatable :: npp_enftemp (:) ! leaf carbon display pool for needleleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: npp_enfboreal (:) ! leaf carbon display pool for needleleaf evergreen boreal tree (gC m-2) + real(r8), allocatable :: npp_dnfboreal (:) ! leaf carbon display pool for needleleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: npp_ebftrop (:) ! leaf carbon display pool for broadleaf evergreen tropical tree (gC m-2) + real(r8), allocatable :: npp_ebftemp (:) ! leaf carbon display pool for broadleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: npp_dbftrop (:) ! leaf carbon display pool for broadleaf deciduous tropical tree (gC m-2) + real(r8), allocatable :: npp_dbftemp (:) ! leaf carbon display pool for broadleaf deciduous temperate tree (gC m-2) + real(r8), allocatable :: npp_dbfboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: npp_ebstemp (:) ! leaf carbon display pool for broadleaf evergreen temperate shrub (gC m-2) + real(r8), allocatable :: npp_dbstemp (:) ! leaf carbon display pool for broadleaf deciduous temperate shrub (gC m-2) + real(r8), allocatable :: npp_dbsboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal shrub (gC m-2) + real(r8), allocatable :: npp_c3arcgrass (:) ! leaf carbon display pool for c3 arctic grass (gC m-2) + real(r8), allocatable :: npp_c3grass (:) ! leaf carbon display pool for c3 grass (gC m-2) + real(r8), allocatable :: npp_c4grass (:) ! leaf carbon display pool for c4 grass (gC m-2) + real(r8), allocatable :: npptoleafc_enftemp (:) ! leaf carbon display pool for needleleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: npptoleafc_enfboreal (:) ! leaf carbon display pool for needleleaf evergreen boreal tree (gC m-2) + real(r8), allocatable :: npptoleafc_dnfboreal (:) ! leaf carbon display pool for needleleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: npptoleafc_ebftrop (:) ! leaf carbon display pool for broadleaf evergreen tropical tree (gC m-2) + real(r8), allocatable :: npptoleafc_ebftemp (:) ! leaf carbon display pool for broadleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: npptoleafc_dbftrop (:) ! leaf carbon display pool for broadleaf deciduous tropical tree (gC m-2) + real(r8), allocatable :: npptoleafc_dbftemp (:) ! leaf carbon display pool for broadleaf deciduous temperate tree (gC m-2) + real(r8), allocatable :: npptoleafc_dbfboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: npptoleafc_ebstemp (:) ! leaf carbon display pool for broadleaf evergreen temperate shrub (gC m-2) + real(r8), allocatable :: npptoleafc_dbstemp (:) ! leaf carbon display pool for broadleaf deciduous temperate shrub (gC m-2) + real(r8), allocatable :: npptoleafc_dbsboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal shrub (gC m-2) + real(r8), allocatable :: npptoleafc_c3arcgrass (:) ! leaf carbon display pool for c3 arctic grass (gC m-2) + real(r8), allocatable :: npptoleafc_c3grass (:) ! leaf carbon display pool for c3 grass (gC m-2) + real(r8), allocatable :: npptoleafc_c4grass (:) ! leaf carbon display pool for c4 grass (gC m-2) + real(r8), allocatable :: leafc_enftemp (:) ! leaf carbon display pool for needleleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: leafc_enfboreal (:) ! leaf carbon display pool for needleleaf evergreen boreal tree (gC m-2) + real(r8), allocatable :: leafc_dnfboreal (:) ! leaf carbon display pool for needleleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: leafc_ebftrop (:) ! leaf carbon display pool for broadleaf evergreen tropical tree (gC m-2) + real(r8), allocatable :: leafc_ebftemp (:) ! leaf carbon display pool for broadleaf evergreen temperate tree (gC m-2) + real(r8), allocatable :: leafc_dbftrop (:) ! leaf carbon display pool for broadleaf deciduous tropical tree (gC m-2) + real(r8), allocatable :: leafc_dbftemp (:) ! leaf carbon display pool for broadleaf deciduous temperate tree (gC m-2) + real(r8), allocatable :: leafc_dbfboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal tree (gC m-2) + real(r8), allocatable :: leafc_ebstemp (:) ! leaf carbon display pool for broadleaf evergreen temperate shrub (gC m-2) + real(r8), allocatable :: leafc_dbstemp (:) ! leaf carbon display pool for broadleaf deciduous temperate shrub (gC m-2) + real(r8), allocatable :: leafc_dbsboreal (:) ! leaf carbon display pool for broadleaf deciduous boreal shrub (gC m-2) + real(r8), allocatable :: leafc_c3arcgrass (:) ! leaf carbon display pool for c3 arctic grass (gC m-2) + real(r8), allocatable :: leafc_c3grass (:) ! leaf carbon display pool for c3 grass (gC m-2) + real(r8), allocatable :: leafc_c4grass (:) ! leaf carbon display pool for c4 grass (gC m-2) + real(r8), allocatable :: ar (:) ! autotrophic respiration (gC m-2 s-1) + real(r8), allocatable :: cwdprod (:) ! CWD production (gC m-2 s-1) + real(r8), allocatable :: cwddecomp (:) ! CWD decomposition (gC m-2 s-1) + real(r8), allocatable :: hr (:) ! heterotrophic respiration (gC m-2 s-1) + real(r8), allocatable :: er (:) ! total ecosystem respiration, autotrophic + heterotrophic (gC m-2 s-1) + real(r8), allocatable :: fire_closs (:) ! total C emissions due to fire (gC m-2 s-1) + real(r8), allocatable :: fire_nloss (:) ! total N emissions due to fire (gN m-2 s-1) + real(r8), allocatable :: hrv_xsmrpool_to_atm (:) ! maintenance respiration storage C to atmosphere due to harvest (gC m-2 s-1) + real(r8), allocatable :: wood_harvestc (:) ! harvested wood C (gC m-2 s-1) + real(r8), allocatable :: wood_harvestn (:) ! harvested wood N (gN m-2 s-1) + real(r8), allocatable :: grainc_to_cropprodc (:) ! grain to crop production carbon (gC m-2 s-1) + real(r8), allocatable :: grainc_to_seed (:) ! grain to crop seed carbon (gC m-2 s-1) + real(r8), allocatable :: grainn_to_cropprodn (:) ! grain to crop production nitrogen (gN m-2 s-1) + real(r8), allocatable :: cropprod1c_loss (:) ! loss rate of 1-yr crop production carbon (gC m-2 s-1) + + ! decomposition carbon fluxes + real(r8), allocatable :: decomp_cpools_sourcesink (:,:,:) ! vertical resolved: the input of litter & soil carbon pools (donor or receiver) from phenology-associated litterfall and decomposition (gC m-3 timestep-1) + real(r8), allocatable :: decomp_ctransfer_vr (:,:,:) ! vertical resolved: the non-respiratory portion of potential carbon transfer from one litter & soil carbon pool to another (gC m-3 s-1) + real(r8), allocatable :: decomp_hr_vr (:,:,:) ! vertical resolved: the heterotrophic respiration portion of potential carbon loss from one litter & soil carbon pool to another (gC m-3 s-1) + real(r8), allocatable :: decomp_hr (:) ! the heterotrophic respiration portion of potential carbon loss from one decomposition carbon pool to another (gC m-3 s-1) + real(r8), allocatable :: phr_vr (:,:) ! vertical resolved: the potential heterotrophic respiration carbon flux (gC m-3 s-1) + real(r8), allocatable :: m_decomp_cpools_to_fire_vr (:,:,:) ! vertical resolved: the carbon from decomposition pools to fire emissions (gC m-3 s-1) + real(r8), allocatable :: decomp_cpools_transport_tendency(:,:,:) ! vertical resolved: the carbon tendency due to vertical transport in decomposition carbon pools (gC m-3 s-1) + real(r8), allocatable :: som_c_leached (:) ! total soil organic matter C loss from vertical transport (gC m-2 s-1) + + ! vegetation to decomposition carbon fluxes + real(r8), allocatable :: phenology_to_met_c (:,:) ! phenology-associated plant C loss to metabolic litter C (gC m-3 s-1) + real(r8), allocatable :: phenology_to_cel_c (:,:) ! phenology-associated plant C loss to cellulosic litter C (gC m-3 s-1) + real(r8), allocatable :: phenology_to_lig_c (:,:) ! phenology-associated plant C loss to lignin litter C (gC m-3 s-1) + real(r8), allocatable :: gap_mortality_to_met_c (:,:) ! gap mortality-associated plant C loss to metabolic litter C (gC m-3 s-1) + real(r8), allocatable :: gap_mortality_to_cel_c (:,:) ! gap mortality-associated plant C loss to cellulosic litter C (gC m-3 s-1) + real(r8), allocatable :: gap_mortality_to_lig_c (:,:) ! gap mortality-associated plant C loss to lignin litter C (gC m-3 s-1) + real(r8), allocatable :: gap_mortality_to_cwdc (:,:) ! gap mortality-associated plant C loss to coarse woody debris C (gC m-3 s-1) + real(r8), allocatable :: fire_mortality_to_met_c (:,:) ! fire mortality-associated plant C loss to metabolic litter C (gC m-3 s-1) + real(r8), allocatable :: fire_mortality_to_cel_c (:,:) ! fire mortality-associated plant C loss to cellulosic litter C (gC m-3 s-1) + real(r8), allocatable :: fire_mortality_to_lig_c (:,:) ! fire mortality-associated plant C loss to lignin litter C (gC m-3 s-1) + real(r8), allocatable :: fire_mortality_to_cwdc (:,:) ! fire mortality-associated plant C loss to coarse woody debris C (gC m-3 s-1) + + ! decomposition nitrogen fluxes + real(r8), allocatable :: decomp_npools_sourcesink (:,:,:) ! vertical resolved: the the input of litter & soil nitrogen pools (donor or receiver) (gN m-3 timestep) + real(r8), allocatable :: decomp_ntransfer_vr (:,:,:) ! vertical resolved: the nitrogen flux transfer from one litter & soil nitrogen pool to another (gN m-3 s-1) + real(r8), allocatable :: decomp_sminn_flux_vr (:,:,:) ! vertical resolved: the nitrogen mineralization flux from each nitrogen transfer between litter & soil pools (gN m-3 s-1) + real(r8), allocatable :: sminn_to_denit_decomp_vr (:,:,:) ! vertical resolved: the nitrogen denitrification flux from each nitrogen transfer between litter & soil pools (gN m-3 s-1) + real(r8), allocatable :: m_decomp_npools_to_fire_vr (:,:,:) ! vertical resolved: the litter & soil nitrogen loss associated to the fire (gN m-3 s-1) + real(r8), allocatable :: decomp_npools_transport_tendency(:,:,:) ! vertical resolved: the nitrogen tendency due to vertical transport in decomposition nitrogen pools (gN m-3 s-1) + real(r8), allocatable :: som_n_leached (:) ! total soil organic matter N loss from vertical transport (gN m-2 s-1) + + ! vegetation to decomposition nitrogen fluxes + real(r8), allocatable :: phenology_to_met_n (:,:) ! phenology-associated plant N loss to metabolic litter N (gN m-3 s-1) + real(r8), allocatable :: phenology_to_cel_n (:,:) ! phenology-associated plant N loss to cellulosic litter N (gN m-3 s-1) + real(r8), allocatable :: phenology_to_lig_n (:,:) ! phenology-associated plant N loss to lignin litter N (gN m-3 s-1) + real(r8), allocatable :: gap_mortality_to_met_n (:,:) ! gap mortality-associated plant N loss to metabolic litter N (gN m-3 s-1) + real(r8), allocatable :: gap_mortality_to_cel_n (:,:) ! gap mortality-associated plant N loss to cellulosic litter N (gN m-3 s-1) + real(r8), allocatable :: gap_mortality_to_lig_n (:,:) ! gap mortality-associated plant N loss to lignin litter N (gN m-3 s-1) + real(r8), allocatable :: gap_mortality_to_cwdn (:,:) ! gap mortality-associated plant N loss to coarse woody debris N (gN m-3 s-1) + real(r8), allocatable :: fire_mortality_to_met_n (:,:) ! fire mortality-associated plant N loss to metabolic litter N (gN m-3 s-1) + real(r8), allocatable :: fire_mortality_to_cel_n (:,:) ! fire mortality-associated plant N loss to cellulosic litter N (gN m-3 s-1) + real(r8), allocatable :: fire_mortality_to_lig_n (:,:) ! fire mortality-associated plant N loss to lignin litter N (gN m-3 s-1) + real(r8), allocatable :: fire_mortality_to_cwdn (:,:) ! fire mortality-associated plant N loss to coarse woody debris N (gN m-3 s-1) + + real(r8), allocatable :: sminn_leached_vr (:,:) ! vertical resolved: soil mineral N loss due to leaching (gN m-3 s-1) + real(r8), allocatable :: smin_no3_leached_vr (:,:) ! vertical resolved: soil mineral NO3 loss due to leaching (gN m-3 s-1) + real(r8), allocatable :: smin_no3_runoff_vr (:,:) ! vertical resolved: soil mineral NO3 loss due to runoff (gN m-3 s-1) + real(r8), allocatable :: net_nmin_vr (:,:) ! vertical resolved: net N mineralization (gN m-3 s-1) + real(r8), allocatable :: gross_nmin_vr (:,:) ! vertical resolved: total N mineralization (gN m-3 s-1) + real(r8), allocatable :: net_nmin (:) ! net N mineralization (gN m-2 s-1) + real(r8), allocatable :: gross_nmin (:) ! total N mineralization (gN m-2 s-1) + real(r8), allocatable :: plant_ndemand (:) ! potential plant N uptake (gN m-2 s-1) + real(r8), allocatable :: actual_immob_vr (:,:) ! vertical resolved: actual N immobilization (gN m-3 s-1) + real(r8), allocatable :: actual_immob_nh4_vr (:,:) ! vertical resolved: actual NH4 immobilization (gN m-3 s-1) + real(r8), allocatable :: actual_immob_no3_vr (:,:) ! vertical resolved: actual NO3 immobilization (gN m-3 s-1) + real(r8), allocatable :: potential_immob_vr (:,:) ! vertical resolved: potential N immobilization (gN m-3 s-1) + real(r8), allocatable :: pmnf_decomp (:,:,:) ! vertical resolved: potential N mineralization flux of each transfer between litter & soil pools (gN m-3 s-1) + real(r8), allocatable :: p_decomp_cpool_loss (:,:,:) ! vertical resolved: potential C exit rate (transfer+hr) of the donor pool of each transfer between litter & soil pools (gC m-3 s-1) + real(r8), allocatable :: sminn_to_plant (:) ! plant uptake N (gN m-2 s-1) + real(r8), allocatable :: sminn_to_plant_vr (:,:) ! vertical resolved: plant uptake N (gN m-3 s-1) + real(r8), allocatable :: smin_nh4_to_plant_vr (:,:) ! vertical resolved: plant uptake NH4 (gN m-3 s-1) + real(r8), allocatable :: smin_no3_to_plant_vr (:,:) ! vertical resolved: plant uptake NO3 (gN m-3 s-1) + real(r8), allocatable :: supplement_to_sminn_vr (:,:) ! vertical resolved: supplemental N supply to soil mineral N (gN m-3 s-1) + real(r8), allocatable :: sminn_to_plant_fun_vr (:,:) ! vertical resolved: plant uptake N by FUN (gN m-3 s-1) + real(r8), allocatable :: sminn_to_plant_fun_nh4_vr(:,:) ! vertical resolved: plant uptake NH4 by FUN (gN m-3 s-1) + real(r8), allocatable :: sminn_to_plant_fun_no3_vr(:,:) ! vertical resolved: plant uptake NO3 by FUN (gN m-3 s-1) + real(r8), allocatable :: sminn_to_denit_excess_vr (:,:) ! vertical resolved: denitrification from excess mineral N (gN m-3 s-1) + real(r8), allocatable :: f_nit_vr (:,:) ! vertical resolved: nitrification (gN m-3 s-1) + real(r8), allocatable :: f_denit_vr (:,:) ! vertical resolved: denitrification (gN m-3 s-1) + real(r8), allocatable :: f_n2o_nit_vr (:,:) ! vertical resolved: N2O emission from N nitrification (gN m-3 s-1) + real(r8), allocatable :: f_n2o_denit_vr (:,:) ! vertical resolved: N2O emission from N denitrification (gN m-3 s-1) + real(r8), allocatable :: pot_f_nit_vr (:,:) ! vertical resolved: potential N nitrification (gN m-3 s-1) + real(r8), allocatable :: pot_f_denit_vr (:,:) ! vertical resolved: potential N denitrification (gN m-3 s-1) + real(r8), allocatable :: n2_n2o_ratio_denit_vr (:,:) ! vertical resolved: ratio of N2 to N2O production by denitrification (gN gN-1) + real(r8), allocatable :: ndep_to_sminn (:) ! atmospheric N deposition to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: ffix_to_sminn (:) ! free living N fixation to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: nfix_to_sminn (:) ! N fixation to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: somc_fire (:) ! soil organic matters C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: supplement_to_sminn (:) ! supplemental N supply to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: fert_to_sminn (:) ! fertilizer N to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: soyfixn_to_sminn (:) ! soybean N fixation to soil mineral N (gN m-2 s-1) + real(r8), allocatable :: denit (:) ! total N denitrification (gN m-2 s-1) + real(r8), allocatable :: sminn_leached (:) ! soil mineral N loss due to leaching (gN m-2 s-1) + real(r8), allocatable :: f_n2o_nit (:) ! flux of N2O from N nitrification (gN m-2 s-1) + real(r8), allocatable :: smin_no3_leached (:) ! soil mineral NO3 loss due to leaching (gN m-2 s-1) + real(r8), allocatable :: smin_no3_runoff (:) ! soil mineral NO3 loss due to runoff (gN m-2 s-1) + !----------------- end BGC variables ----------------------------------- + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_BGCFluxes + PUBLIC :: deallocate_1D_BGCFluxes + PUBLIC :: set_1D_BGCFluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_BGCFluxes + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_MPAS_MPI + USE MOD_LandPatch + IMPLICIT NONE + + + IF (.true.) THEN + + IF (numpatch > 0) THEN + +! bgc variables +! ecosystem carbon flux + allocate (gpp (numpatch)) ; gpp (:) = spval + allocate (gpp_enftemp (numpatch)) ; gpp_enftemp (:) = spval + allocate (gpp_enfboreal (numpatch)) ; gpp_enfboreal (:) = spval + allocate (gpp_dnfboreal (numpatch)) ; gpp_dnfboreal (:) = spval + allocate (gpp_ebftrop (numpatch)) ; gpp_ebftrop (:) = spval + allocate (gpp_ebftemp (numpatch)) ; gpp_ebftemp (:) = spval + allocate (gpp_dbftrop (numpatch)) ; gpp_dbftrop (:) = spval + allocate (gpp_dbftemp (numpatch)) ; gpp_dbftemp (:) = spval + allocate (gpp_dbfboreal (numpatch)) ; gpp_dbfboreal (:) = spval + allocate (gpp_ebstemp (numpatch)) ; gpp_ebstemp (:) = spval + allocate (gpp_dbstemp (numpatch)) ; gpp_dbstemp (:) = spval + allocate (gpp_dbsboreal (numpatch)) ; gpp_dbsboreal (:) = spval + allocate (gpp_c3arcgrass (numpatch)) ; gpp_c3arcgrass (:) = spval + allocate (gpp_c3grass (numpatch)) ; gpp_c3grass (:) = spval + allocate (gpp_c4grass (numpatch)) ; gpp_c4grass (:) = spval + allocate (npp_enftemp (numpatch)) ; npp_enftemp (:) = spval + allocate (npp_enfboreal (numpatch)) ; npp_enfboreal (:) = spval + allocate (npp_dnfboreal (numpatch)) ; npp_dnfboreal (:) = spval + allocate (npp_ebftrop (numpatch)) ; npp_ebftrop (:) = spval + allocate (npp_ebftemp (numpatch)) ; npp_ebftemp (:) = spval + allocate (npp_dbftrop (numpatch)) ; npp_dbftrop (:) = spval + allocate (npp_dbftemp (numpatch)) ; npp_dbftemp (:) = spval + allocate (npp_dbfboreal (numpatch)) ; npp_dbfboreal (:) = spval + allocate (npp_ebstemp (numpatch)) ; npp_ebstemp (:) = spval + allocate (npp_dbstemp (numpatch)) ; npp_dbstemp (:) = spval + allocate (npp_dbsboreal (numpatch)) ; npp_dbsboreal (:) = spval + allocate (npp_c3arcgrass (numpatch)) ; npp_c3arcgrass (:) = spval + allocate (npp_c3grass (numpatch)) ; npp_c3grass (:) = spval + allocate (npp_c4grass (numpatch)) ; npp_c4grass (:) = spval + allocate (npptoleafc_enftemp (numpatch)) ; npptoleafc_enftemp (:) = spval + allocate (npptoleafc_enfboreal (numpatch)) ; npptoleafc_enfboreal (:) = spval + allocate (npptoleafc_dnfboreal (numpatch)) ; npptoleafc_dnfboreal (:) = spval + allocate (npptoleafc_ebftrop (numpatch)) ; npptoleafc_ebftrop (:) = spval + allocate (npptoleafc_ebftemp (numpatch)) ; npptoleafc_ebftemp (:) = spval + allocate (npptoleafc_dbftrop (numpatch)) ; npptoleafc_dbftrop (:) = spval + allocate (npptoleafc_dbftemp (numpatch)) ; npptoleafc_dbftemp (:) = spval + allocate (npptoleafc_dbfboreal (numpatch)) ; npptoleafc_dbfboreal (:) = spval + allocate (npptoleafc_ebstemp (numpatch)) ; npptoleafc_ebstemp (:) = spval + allocate (npptoleafc_dbstemp (numpatch)) ; npptoleafc_dbstemp (:) = spval + allocate (npptoleafc_dbsboreal (numpatch)) ; npptoleafc_dbsboreal (:) = spval + allocate (npptoleafc_c3arcgrass (numpatch)) ; npptoleafc_c3arcgrass (:) = spval + allocate (npptoleafc_c3grass (numpatch)) ; npptoleafc_c3grass (:) = spval + allocate (npptoleafc_c4grass (numpatch)) ; npptoleafc_c4grass (:) = spval + allocate (leafc_enftemp (numpatch)) ; leafc_enftemp (:) = spval + allocate (leafc_enfboreal (numpatch)) ; leafc_enfboreal (:) = spval + allocate (leafc_dnfboreal (numpatch)) ; leafc_dnfboreal (:) = spval + allocate (leafc_ebftrop (numpatch)) ; leafc_ebftrop (:) = spval + allocate (leafc_ebftemp (numpatch)) ; leafc_ebftemp (:) = spval + allocate (leafc_dbftrop (numpatch)) ; leafc_dbftrop (:) = spval + allocate (leafc_dbftemp (numpatch)) ; leafc_dbftemp (:) = spval + allocate (leafc_dbfboreal (numpatch)) ; leafc_dbfboreal (:) = spval + allocate (leafc_ebstemp (numpatch)) ; leafc_ebstemp (:) = spval + allocate (leafc_dbstemp (numpatch)) ; leafc_dbstemp (:) = spval + allocate (leafc_dbsboreal (numpatch)) ; leafc_dbsboreal (:) = spval + allocate (leafc_c3arcgrass (numpatch)) ; leafc_c3arcgrass (:) = spval + allocate (leafc_c3grass (numpatch)) ; leafc_c3grass (:) = spval + allocate (leafc_c4grass (numpatch)) ; leafc_c4grass (:) = spval + allocate (ar (numpatch)) ; ar (:) = spval + allocate (cwdprod (numpatch)) ; cwdprod (:) = spval + allocate (cwddecomp (numpatch)) ; cwddecomp (:) = spval + allocate (hr (numpatch)) ; hr (:) = spval + allocate (er (numpatch)) ; er (:) = spval + allocate (fire_closs (numpatch)) ; fire_closs (:) = spval + allocate (fire_nloss (numpatch)) ; fire_nloss (:) = spval + allocate (hrv_xsmrpool_to_atm (numpatch)) ; hrv_xsmrpool_to_atm (:) = spval + allocate (wood_harvestc (numpatch)) ; wood_harvestc (:) = spval + allocate (wood_harvestn (numpatch)) ; wood_harvestn (:) = spval + allocate (grainc_to_cropprodc (numpatch)) ; grainc_to_cropprodc (:) = spval + allocate (grainc_to_seed (numpatch)) ; grainc_to_seed (:) = spval + allocate (grainn_to_cropprodn (numpatch)) ; grainn_to_cropprodn (:) = spval + allocate (cropprod1c_loss (numpatch)) ; cropprod1c_loss (:) = spval + + +! decomposition carbon fluxes + allocate (decomp_cpools_sourcesink (nl_soil_full,ndecomp_pools,numpatch)); decomp_cpools_sourcesink (:,:,:) = spval + allocate (decomp_ctransfer_vr (nl_soil_full,ndecomp_transitions,numpatch)); decomp_ctransfer_vr (:,:,:) = spval + allocate (decomp_hr_vr (nl_soil_full,ndecomp_transitions,numpatch)); decomp_hr_vr (:,:,:) = spval + allocate (decomp_hr (numpatch)) ; decomp_hr (:) = spval + allocate (phr_vr (nl_soil_full,numpatch)); phr_vr (:,:) = spval + allocate (m_decomp_cpools_to_fire_vr (nl_soil_full,ndecomp_pools,numpatch)); m_decomp_cpools_to_fire_vr (:,:,:) = spval + allocate (decomp_cpools_transport_tendency(nl_soil_full,ndecomp_pools,numpatch)); decomp_cpools_transport_tendency(:,:,:) = spval + allocate (som_c_leached (numpatch)) ; som_c_leached (:) = spval + +! vegetation to decomposition carbon fluxes + allocate (phenology_to_met_c (nl_soil,numpatch)); phenology_to_met_c (:,:) = spval + allocate (phenology_to_cel_c (nl_soil,numpatch)); phenology_to_cel_c (:,:) = spval + allocate (phenology_to_lig_c (nl_soil,numpatch)); phenology_to_lig_c (:,:) = spval + allocate (gap_mortality_to_met_c (nl_soil,numpatch)); gap_mortality_to_met_c (:,:) = spval + allocate (gap_mortality_to_cel_c (nl_soil,numpatch)); gap_mortality_to_cel_c (:,:) = spval + allocate (gap_mortality_to_lig_c (nl_soil,numpatch)); gap_mortality_to_lig_c (:,:) = spval + allocate (gap_mortality_to_cwdc (nl_soil,numpatch)); gap_mortality_to_cwdc (:,:) = spval + allocate (fire_mortality_to_met_c (nl_soil,numpatch)); fire_mortality_to_met_c (:,:) = spval + allocate (fire_mortality_to_cel_c (nl_soil,numpatch)); fire_mortality_to_cel_c (:,:) = spval + allocate (fire_mortality_to_lig_c (nl_soil,numpatch)); fire_mortality_to_lig_c (:,:) = spval + allocate (fire_mortality_to_cwdc (nl_soil,numpatch)); fire_mortality_to_cwdc (:,:) = spval + +! decomposition nitrogen fluxes + allocate (decomp_npools_sourcesink (nl_soil_full,ndecomp_pools,numpatch)); decomp_npools_sourcesink (:,:,:) = spval + allocate (decomp_ntransfer_vr (nl_soil_full,ndecomp_transitions,numpatch)); decomp_ntransfer_vr (:,:,:) = spval + allocate (decomp_sminn_flux_vr (nl_soil_full,ndecomp_transitions,numpatch)); decomp_sminn_flux_vr (:,:,:) = spval + allocate (sminn_to_denit_decomp_vr (nl_soil_full,ndecomp_transitions,numpatch)); sminn_to_denit_decomp_vr(:,:,:) = spval + allocate (m_decomp_npools_to_fire_vr (nl_soil_full,ndecomp_pools,numpatch)); m_decomp_npools_to_fire_vr (:,:,:) = spval + allocate (decomp_npools_transport_tendency(nl_soil_full,ndecomp_pools,numpatch)); decomp_npools_transport_tendency(:,:,:) = spval + allocate (som_n_leached (numpatch)) ; som_n_leached (:) = spval + +! vegetation to decomposition nitrogen fluxes + allocate (phenology_to_met_n (nl_soil,numpatch)); phenology_to_met_n (:,:) = spval + allocate (phenology_to_cel_n (nl_soil,numpatch)); phenology_to_cel_n (:,:) = spval + allocate (phenology_to_lig_n (nl_soil,numpatch)); phenology_to_lig_n (:,:) = spval + allocate (gap_mortality_to_met_n (nl_soil,numpatch)); gap_mortality_to_met_n (:,:) = spval + allocate (gap_mortality_to_cel_n (nl_soil,numpatch)); gap_mortality_to_cel_n (:,:) = spval + allocate (gap_mortality_to_lig_n (nl_soil,numpatch)); gap_mortality_to_lig_n (:,:) = spval + allocate (gap_mortality_to_cwdn (nl_soil,numpatch)); gap_mortality_to_cwdn (:,:) = spval + allocate (fire_mortality_to_met_n (nl_soil,numpatch)); fire_mortality_to_met_n (:,:) = spval + allocate (fire_mortality_to_cel_n (nl_soil,numpatch)); fire_mortality_to_cel_n (:,:) = spval + allocate (fire_mortality_to_lig_n (nl_soil,numpatch)); fire_mortality_to_lig_n (:,:) = spval + allocate (fire_mortality_to_cwdn (nl_soil,numpatch)); fire_mortality_to_cwdn (:,:) = spval + + allocate (sminn_leached_vr (nl_soil,numpatch)); sminn_leached_vr (:,:) = spval + allocate (smin_no3_leached_vr (nl_soil,numpatch)); smin_no3_leached_vr (:,:) = spval + allocate (smin_no3_runoff_vr (nl_soil,numpatch)); smin_no3_runoff_vr (:,:) = spval + allocate (net_nmin_vr (nl_soil,numpatch)); net_nmin_vr (:,:) = spval + allocate (gross_nmin_vr (nl_soil,numpatch)); gross_nmin_vr (:,:) = spval + allocate (net_nmin (numpatch)) ; net_nmin (:) = spval + allocate (gross_nmin (numpatch)) ; gross_nmin (:) = spval + allocate (plant_ndemand (numpatch)) ; plant_ndemand (:) = spval + allocate (actual_immob_vr (nl_soil,numpatch)); actual_immob_vr (:,:) = spval + allocate (actual_immob_nh4_vr (nl_soil,numpatch)); actual_immob_nh4_vr (:,:) = spval + allocate (actual_immob_no3_vr (nl_soil,numpatch)); actual_immob_no3_vr (:,:) = spval + allocate (potential_immob_vr (nl_soil,numpatch)); potential_immob_vr (:,:) = spval + allocate (pmnf_decomp (nl_soil,ndecomp_transitions,numpatch)); pmnf_decomp (:,:,:) = spval + allocate (p_decomp_cpool_loss (nl_soil,ndecomp_transitions,numpatch)); p_decomp_cpool_loss (:,:,:) = spval + allocate (sminn_to_plant (numpatch)) ; sminn_to_plant (:) = spval + allocate (sminn_to_plant_vr (nl_soil,numpatch)); sminn_to_plant_vr (:,:) = spval + allocate (smin_nh4_to_plant_vr (nl_soil,numpatch)); smin_nh4_to_plant_vr (:,:) = spval + allocate (smin_no3_to_plant_vr (nl_soil,numpatch)); smin_no3_to_plant_vr (:,:) = spval + allocate (supplement_to_sminn_vr (nl_soil,numpatch)); supplement_to_sminn_vr (:,:) = spval + allocate (sminn_to_plant_fun_vr (nl_soil,numpatch)); sminn_to_plant_fun_vr (:,:) = spval + allocate (sminn_to_plant_fun_nh4_vr(nl_soil,numpatch)); sminn_to_plant_fun_nh4_vr(:,:) = spval + allocate (sminn_to_plant_fun_no3_vr(nl_soil,numpatch)); sminn_to_plant_fun_no3_vr(:,:) = spval + allocate (sminn_to_denit_excess_vr (nl_soil,numpatch)); sminn_to_denit_excess_vr (:,:) = spval + allocate (f_nit_vr (nl_soil,numpatch)); f_nit_vr (:,:) = spval + allocate (f_denit_vr (nl_soil,numpatch)); f_denit_vr (:,:) = spval + allocate (f_n2o_nit_vr (nl_soil,numpatch)); f_n2o_nit_vr (:,:) = spval + allocate (f_n2o_denit_vr (nl_soil,numpatch)); f_n2o_denit_vr (:,:) = spval + allocate (pot_f_nit_vr (nl_soil,numpatch)); pot_f_nit_vr (:,:) = spval + allocate (pot_f_denit_vr (nl_soil,numpatch)); pot_f_denit_vr (:,:) = spval + allocate (n2_n2o_ratio_denit_vr (nl_soil,numpatch)); n2_n2o_ratio_denit_vr (:,:) = spval + allocate (ndep_to_sminn (numpatch)) ; ndep_to_sminn (:) = spval + allocate (ffix_to_sminn (numpatch)) ; ffix_to_sminn (:) = spval + allocate (nfix_to_sminn (numpatch)) ; nfix_to_sminn (:) = spval + allocate (somc_fire (numpatch)) ; somc_fire (:) = spval + allocate (supplement_to_sminn (numpatch)) ; supplement_to_sminn (:) = spval + allocate (fert_to_sminn (numpatch)) ; fert_to_sminn (:) = spval + allocate (soyfixn_to_sminn (numpatch)) ; soyfixn_to_sminn (:) = spval + allocate (denit (numpatch)) ; denit (:) = spval + allocate (sminn_leached (numpatch)) ; sminn_leached (:) = spval + allocate (f_n2o_nit (numpatch)) ; f_n2o_nit (:) = spval + allocate (smin_no3_leached (numpatch)) ; smin_no3_leached (:) = spval + allocate (smin_no3_runoff (numpatch)) ; smin_no3_runoff (:) = spval + ENDIF + ENDIF + + + END SUBROUTINE allocate_1D_BGCFluxes + + SUBROUTINE deallocate_1D_BGCFluxes () + ! -------------------------------------------------------------------- + ! deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_LandPatch + + IF (.true.) THEN + + IF (numpatch > 0) THEN + +! bgc variables +! ecosystem carbon flux + deallocate (gpp ) + deallocate (gpp_enftemp ) !1 + deallocate (gpp_enfboreal ) !2 + deallocate (gpp_dnfboreal ) !3 + deallocate (gpp_ebftrop ) !4 + deallocate (gpp_ebftemp ) !5 + deallocate (gpp_dbftrop ) !6 + deallocate (gpp_dbftemp ) !7 + deallocate (gpp_dbfboreal ) !8 + deallocate (gpp_ebstemp ) !9 + deallocate (gpp_dbstemp ) !10 + deallocate (gpp_dbsboreal ) !11 + deallocate (gpp_c3arcgrass ) !12 + deallocate (gpp_c3grass ) !13 + deallocate (gpp_c4grass ) !14 + deallocate (npp_enftemp ) !1 + deallocate (npp_enfboreal ) !2 + deallocate (npp_dnfboreal ) !3 + deallocate (npp_ebftrop ) !4 + deallocate (npp_ebftemp ) !5 + deallocate (npp_dbftrop ) !6 + deallocate (npp_dbftemp ) !7 + deallocate (npp_dbfboreal ) !8 + deallocate (npp_ebstemp ) !9 + deallocate (npp_dbstemp ) !10 + deallocate (npp_dbsboreal ) !11 + deallocate (npp_c3arcgrass ) !12 + deallocate (npp_c3grass ) !13 + deallocate (npp_c4grass ) !14 + deallocate (npptoleafc_enftemp ) !1 + deallocate (npptoleafc_enfboreal ) !2 + deallocate (npptoleafc_dnfboreal ) !3 + deallocate (npptoleafc_ebftrop ) !4 + deallocate (npptoleafc_ebftemp ) !5 + deallocate (npptoleafc_dbftrop ) !6 + deallocate (npptoleafc_dbftemp ) !7 + deallocate (npptoleafc_dbfboreal ) !8 + deallocate (npptoleafc_ebstemp ) !9 + deallocate (npptoleafc_dbstemp ) !10 + deallocate (npptoleafc_dbsboreal ) !11 + deallocate (npptoleafc_c3arcgrass ) !12 + deallocate (npptoleafc_c3grass ) !13 + deallocate (npptoleafc_c4grass ) !14 + deallocate (leafc_enftemp ) !1 + deallocate (leafc_enfboreal ) !2 + deallocate (leafc_dnfboreal ) !3 + deallocate (leafc_ebftrop ) !4 + deallocate (leafc_ebftemp ) !5 + deallocate (leafc_dbftrop ) !6 + deallocate (leafc_dbftemp ) !7 + deallocate (leafc_dbfboreal ) !8 + deallocate (leafc_ebstemp ) !9 + deallocate (leafc_dbstemp ) !10 + deallocate (leafc_dbsboreal ) !11 + deallocate (leafc_c3arcgrass ) !12 + deallocate (leafc_c3grass ) !13 + deallocate (leafc_c4grass ) !14 + deallocate (ar ) + deallocate (cwdprod ) + deallocate (cwddecomp ) + deallocate (hr ) + deallocate (er ) + deallocate (fire_closs ) + deallocate (fire_nloss ) + deallocate (hrv_xsmrpool_to_atm ) + deallocate (wood_harvestc ) + deallocate (wood_harvestn ) + deallocate (grainc_to_cropprodc ) + deallocate (grainc_to_seed ) + deallocate (grainn_to_cropprodn ) + deallocate (cropprod1c_loss ) + + + ! decomposition carbon fluxes + deallocate (decomp_cpools_sourcesink ) + deallocate (decomp_ctransfer_vr ) + deallocate (decomp_hr_vr ) + deallocate (decomp_hr ) + deallocate (phr_vr ) + deallocate (m_decomp_cpools_to_fire_vr ) + deallocate (decomp_cpools_transport_tendency) + deallocate (som_c_leached ) + + ! vegetation to decomposition carbon fluxes + deallocate (phenology_to_met_c ) + deallocate (phenology_to_cel_c ) + deallocate (phenology_to_lig_c ) + deallocate (gap_mortality_to_met_c ) + deallocate (gap_mortality_to_cel_c ) + deallocate (gap_mortality_to_lig_c ) + deallocate (gap_mortality_to_cwdc ) + deallocate (fire_mortality_to_met_c ) + deallocate (fire_mortality_to_cel_c ) + deallocate (fire_mortality_to_lig_c ) + deallocate (fire_mortality_to_cwdc ) + + ! decomposition nitrogen fluxes + deallocate (decomp_npools_sourcesink ) + deallocate (decomp_ntransfer_vr ) + deallocate (decomp_sminn_flux_vr ) + deallocate (sminn_to_denit_decomp_vr ) + deallocate (m_decomp_npools_to_fire_vr ) + deallocate (decomp_npools_transport_tendency) + deallocate (som_n_leached ) + + ! vegetation to decomposition nitrogen fluxes + deallocate (phenology_to_met_n ) + deallocate (phenology_to_cel_n ) + deallocate (phenology_to_lig_n ) + deallocate (gap_mortality_to_met_n ) + deallocate (gap_mortality_to_cel_n ) + deallocate (gap_mortality_to_lig_n ) + deallocate (gap_mortality_to_cwdn ) + deallocate (fire_mortality_to_met_n ) + deallocate (fire_mortality_to_cel_n ) + deallocate (fire_mortality_to_lig_n ) + deallocate (fire_mortality_to_cwdn ) + + deallocate (sminn_leached_vr ) + deallocate (smin_no3_leached_vr ) + deallocate (smin_no3_runoff_vr ) + deallocate (net_nmin_vr ) + deallocate (gross_nmin_vr ) + deallocate (net_nmin ) + deallocate (gross_nmin ) + deallocate (plant_ndemand ) + deallocate (actual_immob_vr ) + deallocate (actual_immob_nh4_vr ) + deallocate (actual_immob_no3_vr ) + deallocate (potential_immob_vr ) + deallocate (pmnf_decomp ) + deallocate (p_decomp_cpool_loss ) + deallocate (sminn_to_plant ) + deallocate (sminn_to_plant_vr ) + deallocate (smin_nh4_to_plant_vr ) + deallocate (smin_no3_to_plant_vr ) + deallocate (supplement_to_sminn_vr ) + deallocate (sminn_to_plant_fun_vr ) + deallocate (sminn_to_plant_fun_nh4_vr) + deallocate (sminn_to_plant_fun_no3_vr) + deallocate (sminn_to_denit_excess_vr ) + deallocate (f_nit_vr ) + deallocate (f_denit_vr ) + deallocate (f_n2o_nit_vr ) + deallocate (f_n2o_denit_vr ) + deallocate (pot_f_nit_vr ) + deallocate (pot_f_denit_vr ) + deallocate (n2_n2o_ratio_denit_vr ) + deallocate (ndep_to_sminn ) + deallocate (ffix_to_sminn ) + deallocate (nfix_to_sminn ) + deallocate (somc_fire ) + deallocate (supplement_to_sminn ) + deallocate (fert_to_sminn ) + deallocate (soyfixn_to_sminn ) + deallocate (denit ) + deallocate (sminn_leached ) + deallocate (f_n2o_nit ) + deallocate (smin_no3_leached ) + deallocate (smin_no3_runoff ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_1D_BGCFluxes + +SUBROUTINE set_1D_BGCFluxes(Values, Nan) + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_MPAS_MPI + USE MOD_LandPatch + IMPLICIT NONE + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan + + + IF (.true.) THEN + + IF (numpatch > 0) THEN + +! bgc variables +! ecosystem carbon flux + gpp (:) = Values + gpp_enftemp (:) = Values !1 + gpp_enfboreal (:) = Values !2 + gpp_dnfboreal (:) = Values !3 + gpp_ebftrop (:) = Values !4 + gpp_ebftemp (:) = Values !5 + gpp_dbftrop (:) = Values !6 + gpp_dbftemp (:) = Values !7 + gpp_dbfboreal (:) = Values !8 + gpp_ebstemp (:) = Values !9 + gpp_dbstemp (:) = Values !10 + gpp_dbsboreal (:) = Values !11 + gpp_c3arcgrass (:) = Values !12 + gpp_c3grass (:) = Values !13 + gpp_c4grass (:) = Values !14 + npp_enftemp (:) = Values !1 + npp_enfboreal (:) = Values !2 + npp_dnfboreal (:) = Values !3 + npp_ebftrop (:) = Values !4 + npp_ebftemp (:) = Values !5 + npp_dbftrop (:) = Values !6 + npp_dbftemp (:) = Values !7 + npp_dbfboreal (:) = Values !8 + npp_ebstemp (:) = Values !9 + npp_dbstemp (:) = Values !10 + npp_dbsboreal (:) = Values !11 + npp_c3arcgrass (:) = Values !12 + npp_c3grass (:) = Values !13 + npp_c4grass (:) = Values !14 + npptoleafc_enftemp (:) = Values !1 + npptoleafc_enfboreal (:) = Values !2 + npptoleafc_dnfboreal (:) = Values !3 + npptoleafc_ebftrop (:) = Values !4 + npptoleafc_ebftemp (:) = Values !5 + npptoleafc_dbftrop (:) = Values !6 + npptoleafc_dbftemp (:) = Values !7 + npptoleafc_dbfboreal (:) = Values !8 + npptoleafc_ebstemp (:) = Values !9 + npptoleafc_dbstemp (:) = Values !10 + npptoleafc_dbsboreal (:) = Values !11 + npptoleafc_c3arcgrass (:) = Values !12 + npptoleafc_c3grass (:) = Values !13 + npptoleafc_c4grass (:) = Values !14 + leafc_enftemp (:) = Values !1 + leafc_enfboreal (:) = Values !2 + leafc_dnfboreal (:) = Values !3 + leafc_ebftrop (:) = Values !4 + leafc_ebftemp (:) = Values !5 + leafc_dbftrop (:) = Values !6 + leafc_dbftemp (:) = Values !7 + leafc_dbfboreal (:) = Values !8 + leafc_ebstemp (:) = Values !9 + leafc_dbstemp (:) = Values !10 + leafc_dbsboreal (:) = Values !11 + leafc_c3arcgrass (:) = Values !12 + leafc_c3grass (:) = Values !13 + leafc_c4grass (:) = Values !14 + ar (:) = Values + cwdprod (:) = Values + cwddecomp (:) = Values + hr (:) = Values + er (:) = Values + fire_closs (:) = Values + fire_nloss (:) = Values + hrv_xsmrpool_to_atm (:) = Values + wood_harvestc (:) = Values + wood_harvestn (:) = Values + grainc_to_cropprodc (:) = Values + grainc_to_seed (:) = Values + grainn_to_cropprodn (:) = Values + cropprod1c_loss (:) = Values + + +! decomposition carbon fluxes + decomp_cpools_sourcesink (:,:,:) = Values + decomp_ctransfer_vr (:,:,:) = Values + decomp_hr_vr (:,:,:) = Values + decomp_hr (:) = Values + phr_vr (:,: ) = Values + m_decomp_cpools_to_fire_vr (:,:,:) = Values + decomp_cpools_transport_tendency(:,:,:) = Values + som_c_leached (:) = Values + +! vegetation to decomposition carbon fluxes + phenology_to_met_c (:,:) = Values + phenology_to_cel_c (:,:) = Values + phenology_to_lig_c (:,:) = Values + gap_mortality_to_met_c (:,:) = Values + gap_mortality_to_cel_c (:,:) = Values + gap_mortality_to_lig_c (:,:) = Values + gap_mortality_to_cwdc (:,:) = Values + fire_mortality_to_met_c (:,:) = Values + fire_mortality_to_cel_c (:,:) = Values + fire_mortality_to_lig_c (:,:) = Values + fire_mortality_to_cwdc (:,:) = Values + +! decomposition nitrogen fluxes + decomp_npools_sourcesink (:,:,:) = Values + decomp_ntransfer_vr (:,:,:) = Values + decomp_sminn_flux_vr (:,:,:) = Values + sminn_to_denit_decomp_vr (:,:,:) = Values + m_decomp_npools_to_fire_vr (:,:,:) = Values + decomp_npools_transport_tendency(:,:,:) = Values + som_n_leached (:) = Values + +! vegetation to decomposition nitrogen fluxes + phenology_to_met_n (:,:) = Values + phenology_to_cel_n (:,:) = Values + phenology_to_lig_n (:,:) = Values + gap_mortality_to_met_n (:,:) = Values + gap_mortality_to_cel_n (:,:) = Values + gap_mortality_to_lig_n (:,:) = Values + gap_mortality_to_cwdn (:,:) = Values + fire_mortality_to_met_n (:,:) = Values + fire_mortality_to_cel_n (:,:) = Values + fire_mortality_to_lig_n (:,:) = Values + fire_mortality_to_cwdn (:,:) = Values + + sminn_leached_vr (:,:) = Values + smin_no3_leached_vr (:,:) = Values + smin_no3_runoff_vr (:,:) = Values + net_nmin_vr (:,:) = Values + gross_nmin_vr (:,:) = Values + net_nmin (:) = Values + gross_nmin (:) = Values + plant_ndemand (:) = Values + actual_immob_vr (:,:) = Values + actual_immob_nh4_vr (:,:) = Values + actual_immob_no3_vr (:,:) = Values + potential_immob_vr (:,:) = Values + pmnf_decomp (:,:,:) = Values + p_decomp_cpool_loss (:,:,:) = Values + sminn_to_plant (:) = Values + sminn_to_plant_vr (:,:) = Values + smin_nh4_to_plant_vr (:,:) = Values + smin_no3_to_plant_vr (:,:) = Values + supplement_to_sminn_vr (:,:) = Values + sminn_to_plant_fun_vr (:,:) = Values + sminn_to_plant_fun_nh4_vr(:,:) = Values + sminn_to_plant_fun_no3_vr(:,:) = Values + sminn_to_denit_excess_vr (:,:) = Values + f_nit_vr (:,:) = Values + f_denit_vr (:,:) = Values + f_n2o_nit_vr (:,:) = Values + f_n2o_denit_vr (:,:) = Values + pot_f_nit_vr (:,:) = Values + pot_f_denit_vr (:,:) = Values + n2_n2o_ratio_denit_vr (:,:) = Values + ndep_to_sminn (:) = Values + ffix_to_sminn (:) = Values + nfix_to_sminn (:) = Values + somc_fire (:) = Values + supplement_to_sminn (:) = Values + fert_to_sminn (:) = Values + soyfixn_to_sminn (:) = Values + denit (:) = Values + sminn_leached (:) = Values + f_n2o_nit (:) = Values + smin_no3_leached (:) = Values + smin_no3_runoff (:) = Values + ENDIF + ENDIF + + END SUBROUTINE set_1D_BGCFluxes + +#endif +END MODULE MOD_BGC_Vars_1DFluxes +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 new file mode 100644 index 0000000000..d32bee4b9a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_1DPFTFluxes.F90 @@ -0,0 +1,1313 @@ +#include + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +MODULE MOD_BGC_Vars_1DPFTFluxes +#ifdef BGC +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical flux variables at pft level + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! bgc variables + real(r8), allocatable :: leafc_xfer_to_leafc_p (:) ! pft level: phenology-associated flux: leaf transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: frootc_xfer_to_frootc_p (:) ! pft level: phenology-associated flux: fine root transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: livestemc_xfer_to_livestemc_p (:) ! pft level: phenology-associated flux: live stem transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: deadstemc_xfer_to_deadstemc_p (:) ! pft level: phenology-associated flux: dead stem transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: livecrootc_xfer_to_livecrootc_p (:) ! pft level: phenology-associated flux: live coarse root transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: deadcrootc_xfer_to_deadcrootc_p (:) ! pft level: phenology-associated flux: dead coarse root transfer C to display C (gC m-2 s-1) + real(r8), allocatable :: grainc_xfer_to_grainc_p (:) ! pft level: phenology-associated flux: grain transfer C to display C (gC m-2 s-1) + + real(r8), allocatable :: leafc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: leaf storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: frootc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: fine root storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: livestemc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: live stem storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: deadstemc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: dead stem storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: livecrootc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: live coarse root storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: deadcrootc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: dead coarse root storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: grainc_storage_to_xfer_p (:) ! pft level: phenology-associated flux: grain storage C to transfer C (gC m-2 s-1) + real(r8), allocatable :: gresp_storage_to_xfer_p (:) ! pft level: phenology-associated flux: growth respiration storage C to transfer C (gC m-2 s-1) + + real(r8), allocatable :: leafc_to_litter_p (:) ! pft level: phenology-associated flux: leaf display C to litter C (gC m-2 s-1) + real(r8), allocatable :: frootc_to_litter_p (:) ! pft level: phenology-associated flux: fine root display C to litter C (gC m-2 s-1) + real(r8), allocatable :: grainc_to_food_p (:) ! pft level: phenology-associated flux: grain display C to product C (gC m-2 s-1) + real(r8), allocatable :: grainc_to_seed_p (:) ! pft level: phenology-associated flux: grain display C to seed C (gC m-2 s-1) + real(r8), allocatable :: crop_seedc_to_leaf_p (:) ! pft level: phenology-associated flux: seed C to leaf display C (gC m-2 s-1) + real(r8), allocatable :: livestemc_to_litter_p (:) ! pft level: phenology-associated flux: live stem display C to litter C (gC m-2 s-1) + real(r8), allocatable :: livestemc_to_deadstemc_p (:) ! pft level: phenology-associated flux: live stem display C to dead stem display C (gC m-2 s-1) + real(r8), allocatable :: livecrootc_to_deadcrootc_p (:) ! pft level: phenology-associated flux: live coarse root display C to dead coarse root display C (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_frootc_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root display C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root display C to litter C (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_frootc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root storage C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_gresp_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: growth respiration storage C to litter C (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_frootc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root transfer C to litter C (gC m-2 s-1) + real(r8), allocatable :: m_gresp_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: growth respiration transfer C to litter C (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_frootc_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root display C to fire emissions (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_frootc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root storage C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_gresp_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: growth respiration storage C to fire emissions (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_frootc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root transfer C to fire emissions (gC m-2 s-1) + real(r8), allocatable :: m_gresp_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: growth respiration transfer C to fire emissions (gC m-2 s-1) + + real(r8), allocatable :: m_livestemc_to_deadstemc_fire_p (:) ! pft level: fire mortality-associated flux: live stem display C to dead stem display C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_to_deadcrootc_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display C to dead coarse root display C due to fire (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_frootc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root display C to litter C due to fire (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_frootc_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_storage_to_litter_fire_p(:) ! pft level: fire mortality-associated flux: live coarse root storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_storage_to_litter_fire_p(:) ! pft level: fire mortality-associated flux: dead coarse root storage C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_gresp_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: growth respiration storage C to litter C due to fire (gC m-2 s-1) + + real(r8), allocatable :: m_leafc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_frootc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livestemc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadstemc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_livecrootc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_deadcrootc_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root transfer C to litter C due to fire (gC m-2 s-1) + real(r8), allocatable :: m_gresp_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: growth respiration transfer C to litter C due to fire (gC m-2 s-1) + + real(r8), allocatable :: cpool_to_xsmrpool_p (:) ! pft level: allocation-associated flux: available C allocated to maintenance respiration storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_gresp_storage_p (:) ! pft level: allocation-associated flux: available C allocated to growth respiration storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_leafc_p (:) ! pft level: allocation-associated flux: available C allocated to leaf display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_leafc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to leaf storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_frootc_p (:) ! pft level: allocation-associated flux: available C allocated to fine root display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_frootc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to fine root storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_livestemc_p (:) ! pft level: allocation-associated flux: available C allocated to live stem display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_livestemc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to live stem storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_deadstemc_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_deadstemc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_livecrootc_p (:) ! pft level: allocation-associated flux: available C allocated to live coarse display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_livecrootc_storage_p(:) ! pft level: allocation-associated flux: available C allocated to live coarse storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_deadcrootc_p (:) ! pft level: allocation-associated flux: available C allocated to dead coarse root display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_deadcrootc_storage_p(:) ! pft level: allocation-associated flux: available C allocated to dead coarse root storage C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_grainc_p (:) ! pft level: allocation-associated flux: available C allocated to grain display C (gC m-2 s-1) + real(r8), allocatable :: cpool_to_grainc_storage_p (:) ! pft level: allocation-associated flux: available C allocated to grain storage C (gC m-2 s-1) + + real(r8), allocatable :: leaf_xsmr_p (:) ! pft level: leaf maintenance respiration storage C due to available C deficit (gC m-2 s-1) + real(r8), allocatable :: froot_xsmr_p (:) ! pft level: fine root maintenance respiration storage C due to available C deficit (gC m-2 s-1) + real(r8), allocatable :: livestem_xsmr_p (:) ! pft level: live stem maintenance respiration storage C due to available C deficit (gC m-2 s-1) + real(r8), allocatable :: livecroot_xsmr_p (:) ! pft level: live coarse root maintenance respiration storage C due to available C deficit (gC m-2 s-1) + real(r8), allocatable :: grain_xsmr_p (:) ! pft level: grain maintenance respiration storage C due to available C deficit (gC m-2 s-1) + + real(r8), allocatable :: cpool_leaf_gr_p (:) ! pft level: allocation-associated flux: available C allocated to leaf display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_froot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to fine root display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_livestem_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live stem display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_deadstem_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_livecroot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live coarse display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_deadcroot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead coarse display growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_grain_gr_p (:) ! pft level: allocation-associated flux: available C allocated to grain display growth respiration (gC m-2 s-1) + + real(r8), allocatable :: cpool_leaf_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to leaf storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_froot_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to fine root storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_livestem_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live stem storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_deadstem_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_livecroot_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live coarse storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_deadcroot_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead coarse storage growth respiration (gC m-2 s-1) + real(r8), allocatable :: cpool_grain_storage_gr_p (:) ! pft level: allocation-associated flux: available C allocated to grain storage growth respiration (gC m-2 s-1) + + real(r8), allocatable :: transfer_leaf_gr_p (:) ! pft level: allocation-associated flux: available C allocated to leaf transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_froot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to fine root transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_livestem_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live stem transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_deadstem_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead stem transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_livecroot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to live coarse transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_deadcroot_gr_p (:) ! pft level: allocation-associated flux: available C allocated to dead coarse transfer growth respiration (gC m-2 s-1) + real(r8), allocatable :: transfer_grain_gr_p (:) ! pft level: allocation-associated flux: available C allocated to grain transfer growth respiration (gC m-2 s-1) + + real(r8), allocatable :: xsmrpool_to_atm_p (:) ! pft level: maintenance respiration storage C to atmosphere due to harvest (gC m-2 s-1) + + real(r8), allocatable :: cropprod1c_loss_p (:) ! pft level: product loss (gC m-2 s-1) + + real(r8), allocatable :: plant_ndemand_p (:) ! pft level: plant potential demand N (gN m-2 s-1) + + real(r8), allocatable :: leafn_xfer_to_leafn_p (:) ! pft level: phenology-associated flux: leaf transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: frootn_xfer_to_frootn_p (:) ! pft level: phenology-associated flux: fine root transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: livestemn_xfer_to_livestemn_p (:) ! pft level: phenology-associated flux: live stem transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: deadstemn_xfer_to_deadstemn_p (:) ! pft level: phenology-associated flux: dead stem transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: livecrootn_xfer_to_livecrootn_p (:) ! pft level: phenology-associated flux: live coarse root transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: deadcrootn_xfer_to_deadcrootn_p (:) ! pft level: phenology-associated flux: dead coarse root transfer N to display N (gN m-2 s-1) + real(r8), allocatable :: grainn_xfer_to_grainn_p (:) ! pft level: phenology-associated flux: grain transfer N to display N (gN m-2 s-1) + + real(r8), allocatable :: leafn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: leaf storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: frootn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: fine root storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: livestemn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: live stem storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: deadstemn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: dead stem storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: livecrootn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: live coarse root storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: deadcrootn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: dead coarse root storage N to transfer N (gN m-2 s-1) + real(r8), allocatable :: grainn_storage_to_xfer_p (:) ! pft level: phenology-associated flux: grain storage N to transfer N (gN m-2 s-1) + + real(r8), allocatable :: leafn_to_litter_p (:) ! pft level: phenology-associated flux: leaf display N to litter N (gN m-2 s-1) + real(r8), allocatable :: frootn_to_litter_p (:) ! pft level: phenology-associated flux: fine root display N to litter N (gN m-2 s-1) + real(r8), allocatable :: grainn_to_food_p (:) ! pft level: phenology-associated flux: grain display N to product N (gN m-2 s-1) + real(r8), allocatable :: grainn_to_seed_p (:) ! pft level: phenology-associated flux: grain display N to seed N (gN m-2 s-1) + real(r8), allocatable :: crop_seedn_to_leaf_p (:) ! pft level: phenology-associated flux: seed N to leaf display N (gN m-2 s-1) + real(r8), allocatable :: livestemn_to_litter_p (:) ! pft level: phenology-associated flux: live stem display N to litter N (gN m-2 s-1) + real(r8), allocatable :: livestemn_to_deadstemn_p (:) ! pft level: phenology-associated flux: live stem display N to dead stem display N (gN m-2 s-1) + real(r8), allocatable :: livecrootn_to_deadcrootn_p (:) ! pft level: phenology-associated flux: live coarse root display N to dead coarse root display N (gN m-2 s-1) + + real(r8), allocatable :: leafn_to_retransn_p (:) ! pft level: phenology-associated flux: leaf display N to retranslocated N (gN m-2 s-1) + real(r8), allocatable :: frootn_to_retransn_p (:) ! pft level: phenology-associated flux: fine root display N to retranslocated N (gN m-2 s-1) + real(r8), allocatable :: livestemn_to_retransn_p (:) ! pft level: phenology-associated flux: live stem display N to retranslocated N (gN m-2 s-1) + real(r8), allocatable :: livecrootn_to_retransn_p (:) ! pft level: phenology-associated flux: live coarse root display N to retranslocated N (gN m-2 s-1) + real(r8), allocatable :: retransn_to_npool_p (:) ! pft level: phenology-associated flux: retranslocated N to available N (gN m-2 s-1) + real(r8), allocatable :: free_retransn_to_npool_p (:) ! pft level: phenology-associated flux: retranslocated N to available N (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_frootn_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root display N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_retransn_to_litter_p (:) ! pft level: gap mortality-associated flux: retranslocated N to litter N (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_frootn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root storage N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_storage_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root storage N to litter N (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: leaf transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_frootn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: fine root transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: live stem transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: dead stem transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: live coarse root transfer N to litter N (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_xfer_to_litter_p (:) ! pft level: gap mortality-associated flux: dead coarse root transfer N to litter N (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_frootn_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root display N to fire emissions (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_frootn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root storage N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_storage_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root storage N to fire emissions (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: leaf transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_frootn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: fine root transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: live stem transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: dead stem transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root transfer N to fire emissions (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_xfer_to_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root transfer N to fire emissions (gN m-2 s-1) + + real(r8), allocatable :: m_livestemn_to_deadstemn_fire_p (:) ! pft level: fire mortality-associated flux: live stem display N to dead stem display N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_to_deadcrootn_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display N to dead coarse root display N due to fire (gN m-2 s-1) + + real(r8), allocatable :: m_retransn_to_fire_p (:) ! pft level: fire mortality-associated flux: retranslocated N to fire emissions (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_frootn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root display N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root display N to litter N due to fire (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_frootn_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_storage_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_storage_to_litter_fire_p(:) ! pft level: fire mortality-associated flux: live coarse root storage N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_storage_to_litter_fire_p(:) ! pft level: fire mortality-associated flux: dead coarse root storage N to litter N due to fire (gN m-2 s-1) + + real(r8), allocatable :: m_leafn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: leaf transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_frootn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: fine root transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livestemn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live stem transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadstemn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead stem transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_livecrootn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: live coarse root transfer N to litter N due to fire (gN m-2 s-1) + real(r8), allocatable :: m_deadcrootn_xfer_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: dead coarse root transfer N to litter N due to fire (gN m-2 s-1) + + real(r8), allocatable :: m_retransn_to_litter_fire_p (:) ! pft level: fire mortality-associated flux: retranslocated N to litter N due to fire (gN m-2 s-1) + + real(r8), allocatable :: npool_to_leafn_p (:) ! pft level: allocation-associated flux: available N allocated to leaf display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_leafn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to leaf storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_frootn_p (:) ! pft level: allocation-associated flux: available N allocated to fine root display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_frootn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to fine root storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_livestemn_p (:) ! pft level: allocation-associated flux: available N allocated to live stem display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_livestemn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to live stem storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_deadstemn_p (:) ! pft level: allocation-associated flux: available N allocated to dead stem display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_deadstemn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to dead stem storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_livecrootn_p (:) ! pft level: allocation-associated flux: available N allocated to live coarse display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_livecrootn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to live coarse storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_deadcrootn_p (:) ! pft level: allocation-associated flux: available N allocated to dead coarse root display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_deadcrootn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to dead coarse root storage N (gN m-2 s-1) + real(r8), allocatable :: npool_to_grainn_p (:) ! pft level: allocation-associated flux: available N allocated to grain display N (gN m-2 s-1) + real(r8), allocatable :: npool_to_grainn_storage_p (:) ! pft level: allocation-associated flux: available N allocated to grain storage N (gN m-2 s-1) + + real(r8), allocatable :: respcsun_p (:) ! pft level: sunlit leaf respiration (gC m-2 s-1) + real(r8), allocatable :: respcsha_p (:) ! pft level: shaded leaf respiration (gC m-2 s-1) + real(r8), allocatable :: leaf_mr_p (:) ! pft level: leaf maintenance respiration (gC m-2 s-1) + real(r8), allocatable :: froot_mr_p (:) ! pft level: fine root maintenance respiration (gC m-2 s-1) + real(r8), allocatable :: livestem_mr_p (:) ! pft level: live stem maintenance respiration (gC m-2 s-1) + real(r8), allocatable :: livecroot_mr_p (:) ! pft level: live coarse root maintenance respiration (gC m-2 s-1) + real(r8), allocatable :: grain_mr_p (:) ! pft level: grain maintenance respiration (gC m-2 s-1) + + real(r8), allocatable :: soil_change_p (:) ! pft level: soil carbon used by FUN (gC m-2 s-1) + + real(r8), allocatable :: psn_to_cpool_p (:) ! pft level: photosynthesis rate (gC m-2 s-1) + real(r8), allocatable :: gpp_p (:) ! pft level: gross primary production (gC m-2 s-1) + real(r8), allocatable :: availc_p (:) ! pft level: available C (gC m-2 s-1) + real(r8), allocatable :: avail_retransn_p (:) ! pft level: available retranslocated N (gN m-2 s-1) + real(r8), allocatable :: xsmrpool_recover_p (:) ! pft level: available C to maintenance respiration storage C to recover previous excess mainte + real(r8), allocatable :: excess_cflux_p (:) ! pft level: excess C due to N limitation (gC m-2 s-1) + real(r8), allocatable :: sminn_to_npool_p (:) ! pft level: soil mineral N uptake for plant growth (gN m-2 s-1) + + real(r8), allocatable :: plant_calloc_p (:) ! pft level: actual available C for plant grwoth (gC m-2 s-1) + real(r8), allocatable :: plant_nalloc_p (:) ! pft level: actual available N for plant growth (gN m-2 s-1) + real(r8), allocatable :: leaf_curmr_p (:) ! pft level: leaf maintenance respiration from current available C (gC m-2 s-1) + real(r8), allocatable :: froot_curmr_p (:) ! pft level: fine root maintenance respiration from current available C (gC m-2 s-1) + real(r8), allocatable :: livestem_curmr_p (:) ! pft level: live stem maintenance respiration from current available C (gC m-2 s-1) + real(r8), allocatable :: livecroot_curmr_p (:) ! pft level: live coarse root maintenance respiration from current available C (gC m-2 s-1) + real(r8), allocatable :: grain_curmr_p (:) ! pft level: grain maintenance respiration from current available C (gC m-2 s-1) + + real(r8), allocatable :: fire_closs_p (:) ! pft level: total C emissions due to fire (gC m-2 s-1) + real(r8), allocatable :: fire_nloss_p (:) ! pft level: total N emissions due to fire (gN m-2 s-1) + real(r8), allocatable :: wood_harvestc_p (:) ! pft level: harvested wood C (gC m-2 s-1) + real(r8), allocatable :: wood_harvestn_p (:) ! pft level: harvested wood N (gN m-2 s-1) + real(r8), allocatable :: grainc_to_cropprodc_p (:) ! pft level: harvested grain C (gC m-2 s-1) + real(r8), allocatable :: grainn_to_cropprodn_p (:) ! pft level: harvested grain N (gN m-2 s-1) + real(r8), allocatable :: hrv_xsmrpool_to_atm_p (:) ! pft level: maintenance respiration storage C to atmosphere due to harvest (gC m-2 s-1) + real(r8), allocatable :: soyfixn_p (:) ! pft level: soybean fixed nitrogen rate (gN m-2 s-1) + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_BGCPFTFluxes + PUBLIC :: deallocate_1D_BGCPFTFluxes + PUBLIC :: set_1D_BGCPFTFluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_BGCPFTFluxes + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandPFT + IMPLICIT NONE + + IF (.true.) THEN + IF (numpft > 0) THEN + + ! bgc variables + allocate (leafc_xfer_to_leafc_p (numpft)) ; leafc_xfer_to_leafc_p (:) = spval + allocate (frootc_xfer_to_frootc_p (numpft)) ; frootc_xfer_to_frootc_p (:) = spval + allocate (livestemc_xfer_to_livestemc_p (numpft)) ; livestemc_xfer_to_livestemc_p (:) = spval + allocate (deadstemc_xfer_to_deadstemc_p (numpft)) ; deadstemc_xfer_to_deadstemc_p (:) = spval + allocate (livecrootc_xfer_to_livecrootc_p (numpft)) ; livecrootc_xfer_to_livecrootc_p (:) = spval + allocate (deadcrootc_xfer_to_deadcrootc_p (numpft)) ; deadcrootc_xfer_to_deadcrootc_p (:) = spval + allocate (grainc_xfer_to_grainc_p (numpft)) ; grainc_xfer_to_grainc_p (:) = spval + + allocate (leafc_storage_to_xfer_p (numpft)) ; leafc_storage_to_xfer_p (:) = spval + allocate (frootc_storage_to_xfer_p (numpft)) ; frootc_storage_to_xfer_p (:) = spval + allocate (livestemc_storage_to_xfer_p (numpft)) ; livestemc_storage_to_xfer_p (:) = spval + allocate (deadstemc_storage_to_xfer_p (numpft)) ; deadstemc_storage_to_xfer_p (:) = spval + allocate (livecrootc_storage_to_xfer_p (numpft)) ; livecrootc_storage_to_xfer_p (:) = spval + allocate (deadcrootc_storage_to_xfer_p (numpft)) ; deadcrootc_storage_to_xfer_p (:) = spval + allocate (grainc_storage_to_xfer_p (numpft)) ; grainc_storage_to_xfer_p (:) = spval + allocate (gresp_storage_to_xfer_p (numpft)) ; gresp_storage_to_xfer_p (:) = spval + + allocate (leafc_to_litter_p (numpft)) ; leafc_to_litter_p (:) = spval + allocate (frootc_to_litter_p (numpft)) ; frootc_to_litter_p (:) = spval + allocate (grainc_to_food_p (numpft)) ; grainc_to_food_p (:) = spval + allocate (grainc_to_seed_p (numpft)) ; grainc_to_seed_p (:) = spval + allocate (crop_seedc_to_leaf_p (numpft)) ; crop_seedc_to_leaf_p (:) = spval + allocate (livestemc_to_litter_p (numpft)) ; livestemc_to_litter_p (:) = spval + allocate (livestemc_to_deadstemc_p (numpft)) ; livestemc_to_deadstemc_p (:) = spval + allocate (livecrootc_to_deadcrootc_p (numpft)) ; livecrootc_to_deadcrootc_p (:) = spval + + allocate (m_leafc_to_litter_p (numpft)) ; m_leafc_to_litter_p (:) = spval + allocate (m_frootc_to_litter_p (numpft)) ; m_frootc_to_litter_p (:) = spval + allocate (m_livestemc_to_litter_p (numpft)) ; m_livestemc_to_litter_p (:) = spval + allocate (m_deadstemc_to_litter_p (numpft)) ; m_deadstemc_to_litter_p (:) = spval + allocate (m_livecrootc_to_litter_p (numpft)) ; m_livecrootc_to_litter_p (:) = spval + allocate (m_deadcrootc_to_litter_p (numpft)) ; m_deadcrootc_to_litter_p (:) = spval + + allocate (m_leafc_storage_to_litter_p (numpft)) ; m_leafc_storage_to_litter_p (:) = spval + allocate (m_frootc_storage_to_litter_p (numpft)) ; m_frootc_storage_to_litter_p (:) = spval + allocate (m_livestemc_storage_to_litter_p (numpft)) ; m_livestemc_storage_to_litter_p (:) = spval + allocate (m_deadstemc_storage_to_litter_p (numpft)) ; m_deadstemc_storage_to_litter_p (:) = spval + allocate (m_livecrootc_storage_to_litter_p (numpft)) ; m_livecrootc_storage_to_litter_p (:) = spval + allocate (m_deadcrootc_storage_to_litter_p (numpft)) ; m_deadcrootc_storage_to_litter_p (:) = spval + allocate (m_gresp_storage_to_litter_p (numpft)) ; m_gresp_storage_to_litter_p (:) = spval + + allocate (m_leafc_xfer_to_litter_p (numpft)) ; m_leafc_xfer_to_litter_p (:) = spval + allocate (m_frootc_xfer_to_litter_p (numpft)) ; m_frootc_xfer_to_litter_p (:) = spval + allocate (m_livestemc_xfer_to_litter_p (numpft)) ; m_livestemc_xfer_to_litter_p (:) = spval + allocate (m_deadstemc_xfer_to_litter_p (numpft)) ; m_deadstemc_xfer_to_litter_p (:) = spval + allocate (m_livecrootc_xfer_to_litter_p (numpft)) ; m_livecrootc_xfer_to_litter_p (:) = spval + allocate (m_deadcrootc_xfer_to_litter_p (numpft)) ; m_deadcrootc_xfer_to_litter_p (:) = spval + allocate (m_gresp_xfer_to_litter_p (numpft)) ; m_gresp_xfer_to_litter_p (:) = spval + + allocate (m_leafc_to_fire_p (numpft)) ; m_leafc_to_fire_p (:) = spval + allocate (m_frootc_to_fire_p (numpft)) ; m_frootc_to_fire_p (:) = spval + allocate (m_livestemc_to_fire_p (numpft)) ; m_livestemc_to_fire_p (:) = spval + allocate (m_deadstemc_to_fire_p (numpft)) ; m_deadstemc_to_fire_p (:) = spval + allocate (m_livecrootc_to_fire_p (numpft)) ; m_livecrootc_to_fire_p (:) = spval + allocate (m_deadcrootc_to_fire_p (numpft)) ; m_deadcrootc_to_fire_p (:) = spval + + allocate (m_leafc_storage_to_fire_p (numpft)) ; m_leafc_storage_to_fire_p (:) = spval + allocate (m_frootc_storage_to_fire_p (numpft)) ; m_frootc_storage_to_fire_p (:) = spval + allocate (m_livestemc_storage_to_fire_p (numpft)) ; m_livestemc_storage_to_fire_p (:) = spval + allocate (m_deadstemc_storage_to_fire_p (numpft)) ; m_deadstemc_storage_to_fire_p (:) = spval + allocate (m_livecrootc_storage_to_fire_p (numpft)) ; m_livecrootc_storage_to_fire_p (:) = spval + allocate (m_deadcrootc_storage_to_fire_p (numpft)) ; m_deadcrootc_storage_to_fire_p (:) = spval + allocate (m_gresp_storage_to_fire_p (numpft)) ; m_gresp_storage_to_fire_p (:) = spval + + allocate (m_leafc_xfer_to_fire_p (numpft)) ; m_leafc_xfer_to_fire_p (:) = spval + allocate (m_frootc_xfer_to_fire_p (numpft)) ; m_frootc_xfer_to_fire_p (:) = spval + allocate (m_livestemc_xfer_to_fire_p (numpft)) ; m_livestemc_xfer_to_fire_p (:) = spval + allocate (m_deadstemc_xfer_to_fire_p (numpft)) ; m_deadstemc_xfer_to_fire_p (:) = spval + allocate (m_livecrootc_xfer_to_fire_p (numpft)) ; m_livecrootc_xfer_to_fire_p (:) = spval + allocate (m_deadcrootc_xfer_to_fire_p (numpft)) ; m_deadcrootc_xfer_to_fire_p (:) = spval + allocate (m_gresp_xfer_to_fire_p (numpft)) ; m_gresp_xfer_to_fire_p (:) = spval + + allocate (m_livestemc_to_deadstemc_fire_p (numpft)) ; m_livestemc_to_deadstemc_fire_p (:) = spval + allocate (m_livecrootc_to_deadcrootc_fire_p (numpft)) ; m_livecrootc_to_deadcrootc_fire_p (:) = spval + + allocate (m_leafc_to_litter_fire_p (numpft)) ; m_leafc_to_litter_fire_p (:) = spval + allocate (m_frootc_to_litter_fire_p (numpft)) ; m_frootc_to_litter_fire_p (:) = spval + allocate (m_livestemc_to_litter_fire_p (numpft)) ; m_livestemc_to_litter_fire_p (:) = spval + allocate (m_deadstemc_to_litter_fire_p (numpft)) ; m_deadstemc_to_litter_fire_p (:) = spval + allocate (m_livecrootc_to_litter_fire_p (numpft)) ; m_livecrootc_to_litter_fire_p (:) = spval + allocate (m_deadcrootc_to_litter_fire_p (numpft)) ; m_deadcrootc_to_litter_fire_p (:) = spval + + allocate (m_leafc_storage_to_litter_fire_p (numpft)) ; m_leafc_storage_to_litter_fire_p (:) = spval + allocate (m_frootc_storage_to_litter_fire_p (numpft)) ; m_frootc_storage_to_litter_fire_p (:) = spval + allocate (m_livestemc_storage_to_litter_fire_p (numpft)) ; m_livestemc_storage_to_litter_fire_p (:) = spval + allocate (m_deadstemc_storage_to_litter_fire_p (numpft)) ; m_deadstemc_storage_to_litter_fire_p (:) = spval + allocate (m_livecrootc_storage_to_litter_fire_p(numpft)) ; m_livecrootc_storage_to_litter_fire_p(:) = spval + allocate (m_deadcrootc_storage_to_litter_fire_p(numpft)) ; m_deadcrootc_storage_to_litter_fire_p(:) = spval + allocate (m_gresp_storage_to_litter_fire_p (numpft)) ; m_gresp_storage_to_litter_fire_p (:) = spval + + allocate (m_leafc_xfer_to_litter_fire_p (numpft)) ; m_leafc_xfer_to_litter_fire_p (:) = spval + allocate (m_frootc_xfer_to_litter_fire_p (numpft)) ; m_frootc_xfer_to_litter_fire_p (:) = spval + allocate (m_livestemc_xfer_to_litter_fire_p (numpft)) ; m_livestemc_xfer_to_litter_fire_p (:) = spval + allocate (m_deadstemc_xfer_to_litter_fire_p (numpft)) ; m_deadstemc_xfer_to_litter_fire_p (:) = spval + allocate (m_livecrootc_xfer_to_litter_fire_p (numpft)) ; m_livecrootc_xfer_to_litter_fire_p (:) = spval + allocate (m_deadcrootc_xfer_to_litter_fire_p (numpft)) ; m_deadcrootc_xfer_to_litter_fire_p (:) = spval + allocate (m_gresp_xfer_to_litter_fire_p (numpft)) ; m_gresp_xfer_to_litter_fire_p (:) = spval + + allocate (cpool_to_xsmrpool_p (numpft)) ; cpool_to_xsmrpool_p (:) = spval + allocate (cpool_to_gresp_storage_p (numpft)) ; cpool_to_gresp_storage_p (:) = spval + allocate (cpool_to_leafc_p (numpft)) ; cpool_to_leafc_p (:) = spval + allocate (cpool_to_leafc_storage_p (numpft)) ; cpool_to_leafc_storage_p (:) = spval + allocate (cpool_to_frootc_p (numpft)) ; cpool_to_frootc_p (:) = spval + allocate (cpool_to_frootc_storage_p (numpft)) ; cpool_to_frootc_storage_p (:) = spval + allocate (cpool_to_livestemc_p (numpft)) ; cpool_to_livestemc_p (:) = spval + allocate (cpool_to_livestemc_storage_p (numpft)) ; cpool_to_livestemc_storage_p (:) = spval + allocate (cpool_to_deadstemc_p (numpft)) ; cpool_to_deadstemc_p (:) = spval + allocate (cpool_to_deadstemc_storage_p (numpft)) ; cpool_to_deadstemc_storage_p (:) = spval + allocate (cpool_to_livecrootc_p (numpft)) ; cpool_to_livecrootc_p (:) = spval + allocate (cpool_to_livecrootc_storage_p(numpft)) ; cpool_to_livecrootc_storage_p(:) = spval + allocate (cpool_to_deadcrootc_p (numpft)) ; cpool_to_deadcrootc_p (:) = spval + allocate (cpool_to_deadcrootc_storage_p(numpft)) ; cpool_to_deadcrootc_storage_p(:) = spval + allocate (cpool_to_grainc_p (numpft)) ; cpool_to_grainc_p (:) = spval + allocate (cpool_to_grainc_storage_p (numpft)) ; cpool_to_grainc_storage_p (:) = spval + + allocate (leaf_xsmr_p (numpft)) ; leaf_xsmr_p (:) = spval + allocate (froot_xsmr_p (numpft)) ; froot_xsmr_p (:) = spval + allocate (livestem_xsmr_p (numpft)) ; livestem_xsmr_p (:) = spval + allocate (livecroot_xsmr_p (numpft)) ; livecroot_xsmr_p (:) = spval + allocate (grain_xsmr_p (numpft)) ; grain_xsmr_p (:) = spval + + allocate (cpool_leaf_gr_p (numpft)) ; cpool_leaf_gr_p (:) = spval + allocate (cpool_froot_gr_p (numpft)) ; cpool_froot_gr_p (:) = spval + allocate (cpool_livestem_gr_p (numpft)) ; cpool_livestem_gr_p (:) = spval + allocate (cpool_deadstem_gr_p (numpft)) ; cpool_deadstem_gr_p (:) = spval + allocate (cpool_livecroot_gr_p (numpft)) ; cpool_livecroot_gr_p (:) = spval + allocate (cpool_deadcroot_gr_p (numpft)) ; cpool_deadcroot_gr_p (:) = spval + allocate (cpool_grain_gr_p (numpft)) ; cpool_grain_gr_p (:) = spval + + allocate (cpool_leaf_storage_gr_p (numpft)) ; cpool_leaf_storage_gr_p (:) = spval + allocate (cpool_froot_storage_gr_p (numpft)) ; cpool_froot_storage_gr_p (:) = spval + allocate (cpool_livestem_storage_gr_p (numpft)) ; cpool_livestem_storage_gr_p (:) = spval + allocate (cpool_deadstem_storage_gr_p (numpft)) ; cpool_deadstem_storage_gr_p (:) = spval + allocate (cpool_livecroot_storage_gr_p (numpft)) ; cpool_livecroot_storage_gr_p (:) = spval + allocate (cpool_deadcroot_storage_gr_p (numpft)) ; cpool_deadcroot_storage_gr_p (:) = spval + allocate (cpool_grain_storage_gr_p (numpft)) ; cpool_grain_storage_gr_p (:) = spval + + allocate (transfer_leaf_gr_p (numpft)) ; transfer_leaf_gr_p (:) = spval + allocate (transfer_froot_gr_p (numpft)) ; transfer_froot_gr_p (:) = spval + allocate (transfer_livestem_gr_p (numpft)) ; transfer_livestem_gr_p (:) = spval + allocate (transfer_deadstem_gr_p (numpft)) ; transfer_deadstem_gr_p (:) = spval + allocate (transfer_livecroot_gr_p (numpft)) ; transfer_livecroot_gr_p (:) = spval + allocate (transfer_deadcroot_gr_p (numpft)) ; transfer_deadcroot_gr_p (:) = spval + allocate (transfer_grain_gr_p (numpft)) ; transfer_grain_gr_p (:) = spval + + allocate (xsmrpool_to_atm_p (numpft)) ; xsmrpool_to_atm_p (:) = spval + + allocate (cropprod1c_loss_p (numpft)) ; cropprod1c_loss_p (:) = spval + + allocate (plant_ndemand_p (numpft)) ; plant_ndemand_p (:) = spval + + allocate (leafn_xfer_to_leafn_p (numpft)) ; leafn_xfer_to_leafn_p (:) = spval + allocate (frootn_xfer_to_frootn_p (numpft)) ; frootn_xfer_to_frootn_p (:) = spval + allocate (livestemn_xfer_to_livestemn_p (numpft)) ; livestemn_xfer_to_livestemn_p (:) = spval + allocate (deadstemn_xfer_to_deadstemn_p (numpft)) ; deadstemn_xfer_to_deadstemn_p (:) = spval + allocate (livecrootn_xfer_to_livecrootn_p (numpft)) ; livecrootn_xfer_to_livecrootn_p (:) = spval + allocate (deadcrootn_xfer_to_deadcrootn_p (numpft)) ; deadcrootn_xfer_to_deadcrootn_p (:) = spval + allocate (grainn_xfer_to_grainn_p (numpft)) ; grainn_xfer_to_grainn_p (:) = spval + + allocate (leafn_storage_to_xfer_p (numpft)) ; leafn_storage_to_xfer_p (:) = spval + allocate (frootn_storage_to_xfer_p (numpft)) ; frootn_storage_to_xfer_p (:) = spval + allocate (livestemn_storage_to_xfer_p (numpft)) ; livestemn_storage_to_xfer_p (:) = spval + allocate (deadstemn_storage_to_xfer_p (numpft)) ; deadstemn_storage_to_xfer_p (:) = spval + allocate (livecrootn_storage_to_xfer_p (numpft)) ; livecrootn_storage_to_xfer_p (:) = spval + allocate (deadcrootn_storage_to_xfer_p (numpft)) ; deadcrootn_storage_to_xfer_p (:) = spval + allocate (grainn_storage_to_xfer_p (numpft)) ; grainn_storage_to_xfer_p (:) = spval + + allocate (leafn_to_litter_p (numpft)) ; leafn_to_litter_p (:) = spval + allocate (frootn_to_litter_p (numpft)) ; frootn_to_litter_p (:) = spval + allocate (grainn_to_food_p (numpft)) ; grainn_to_food_p (:) = spval + allocate (grainn_to_seed_p (numpft)) ; grainn_to_seed_p (:) = spval + allocate (crop_seedn_to_leaf_p (numpft)) ; crop_seedn_to_leaf_p (:) = spval + allocate (livestemn_to_litter_p (numpft)) ; livestemn_to_litter_p (:) = spval + allocate (livestemn_to_deadstemn_p (numpft)) ; livestemn_to_deadstemn_p (:) = spval + allocate (livecrootn_to_deadcrootn_p (numpft)) ; livecrootn_to_deadcrootn_p (:) = spval + + allocate (leafn_to_retransn_p (numpft)) ; leafn_to_retransn_p (:) = spval + allocate (frootn_to_retransn_p (numpft)) ; frootn_to_retransn_p (:) = spval + allocate (livestemn_to_retransn_p (numpft)) ; livestemn_to_retransn_p (:) = spval + allocate (livecrootn_to_retransn_p (numpft)) ; livecrootn_to_retransn_p (:) = spval + allocate (retransn_to_npool_p (numpft)) ; retransn_to_npool_p (:) = spval + allocate (free_retransn_to_npool_p (numpft)) ; free_retransn_to_npool_p (:) = spval + + allocate (m_leafn_to_litter_p (numpft)) ; m_leafn_to_litter_p (:) = spval + allocate (m_frootn_to_litter_p (numpft)) ; m_frootn_to_litter_p (:) = spval + allocate (m_livestemn_to_litter_p (numpft)) ; m_livestemn_to_litter_p (:) = spval + allocate (m_deadstemn_to_litter_p (numpft)) ; m_deadstemn_to_litter_p (:) = spval + allocate (m_livecrootn_to_litter_p (numpft)) ; m_livecrootn_to_litter_p (:) = spval + allocate (m_deadcrootn_to_litter_p (numpft)) ; m_deadcrootn_to_litter_p (:) = spval + allocate (m_retransn_to_litter_p (numpft)) ; m_retransn_to_litter_p (:) = spval + + allocate (m_leafn_storage_to_litter_p (numpft)) ; m_leafn_storage_to_litter_p (:) = spval + allocate (m_frootn_storage_to_litter_p (numpft)) ; m_frootn_storage_to_litter_p (:) = spval + allocate (m_livestemn_storage_to_litter_p (numpft)) ; m_livestemn_storage_to_litter_p (:) = spval + allocate (m_deadstemn_storage_to_litter_p (numpft)) ; m_deadstemn_storage_to_litter_p (:) = spval + allocate (m_livecrootn_storage_to_litter_p (numpft)) ; m_livecrootn_storage_to_litter_p (:) = spval + allocate (m_deadcrootn_storage_to_litter_p (numpft)) ; m_deadcrootn_storage_to_litter_p (:) = spval + + allocate (m_leafn_xfer_to_litter_p (numpft)) ; m_leafn_xfer_to_litter_p (:) = spval + allocate (m_frootn_xfer_to_litter_p (numpft)) ; m_frootn_xfer_to_litter_p (:) = spval + allocate (m_livestemn_xfer_to_litter_p (numpft)) ; m_livestemn_xfer_to_litter_p (:) = spval + allocate (m_deadstemn_xfer_to_litter_p (numpft)) ; m_deadstemn_xfer_to_litter_p (:) = spval + allocate (m_livecrootn_xfer_to_litter_p (numpft)) ; m_livecrootn_xfer_to_litter_p (:) = spval + allocate (m_deadcrootn_xfer_to_litter_p (numpft)) ; m_deadcrootn_xfer_to_litter_p (:) = spval + + allocate (m_leafn_to_fire_p (numpft)) ; m_leafn_to_fire_p (:) = spval + allocate (m_frootn_to_fire_p (numpft)) ; m_frootn_to_fire_p (:) = spval + allocate (m_livestemn_to_fire_p (numpft)) ; m_livestemn_to_fire_p (:) = spval + allocate (m_deadstemn_to_fire_p (numpft)) ; m_deadstemn_to_fire_p (:) = spval + allocate (m_livecrootn_to_fire_p (numpft)) ; m_livecrootn_to_fire_p (:) = spval + allocate (m_deadcrootn_to_fire_p (numpft)) ; m_deadcrootn_to_fire_p (:) = spval + + allocate (m_leafn_storage_to_fire_p (numpft)) ; m_leafn_storage_to_fire_p (:) = spval + allocate (m_frootn_storage_to_fire_p (numpft)) ; m_frootn_storage_to_fire_p (:) = spval + allocate (m_livestemn_storage_to_fire_p (numpft)) ; m_livestemn_storage_to_fire_p (:) = spval + allocate (m_deadstemn_storage_to_fire_p (numpft)) ; m_deadstemn_storage_to_fire_p (:) = spval + allocate (m_livecrootn_storage_to_fire_p (numpft)) ; m_livecrootn_storage_to_fire_p (:) = spval + allocate (m_deadcrootn_storage_to_fire_p (numpft)) ; m_deadcrootn_storage_to_fire_p (:) = spval + + allocate (m_leafn_xfer_to_fire_p (numpft)) ; m_leafn_xfer_to_fire_p (:) = spval + allocate (m_frootn_xfer_to_fire_p (numpft)) ; m_frootn_xfer_to_fire_p (:) = spval + allocate (m_livestemn_xfer_to_fire_p (numpft)) ; m_livestemn_xfer_to_fire_p (:) = spval + allocate (m_deadstemn_xfer_to_fire_p (numpft)) ; m_deadstemn_xfer_to_fire_p (:) = spval + allocate (m_livecrootn_xfer_to_fire_p (numpft)) ; m_livecrootn_xfer_to_fire_p (:) = spval + allocate (m_deadcrootn_xfer_to_fire_p (numpft)) ; m_deadcrootn_xfer_to_fire_p (:) = spval + + allocate (m_livestemn_to_deadstemn_fire_p (numpft)) ; m_livestemn_to_deadstemn_fire_p (:) = spval + allocate (m_livecrootn_to_deadcrootn_fire_p (numpft)) ; m_livecrootn_to_deadcrootn_fire_p (:) = spval + + allocate (m_retransn_to_fire_p (numpft)) ; m_retransn_to_fire_p (:) = spval + + allocate (m_leafn_to_litter_fire_p (numpft)) ; m_leafn_to_litter_fire_p (:) = spval + allocate (m_frootn_to_litter_fire_p (numpft)) ; m_frootn_to_litter_fire_p (:) = spval + allocate (m_livestemn_to_litter_fire_p (numpft)) ; m_livestemn_to_litter_fire_p (:) = spval + allocate (m_deadstemn_to_litter_fire_p (numpft)) ; m_deadstemn_to_litter_fire_p (:) = spval + allocate (m_livecrootn_to_litter_fire_p (numpft)) ; m_livecrootn_to_litter_fire_p (:) = spval + allocate (m_deadcrootn_to_litter_fire_p (numpft)) ; m_deadcrootn_to_litter_fire_p (:) = spval + + allocate (m_leafn_storage_to_litter_fire_p (numpft)) ; m_leafn_storage_to_litter_fire_p (:) = spval + allocate (m_frootn_storage_to_litter_fire_p (numpft)) ; m_frootn_storage_to_litter_fire_p (:) = spval + allocate (m_livestemn_storage_to_litter_fire_p (numpft)) ; m_livestemn_storage_to_litter_fire_p (:) = spval + allocate (m_deadstemn_storage_to_litter_fire_p (numpft)) ; m_deadstemn_storage_to_litter_fire_p (:) = spval + allocate (m_livecrootn_storage_to_litter_fire_p(numpft)) ; m_livecrootn_storage_to_litter_fire_p(:) = spval + allocate (m_deadcrootn_storage_to_litter_fire_p(numpft)) ; m_deadcrootn_storage_to_litter_fire_p(:) = spval + + allocate (m_leafn_xfer_to_litter_fire_p (numpft)) ; m_leafn_xfer_to_litter_fire_p (:) = spval + allocate (m_frootn_xfer_to_litter_fire_p (numpft)) ; m_frootn_xfer_to_litter_fire_p (:) = spval + allocate (m_livestemn_xfer_to_litter_fire_p (numpft)) ; m_livestemn_xfer_to_litter_fire_p (:) = spval + allocate (m_deadstemn_xfer_to_litter_fire_p (numpft)) ; m_deadstemn_xfer_to_litter_fire_p (:) = spval + allocate (m_livecrootn_xfer_to_litter_fire_p (numpft)) ; m_livecrootn_xfer_to_litter_fire_p (:) = spval + allocate (m_deadcrootn_xfer_to_litter_fire_p (numpft)) ; m_deadcrootn_xfer_to_litter_fire_p (:) = spval + + allocate (m_retransn_to_litter_fire_p (numpft)) ; m_retransn_to_litter_fire_p (:) = spval + + allocate (npool_to_leafn_p (numpft)) ; npool_to_leafn_p (:) = spval + allocate (npool_to_leafn_storage_p (numpft)) ; npool_to_leafn_storage_p (:) = spval + allocate (npool_to_frootn_p (numpft)) ; npool_to_frootn_p (:) = spval + allocate (npool_to_frootn_storage_p (numpft)) ; npool_to_frootn_storage_p (:) = spval + allocate (npool_to_livestemn_p (numpft)) ; npool_to_livestemn_p (:) = spval + allocate (npool_to_livestemn_storage_p (numpft)) ; npool_to_livestemn_storage_p (:) = spval + allocate (npool_to_deadstemn_p (numpft)) ; npool_to_deadstemn_p (:) = spval + allocate (npool_to_deadstemn_storage_p (numpft)) ; npool_to_deadstemn_storage_p (:) = spval + allocate (npool_to_livecrootn_p (numpft)) ; npool_to_livecrootn_p (:) = spval + allocate (npool_to_livecrootn_storage_p (numpft)) ; npool_to_livecrootn_storage_p (:) = spval + allocate (npool_to_deadcrootn_p (numpft)) ; npool_to_deadcrootn_p (:) = spval + allocate (npool_to_deadcrootn_storage_p (numpft)) ; npool_to_deadcrootn_storage_p (:) = spval + allocate (npool_to_grainn_p (numpft)) ; npool_to_grainn_p (:) = spval + allocate (npool_to_grainn_storage_p (numpft)) ; npool_to_grainn_storage_p (:) = spval + + allocate (respcsun_p (numpft)) ; respcsun_p (:) = spval + allocate (respcsha_p (numpft)) ; respcsha_p (:) = spval + allocate (leaf_mr_p (numpft)) ; leaf_mr_p (:) = spval + allocate (froot_mr_p (numpft)) ; froot_mr_p (:) = spval + allocate (livestem_mr_p (numpft)) ; livestem_mr_p (:) = spval + allocate (livecroot_mr_p (numpft)) ; livecroot_mr_p (:) = spval + allocate (grain_mr_p (numpft)) ; grain_mr_p (:) = spval + + allocate (soil_change_p (numpft)) ; soil_change_p (:) = spval + + allocate (psn_to_cpool_p (numpft)) ; psn_to_cpool_p (:) = spval + allocate (gpp_p (numpft)) ; gpp_p (:) = spval + allocate (availc_p (numpft)) ; availc_p (:) = spval + allocate (avail_retransn_p (numpft)) ; avail_retransn_p (:) = spval + allocate (xsmrpool_recover_p (numpft)) ; xsmrpool_recover_p (:) = spval + allocate (excess_cflux_p (numpft)) ; excess_cflux_p (:) = spval + allocate (sminn_to_npool_p (numpft)) ; sminn_to_npool_p (:) = spval + + allocate (plant_calloc_p (numpft)) ; plant_calloc_p (:) = spval + allocate (plant_nalloc_p (numpft)) ; plant_nalloc_p (:) = spval + allocate (leaf_curmr_p (numpft)) ; leaf_curmr_p (:) = spval + allocate (froot_curmr_p (numpft)) ; froot_curmr_p (:) = spval + allocate (livestem_curmr_p (numpft)) ; livestem_curmr_p (:) = spval + allocate (livecroot_curmr_p (numpft)) ; livecroot_curmr_p (:) = spval + allocate (grain_curmr_p (numpft)) ; grain_curmr_p (:) = spval + + allocate (fire_closs_p (numpft)) ; fire_closs_p (:) = spval + allocate (fire_nloss_p (numpft)) ; fire_nloss_p (:) = spval + allocate (wood_harvestc_p (numpft)) ; wood_harvestc_p (:) = spval + allocate (wood_harvestn_p (numpft)) ; wood_harvestn_p (:) = spval + allocate (grainc_to_cropprodc_p (numpft)) ; grainc_to_cropprodc_p (:) = spval + allocate (grainn_to_cropprodn_p (numpft)) ; grainn_to_cropprodn_p (:) = spval + allocate (hrv_xsmrpool_to_atm_p (numpft)) ; hrv_xsmrpool_to_atm_p (:) = spval + allocate (soyfixn_p (numpft)) ; soyfixn_p (:) = spval + + ENDIF + ENDIF + +!-------- + + END SUBROUTINE allocate_1D_BGCPFTFluxes + + SUBROUTINE deallocate_1D_BGCPFTFluxes + ! -------------------------------------------------------------------- + ! deallocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_LandPFT + + IF (.true.) THEN + IF (numpft > 0) THEN + +! bgc variables + deallocate (leafc_xfer_to_leafc_p ) + deallocate (frootc_xfer_to_frootc_p ) + deallocate (livestemc_xfer_to_livestemc_p ) + deallocate (deadstemc_xfer_to_deadstemc_p ) + deallocate (livecrootc_xfer_to_livecrootc_p ) + deallocate (deadcrootc_xfer_to_deadcrootc_p ) + deallocate (grainc_xfer_to_grainc_p ) + + deallocate (leafc_storage_to_xfer_p ) + deallocate (frootc_storage_to_xfer_p ) + deallocate (livestemc_storage_to_xfer_p ) + deallocate (deadstemc_storage_to_xfer_p ) + deallocate (livecrootc_storage_to_xfer_p ) + deallocate (deadcrootc_storage_to_xfer_p ) + deallocate (grainc_storage_to_xfer_p ) + deallocate (gresp_storage_to_xfer_p ) + + deallocate (leafc_to_litter_p ) + deallocate (frootc_to_litter_p ) + deallocate (grainc_to_food_p ) + deallocate (grainc_to_seed_p ) + deallocate (crop_seedc_to_leaf_p ) + deallocate (livestemc_to_litter_p ) + deallocate (livestemc_to_deadstemc_p ) + deallocate (livecrootc_to_deadcrootc_p ) + + deallocate (m_leafc_to_litter_p ) + deallocate (m_frootc_to_litter_p ) + deallocate (m_livestemc_to_litter_p ) + deallocate (m_deadstemc_to_litter_p ) + deallocate (m_livecrootc_to_litter_p ) + deallocate (m_deadcrootc_to_litter_p ) + + deallocate (m_leafc_storage_to_litter_p ) + deallocate (m_frootc_storage_to_litter_p ) + deallocate (m_livestemc_storage_to_litter_p ) + deallocate (m_deadstemc_storage_to_litter_p ) + deallocate (m_livecrootc_storage_to_litter_p ) + deallocate (m_deadcrootc_storage_to_litter_p ) + deallocate (m_gresp_storage_to_litter_p ) + + deallocate (m_leafc_xfer_to_litter_p ) + deallocate (m_frootc_xfer_to_litter_p ) + deallocate (m_livestemc_xfer_to_litter_p ) + deallocate (m_deadstemc_xfer_to_litter_p ) + deallocate (m_livecrootc_xfer_to_litter_p ) + deallocate (m_deadcrootc_xfer_to_litter_p ) + deallocate (m_gresp_xfer_to_litter_p ) + + deallocate (m_leafc_to_fire_p ) + deallocate (m_frootc_to_fire_p ) + deallocate (m_livestemc_to_fire_p ) + deallocate (m_deadstemc_to_fire_p ) + deallocate (m_livecrootc_to_fire_p ) + deallocate (m_deadcrootc_to_fire_p ) + + deallocate (m_leafc_storage_to_fire_p ) + deallocate (m_frootc_storage_to_fire_p ) + deallocate (m_livestemc_storage_to_fire_p ) + deallocate (m_deadstemc_storage_to_fire_p ) + deallocate (m_livecrootc_storage_to_fire_p ) + deallocate (m_deadcrootc_storage_to_fire_p ) + deallocate (m_gresp_storage_to_fire_p ) + + deallocate (m_leafc_xfer_to_fire_p ) + deallocate (m_frootc_xfer_to_fire_p ) + deallocate (m_livestemc_xfer_to_fire_p ) + deallocate (m_deadstemc_xfer_to_fire_p ) + deallocate (m_livecrootc_xfer_to_fire_p ) + deallocate (m_deadcrootc_xfer_to_fire_p ) + deallocate (m_gresp_xfer_to_fire_p ) + + deallocate (m_livestemc_to_deadstemc_fire_p ) + deallocate (m_livecrootc_to_deadcrootc_fire_p ) + + deallocate (m_leafc_to_litter_fire_p ) + deallocate (m_frootc_to_litter_fire_p ) + deallocate (m_livestemc_to_litter_fire_p ) + deallocate (m_deadstemc_to_litter_fire_p ) + deallocate (m_livecrootc_to_litter_fire_p ) + deallocate (m_deadcrootc_to_litter_fire_p ) + + deallocate (m_leafc_storage_to_litter_fire_p ) + deallocate (m_frootc_storage_to_litter_fire_p ) + deallocate (m_livestemc_storage_to_litter_fire_p ) + deallocate (m_deadstemc_storage_to_litter_fire_p ) + deallocate (m_livecrootc_storage_to_litter_fire_p) + deallocate (m_deadcrootc_storage_to_litter_fire_p) + deallocate (m_gresp_storage_to_litter_fire_p ) + + deallocate (m_leafc_xfer_to_litter_fire_p ) + deallocate (m_frootc_xfer_to_litter_fire_p ) + deallocate (m_livestemc_xfer_to_litter_fire_p ) + deallocate (m_deadstemc_xfer_to_litter_fire_p ) + deallocate (m_livecrootc_xfer_to_litter_fire_p ) + deallocate (m_deadcrootc_xfer_to_litter_fire_p ) + deallocate (m_gresp_xfer_to_litter_fire_p ) + + deallocate (cpool_to_xsmrpool_p ) + deallocate (cpool_to_gresp_storage_p ) + deallocate (cpool_to_leafc_p ) + deallocate (cpool_to_leafc_storage_p ) + deallocate (cpool_to_frootc_p ) + deallocate (cpool_to_frootc_storage_p ) + deallocate (cpool_to_livestemc_p ) + deallocate (cpool_to_livestemc_storage_p ) + deallocate (cpool_to_deadstemc_p ) + deallocate (cpool_to_deadstemc_storage_p ) + deallocate (cpool_to_livecrootc_p ) + deallocate (cpool_to_livecrootc_storage_p) + deallocate (cpool_to_deadcrootc_p ) + deallocate (cpool_to_deadcrootc_storage_p) + deallocate (cpool_to_grainc_p ) + deallocate (cpool_to_grainc_storage_p ) + + deallocate (leaf_xsmr_p ) + deallocate (froot_xsmr_p ) + deallocate (livestem_xsmr_p ) + deallocate (livecroot_xsmr_p ) + deallocate (grain_xsmr_p ) + + deallocate (cpool_leaf_gr_p ) + deallocate (cpool_froot_gr_p ) + deallocate (cpool_livestem_gr_p ) + deallocate (cpool_deadstem_gr_p ) + deallocate (cpool_livecroot_gr_p ) + deallocate (cpool_deadcroot_gr_p ) + deallocate (cpool_grain_gr_p ) + + deallocate (cpool_leaf_storage_gr_p ) + deallocate (cpool_froot_storage_gr_p ) + deallocate (cpool_livestem_storage_gr_p ) + deallocate (cpool_deadstem_storage_gr_p ) + deallocate (cpool_livecroot_storage_gr_p ) + deallocate (cpool_deadcroot_storage_gr_p ) + deallocate (cpool_grain_storage_gr_p ) + + deallocate (transfer_leaf_gr_p ) + deallocate (transfer_froot_gr_p ) + deallocate (transfer_livestem_gr_p ) + deallocate (transfer_deadstem_gr_p ) + deallocate (transfer_livecroot_gr_p ) + deallocate (transfer_deadcroot_gr_p ) + deallocate (transfer_grain_gr_p ) + + deallocate (xsmrpool_to_atm_p ) + + deallocate (cropprod1c_loss_p ) + + deallocate (plant_ndemand_p ) + + deallocate (leafn_xfer_to_leafn_p ) + deallocate (frootn_xfer_to_frootn_p ) + deallocate (livestemn_xfer_to_livestemn_p ) + deallocate (deadstemn_xfer_to_deadstemn_p ) + deallocate (livecrootn_xfer_to_livecrootn_p ) + deallocate (deadcrootn_xfer_to_deadcrootn_p ) + deallocate (grainn_xfer_to_grainn_p ) + + deallocate (leafn_storage_to_xfer_p ) + deallocate (frootn_storage_to_xfer_p ) + deallocate (livestemn_storage_to_xfer_p ) + deallocate (deadstemn_storage_to_xfer_p ) + deallocate (livecrootn_storage_to_xfer_p ) + deallocate (deadcrootn_storage_to_xfer_p ) + deallocate (grainn_storage_to_xfer_p ) + + deallocate (leafn_to_litter_p ) + deallocate (frootn_to_litter_p ) + deallocate (grainn_to_food_p ) + deallocate (grainn_to_seed_p ) + deallocate (crop_seedn_to_leaf_p ) + deallocate (livestemn_to_litter_p ) + deallocate (livestemn_to_deadstemn_p ) + deallocate (livecrootn_to_deadcrootn_p ) + + deallocate (leafn_to_retransn_p ) + deallocate (frootn_to_retransn_p ) + deallocate (livestemn_to_retransn_p ) + deallocate (livecrootn_to_retransn_p ) + deallocate (retransn_to_npool_p ) + deallocate (free_retransn_to_npool_p ) + + deallocate (m_leafn_to_litter_p ) + deallocate (m_frootn_to_litter_p ) + deallocate (m_livestemn_to_litter_p ) + deallocate (m_deadstemn_to_litter_p ) + deallocate (m_livecrootn_to_litter_p ) + deallocate (m_deadcrootn_to_litter_p ) + deallocate (m_retransn_to_litter_p ) + + deallocate (m_leafn_storage_to_litter_p ) + deallocate (m_frootn_storage_to_litter_p ) + deallocate (m_livestemn_storage_to_litter_p ) + deallocate (m_deadstemn_storage_to_litter_p ) + deallocate (m_livecrootn_storage_to_litter_p ) + deallocate (m_deadcrootn_storage_to_litter_p ) + + deallocate (m_leafn_xfer_to_litter_p ) + deallocate (m_frootn_xfer_to_litter_p ) + deallocate (m_livestemn_xfer_to_litter_p ) + deallocate (m_deadstemn_xfer_to_litter_p ) + deallocate (m_livecrootn_xfer_to_litter_p ) + deallocate (m_deadcrootn_xfer_to_litter_p ) + + deallocate (m_leafn_to_fire_p ) + deallocate (m_frootn_to_fire_p ) + deallocate (m_livestemn_to_fire_p ) + deallocate (m_deadstemn_to_fire_p ) + deallocate (m_livecrootn_to_fire_p ) + deallocate (m_deadcrootn_to_fire_p ) + + deallocate (m_leafn_storage_to_fire_p ) + deallocate (m_frootn_storage_to_fire_p ) + deallocate (m_livestemn_storage_to_fire_p ) + deallocate (m_deadstemn_storage_to_fire_p ) + deallocate (m_livecrootn_storage_to_fire_p ) + deallocate (m_deadcrootn_storage_to_fire_p ) + + deallocate (m_leafn_xfer_to_fire_p ) + deallocate (m_frootn_xfer_to_fire_p ) + deallocate (m_livestemn_xfer_to_fire_p ) + deallocate (m_deadstemn_xfer_to_fire_p ) + deallocate (m_livecrootn_xfer_to_fire_p ) + deallocate (m_deadcrootn_xfer_to_fire_p ) + + deallocate (m_livestemn_to_deadstemn_fire_p ) + deallocate (m_livecrootn_to_deadcrootn_fire_p ) + + deallocate (m_retransn_to_fire_p ) + + deallocate (m_leafn_to_litter_fire_p ) + deallocate (m_frootn_to_litter_fire_p ) + deallocate (m_livestemn_to_litter_fire_p ) + deallocate (m_deadstemn_to_litter_fire_p ) + deallocate (m_livecrootn_to_litter_fire_p ) + deallocate (m_deadcrootn_to_litter_fire_p ) + + deallocate (m_leafn_storage_to_litter_fire_p ) + deallocate (m_frootn_storage_to_litter_fire_p ) + deallocate (m_livestemn_storage_to_litter_fire_p ) + deallocate (m_deadstemn_storage_to_litter_fire_p ) + deallocate (m_livecrootn_storage_to_litter_fire_p) + deallocate (m_deadcrootn_storage_to_litter_fire_p) + + deallocate (m_leafn_xfer_to_litter_fire_p ) + deallocate (m_frootn_xfer_to_litter_fire_p ) + deallocate (m_livestemn_xfer_to_litter_fire_p ) + deallocate (m_deadstemn_xfer_to_litter_fire_p ) + deallocate (m_livecrootn_xfer_to_litter_fire_p ) + deallocate (m_deadcrootn_xfer_to_litter_fire_p ) + + deallocate (m_retransn_to_litter_fire_p ) + + deallocate (npool_to_leafn_p ) + deallocate (npool_to_leafn_storage_p ) + deallocate (npool_to_frootn_p ) + deallocate (npool_to_frootn_storage_p ) + deallocate (npool_to_livestemn_p ) + deallocate (npool_to_livestemn_storage_p ) + deallocate (npool_to_deadstemn_p ) + deallocate (npool_to_deadstemn_storage_p ) + deallocate (npool_to_livecrootn_p ) + deallocate (npool_to_livecrootn_storage_p ) + deallocate (npool_to_deadcrootn_p ) + deallocate (npool_to_deadcrootn_storage_p ) + deallocate (npool_to_grainn_p ) + deallocate (npool_to_grainn_storage_p ) + + deallocate (respcsun_p ) + deallocate (respcsha_p ) + deallocate (leaf_mr_p ) + deallocate (froot_mr_p ) + deallocate (livestem_mr_p ) + deallocate (livecroot_mr_p ) + deallocate (grain_mr_p ) + + deallocate (soil_change_p ) + + deallocate (psn_to_cpool_p ) + deallocate (gpp_p ) + deallocate (availc_p ) + deallocate (avail_retransn_p ) + deallocate (xsmrpool_recover_p ) + deallocate (excess_cflux_p ) + deallocate (sminn_to_npool_p ) + + deallocate (plant_calloc_p ) + deallocate (plant_nalloc_p ) + deallocate (leaf_curmr_p ) + deallocate (froot_curmr_p ) + deallocate (livestem_curmr_p ) + deallocate (livecroot_curmr_p ) + deallocate (grain_curmr_p ) + + deallocate (fire_closs_p ) + deallocate (fire_nloss_p ) + deallocate (wood_harvestc_p ) + deallocate (wood_harvestn_p ) + deallocate (grainc_to_cropprodc_p ) + deallocate (grainn_to_cropprodn_p ) + deallocate (hrv_xsmrpool_to_atm_p ) + deallocate (soyfixn_p ) + + ENDIF + ENDIF + + + END SUBROUTINE deallocate_1D_BGCPFTFluxes + + SUBROUTINE set_1D_BGCPFTFluxes(Values, Nan) + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandPFT + IMPLICIT NONE + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan + + IF (.true.) THEN + IF (numpft > 0) THEN + + ! bgc variables + leafc_xfer_to_leafc_p (:) = Values + frootc_xfer_to_frootc_p (:) = Values + livestemc_xfer_to_livestemc_p (:) = Values + deadstemc_xfer_to_deadstemc_p (:) = Values + livecrootc_xfer_to_livecrootc_p (:) = Values + deadcrootc_xfer_to_deadcrootc_p (:) = Values + grainc_xfer_to_grainc_p (:) = Values + + leafc_storage_to_xfer_p (:) = Values + frootc_storage_to_xfer_p (:) = Values + livestemc_storage_to_xfer_p (:) = Values + deadstemc_storage_to_xfer_p (:) = Values + livecrootc_storage_to_xfer_p (:) = Values + deadcrootc_storage_to_xfer_p (:) = Values + grainc_storage_to_xfer_p (:) = Values + gresp_storage_to_xfer_p (:) = Values + + leafc_to_litter_p (:) = Values + frootc_to_litter_p (:) = Values + grainc_to_food_p (:) = Values + grainc_to_seed_p (:) = Values + crop_seedc_to_leaf_p (:) = Values + livestemc_to_litter_p (:) = Values + livestemc_to_deadstemc_p (:) = Values + livecrootc_to_deadcrootc_p (:) = Values + + m_leafc_to_litter_p (:) = Values + m_frootc_to_litter_p (:) = Values + m_livestemc_to_litter_p (:) = Values + m_deadstemc_to_litter_p (:) = Values + m_livecrootc_to_litter_p (:) = Values + m_deadcrootc_to_litter_p (:) = Values + + m_leafc_storage_to_litter_p (:) = Values + m_frootc_storage_to_litter_p (:) = Values + m_livestemc_storage_to_litter_p (:) = Values + m_deadstemc_storage_to_litter_p (:) = Values + m_livecrootc_storage_to_litter_p (:) = Values + m_deadcrootc_storage_to_litter_p (:) = Values + m_gresp_storage_to_litter_p (:) = Values + + m_leafc_xfer_to_litter_p (:) = Values + m_frootc_xfer_to_litter_p (:) = Values + m_livestemc_xfer_to_litter_p (:) = Values + m_deadstemc_xfer_to_litter_p (:) = Values + m_livecrootc_xfer_to_litter_p (:) = Values + m_deadcrootc_xfer_to_litter_p (:) = Values + m_gresp_xfer_to_litter_p (:) = Values + + m_leafc_to_fire_p (:) = Values + m_frootc_to_fire_p (:) = Values + m_livestemc_to_fire_p (:) = Values + m_deadstemc_to_fire_p (:) = Values + m_livecrootc_to_fire_p (:) = Values + m_deadcrootc_to_fire_p (:) = Values + + m_leafc_storage_to_fire_p (:) = Values + m_frootc_storage_to_fire_p (:) = Values + m_livestemc_storage_to_fire_p (:) = Values + m_deadstemc_storage_to_fire_p (:) = Values + m_livecrootc_storage_to_fire_p (:) = Values + m_deadcrootc_storage_to_fire_p (:) = Values + m_gresp_storage_to_fire_p (:) = Values + + m_leafc_xfer_to_fire_p (:) = Values + m_frootc_xfer_to_fire_p (:) = Values + m_livestemc_xfer_to_fire_p (:) = Values + m_deadstemc_xfer_to_fire_p (:) = Values + m_livecrootc_xfer_to_fire_p (:) = Values + m_deadcrootc_xfer_to_fire_p (:) = Values + m_gresp_xfer_to_fire_p (:) = Values + + m_livestemc_to_deadstemc_fire_p (:) = Values + m_livecrootc_to_deadcrootc_fire_p (:) = Values + + m_leafc_to_litter_fire_p (:) = Values + m_frootc_to_litter_fire_p (:) = Values + m_livestemc_to_litter_fire_p (:) = Values + m_deadstemc_to_litter_fire_p (:) = Values + m_livecrootc_to_litter_fire_p (:) = Values + m_deadcrootc_to_litter_fire_p (:) = Values + + m_leafc_storage_to_litter_fire_p (:) = Values + m_frootc_storage_to_litter_fire_p (:) = Values + m_livestemc_storage_to_litter_fire_p (:) = Values + m_deadstemc_storage_to_litter_fire_p (:) = Values + m_livecrootc_storage_to_litter_fire_p(:) = Values + m_deadcrootc_storage_to_litter_fire_p(:) = Values + m_gresp_storage_to_litter_fire_p (:) = Values + + m_leafc_xfer_to_litter_fire_p (:) = Values + m_frootc_xfer_to_litter_fire_p (:) = Values + m_livestemc_xfer_to_litter_fire_p (:) = Values + m_deadstemc_xfer_to_litter_fire_p (:) = Values + m_livecrootc_xfer_to_litter_fire_p (:) = Values + m_deadcrootc_xfer_to_litter_fire_p (:) = Values + m_gresp_xfer_to_litter_fire_p (:) = Values + + cpool_to_xsmrpool_p (:) = Values + cpool_to_gresp_storage_p (:) = Values + cpool_to_leafc_p (:) = Values + cpool_to_leafc_storage_p (:) = Values + cpool_to_frootc_p (:) = Values + cpool_to_frootc_storage_p (:) = Values + cpool_to_livestemc_p (:) = Values + cpool_to_livestemc_storage_p (:) = Values + cpool_to_deadstemc_p (:) = Values + cpool_to_deadstemc_storage_p (:) = Values + cpool_to_livecrootc_p (:) = Values + cpool_to_livecrootc_storage_p (:) = Values + cpool_to_deadcrootc_p (:) = Values + cpool_to_deadcrootc_storage_p (:) = Values + cpool_to_grainc_p (:) = Values + cpool_to_grainc_storage_p (:) = Values + + leaf_xsmr_p (:) = Values + froot_xsmr_p (:) = Values + livestem_xsmr_p (:) = Values + livecroot_xsmr_p (:) = Values + grain_xsmr_p (:) = Values + + cpool_leaf_gr_p (:) = Values + cpool_froot_gr_p (:) = Values + cpool_livestem_gr_p (:) = Values + cpool_deadstem_gr_p (:) = Values + cpool_livecroot_gr_p (:) = Values + cpool_deadcroot_gr_p (:) = Values + cpool_grain_gr_p (:) = Values + + cpool_leaf_storage_gr_p (:) = Values + cpool_froot_storage_gr_p (:) = Values + cpool_livestem_storage_gr_p (:) = Values + cpool_deadstem_storage_gr_p (:) = Values + cpool_livecroot_storage_gr_p (:) = Values + cpool_deadcroot_storage_gr_p (:) = Values + cpool_grain_storage_gr_p (:) = Values + + transfer_leaf_gr_p (:) = Values + transfer_froot_gr_p (:) = Values + transfer_livestem_gr_p (:) = Values + transfer_deadstem_gr_p (:) = Values + transfer_livecroot_gr_p (:) = Values + transfer_deadcroot_gr_p (:) = Values + transfer_grain_gr_p (:) = Values + + xsmrpool_to_atm_p (:) = Values + + cropprod1c_loss_p (:) = Values + + plant_ndemand_p (:) = Values + + leafn_xfer_to_leafn_p (:) = Values + frootn_xfer_to_frootn_p (:) = Values + livestemn_xfer_to_livestemn_p (:) = Values + deadstemn_xfer_to_deadstemn_p (:) = Values + livecrootn_xfer_to_livecrootn_p (:) = Values + deadcrootn_xfer_to_deadcrootn_p (:) = Values + grainn_xfer_to_grainn_p (:) = Values + + leafn_storage_to_xfer_p (:) = Values + frootn_storage_to_xfer_p (:) = Values + livestemn_storage_to_xfer_p (:) = Values + deadstemn_storage_to_xfer_p (:) = Values + livecrootn_storage_to_xfer_p (:) = Values + deadcrootn_storage_to_xfer_p (:) = Values + grainn_storage_to_xfer_p (:) = Values + + leafn_to_litter_p (:) = Values + frootn_to_litter_p (:) = Values + grainn_to_food_p (:) = Values + grainn_to_seed_p (:) = Values + crop_seedn_to_leaf_p (:) = Values + livestemn_to_litter_p (:) = Values + livestemn_to_deadstemn_p (:) = Values + livecrootn_to_deadcrootn_p (:) = Values + + leafn_to_retransn_p (:) = Values + frootn_to_retransn_p (:) = Values + livestemn_to_retransn_p (:) = Values + livecrootn_to_retransn_p (:) = Values + retransn_to_npool_p (:) = Values + free_retransn_to_npool_p (:) = Values + + m_leafn_to_litter_p (:) = Values + m_frootn_to_litter_p (:) = Values + m_livestemn_to_litter_p (:) = Values + m_deadstemn_to_litter_p (:) = Values + m_livecrootn_to_litter_p (:) = Values + m_deadcrootn_to_litter_p (:) = Values + m_retransn_to_litter_p (:) = Values + + m_leafn_storage_to_litter_p (:) = Values + m_frootn_storage_to_litter_p (:) = Values + m_livestemn_storage_to_litter_p (:) = Values + m_deadstemn_storage_to_litter_p (:) = Values + m_livecrootn_storage_to_litter_p (:) = Values + m_deadcrootn_storage_to_litter_p (:) = Values + + m_leafn_xfer_to_litter_p (:) = Values + m_frootn_xfer_to_litter_p (:) = Values + m_livestemn_xfer_to_litter_p (:) = Values + m_deadstemn_xfer_to_litter_p (:) = Values + m_livecrootn_xfer_to_litter_p (:) = Values + m_deadcrootn_xfer_to_litter_p (:) = Values + + m_leafn_to_fire_p (:) = Values + m_frootn_to_fire_p (:) = Values + m_livestemn_to_fire_p (:) = Values + m_deadstemn_to_fire_p (:) = Values + m_livecrootn_to_fire_p (:) = Values + m_deadcrootn_to_fire_p (:) = Values + + m_leafn_storage_to_fire_p (:) = Values + m_frootn_storage_to_fire_p (:) = Values + m_livestemn_storage_to_fire_p (:) = Values + m_deadstemn_storage_to_fire_p (:) = Values + m_livecrootn_storage_to_fire_p (:) = Values + m_deadcrootn_storage_to_fire_p (:) = Values + + m_leafn_xfer_to_fire_p (:) = Values + m_frootn_xfer_to_fire_p (:) = Values + m_livestemn_xfer_to_fire_p (:) = Values + m_deadstemn_xfer_to_fire_p (:) = Values + m_livecrootn_xfer_to_fire_p (:) = Values + m_deadcrootn_xfer_to_fire_p (:) = Values + + m_livestemn_to_deadstemn_fire_p (:) = Values + m_livecrootn_to_deadcrootn_fire_p (:) = Values + + m_retransn_to_fire_p (:) = Values + + m_leafn_to_litter_fire_p (:) = Values + m_frootn_to_litter_fire_p (:) = Values + m_livestemn_to_litter_fire_p (:) = Values + m_deadstemn_to_litter_fire_p (:) = Values + m_livecrootn_to_litter_fire_p (:) = Values + m_deadcrootn_to_litter_fire_p (:) = Values + + m_leafn_storage_to_litter_fire_p (:) = Values + m_frootn_storage_to_litter_fire_p (:) = Values + m_livestemn_storage_to_litter_fire_p (:) = Values + m_deadstemn_storage_to_litter_fire_p (:) = Values + m_livecrootn_storage_to_litter_fire_p(:) = Values + m_deadcrootn_storage_to_litter_fire_p(:) = Values + + m_leafn_xfer_to_litter_fire_p (:) = Values + m_frootn_xfer_to_litter_fire_p (:) = Values + m_livestemn_xfer_to_litter_fire_p (:) = Values + m_deadstemn_xfer_to_litter_fire_p (:) = Values + m_livecrootn_xfer_to_litter_fire_p (:) = Values + m_deadcrootn_xfer_to_litter_fire_p (:) = Values + + m_retransn_to_litter_fire_p (:) = Values + + npool_to_leafn_p (:) = Values + npool_to_leafn_storage_p (:) = Values + npool_to_frootn_p (:) = Values + npool_to_frootn_storage_p (:) = Values + npool_to_livestemn_p (:) = Values + npool_to_livestemn_storage_p (:) = Values + npool_to_deadstemn_p (:) = Values + npool_to_deadstemn_storage_p (:) = Values + npool_to_livecrootn_p (:) = Values + npool_to_livecrootn_storage_p (:) = Values + npool_to_deadcrootn_p (:) = Values + npool_to_deadcrootn_storage_p (:) = Values + npool_to_grainn_p (:) = Values + npool_to_grainn_storage_p (:) = Values + + respcsun_p (:) = Values!sunlit leaf respiration + respcsha_p (:) = Values!shaded leaf respiration + leaf_mr_p (:) = Values!leaf maintenance respiration + froot_mr_p (:) = Values!fine root maintenance respiration + livestem_mr_p (:) = Values!live stem maintenance respiration + livecroot_mr_p (:) = Values!live coarse root maintenance respiration + grain_mr_p (:) = Values!grain maintenance respiration + + soil_change_p (:) = Values + + psn_to_cpool_p (:) = Values + gpp_p (:) = Values + availc_p (:) = Values + avail_retransn_p (:) = Values + xsmrpool_recover_p (:) = Values + excess_cflux_p (:) = Values + sminn_to_npool_p (:) = Values + + plant_calloc_p (:) = Values + plant_nalloc_p (:) = Values + leaf_curmr_p (:) = Values + froot_curmr_p (:) = Values + livestem_curmr_p (:) = Values + livecroot_curmr_p (:) = Values + grain_curmr_p (:) = Values + + fire_closs_p (:) = Values + fire_nloss_p (:) = Values + wood_harvestc_p (:) = Values + wood_harvestn_p (:) = Values + grainc_to_cropprodc_p (:) = Values + grainn_to_cropprodn_p (:) = Values + hrv_xsmrpool_to_atm_p (:) = Values + soyfixn_p (:) = Values + + ENDIF + ENDIF + +!-------- + + END SUBROUTINE set_1D_BGCPFTFluxes +#endif + +END MODULE MOD_BGC_Vars_1DPFTFluxes + +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 new file mode 100644 index 0000000000..5cfb5c7ee4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_PFTimeVariables.F90 @@ -0,0 +1,2696 @@ +#include + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +MODULE MOD_BGC_Vars_PFTimeVariables + +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical state variables at pft level. +! Read and write biogeochemical state variables at pft level from/to restart files. + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version + +#ifdef BGC + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_TimeManager + + IMPLICIT NONE + SAVE +! ----------------------------------------------------------------- +! Time-varying state variables which required by restart run +!--------------------- bgc variables --------------------------------------- + real(r8), allocatable :: leafc_p (:) ! leaf display C (gC m-2) + real(r8), allocatable :: leafc_storage_p (:) ! leaf storage C (gC m-2) + real(r8), allocatable :: leafc_xfer_p (:) ! leaf transfer C (gC m-2) + real(r8), allocatable :: frootc_p (:) ! fine root display C (gC m-2) + real(r8), allocatable :: frootc_storage_p (:) ! fine root storage C (gC m-2) + real(r8), allocatable :: frootc_xfer_p (:) ! fine root transfer C (gC m-2) + real(r8), allocatable :: livestemc_p (:) ! live stem display C (gC m-2) + real(r8), allocatable :: livestemc_storage_p (:) ! live stem storage C (gC m-2) + real(r8), allocatable :: livestemc_xfer_p (:) ! live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemc_p (:) ! dead stem display C (gC m-2) + real(r8), allocatable :: deadstemc_storage_p (:) ! dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemc_xfer_p (:) ! dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootc_p (:) ! live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootc_storage_p (:) ! live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootc_xfer_p (:) ! live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootc_p (:) ! dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootc_storage_p (:) ! dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootc_xfer_p (:) ! dead coarse root transfer C (gC m-2) + real(r8), allocatable :: grainc_p (:) ! grain display C (gC m-2) + real(r8), allocatable :: grainc_storage_p (:) ! grain storage C (gC m-2) + real(r8), allocatable :: grainc_xfer_p (:) ! grain transfer C (gC m-2) + real(r8), allocatable :: cropseedc_deficit_p (:) ! crop seed deficit C (gC m-2) + real(r8), allocatable :: cropprod1c_p (:) ! product C (gC m-2) + real(r8), allocatable :: xsmrpool_p (:) ! maintenance respiration storage C (gC m-2) + real(r8), allocatable :: gresp_storage_p (:) ! growth respiration storage C (gC m-2) + real(r8), allocatable :: gresp_xfer_p (:) ! growth respiration transfer C (gC m-2) + real(r8), allocatable :: cpool_p (:) ! available C (gC m-2) + real(r8), allocatable :: totvegc_p (:) ! total vegetation C, including available C (gC m-2) + + real(r8), allocatable :: leaf_prof_p (:,:) ! vertical profile of leaves input to litter (m-1) + real(r8), allocatable :: stem_prof_p (:,:) ! vertical profile of stem input to litter (m-1) + real(r8), allocatable :: froot_prof_p (:,:) ! vertical profile of fine roots input to litter (m-1) + real(r8), allocatable :: croot_prof_p (:,:) ! vertical profile of coarse roots input to litter (m-1) + real(r8), allocatable :: cinput_rootfr_p (:,:) ! root fraction used for calculating vertical profile of roots input to litter (m-1) + + real(r8), allocatable :: leafn_p (:) ! leaf display N (gN m-2) + real(r8), allocatable :: leafn_storage_p (:) ! leaf storage N (gN m-2) + real(r8), allocatable :: leafn_xfer_p (:) ! leaf transfer N (gN m-2) + real(r8), allocatable :: frootn_p (:) ! fine root display N (gN m-2) + real(r8), allocatable :: frootn_storage_p (:) ! fine root storage N (gN m-2) + real(r8), allocatable :: frootn_xfer_p (:) ! fine root transfer N (gN m-2) + real(r8), allocatable :: livestemn_p (:) ! live stem display N (gN m-2) + real(r8), allocatable :: livestemn_storage_p (:) ! live stem storage N (gN m-2) + real(r8), allocatable :: livestemn_xfer_p (:) ! live stem transfer N (gN m-2) + real(r8), allocatable :: deadstemn_p (:) ! dead stem display N (gN m-2) + real(r8), allocatable :: deadstemn_storage_p (:) ! dead stem storage N (gN m-2) + real(r8), allocatable :: deadstemn_xfer_p (:) ! dead stem transfer N (gN m-2) + real(r8), allocatable :: livecrootn_p (:) ! live coarse root display N (gN m-2) + real(r8), allocatable :: livecrootn_storage_p (:) ! live coarse root storage N (gN m-2) + real(r8), allocatable :: livecrootn_xfer_p (:) ! live coarse root transfer N (gN m-2) + real(r8), allocatable :: deadcrootn_p (:) ! dead coarse root display N (gN m-2) + real(r8), allocatable :: deadcrootn_storage_p (:) ! dead coarse root storage N (gN m-2) + real(r8), allocatable :: deadcrootn_xfer_p (:) ! dead coarse root transfer N (gN m-2) + real(r8), allocatable :: grainn_p (:) ! grain display N (gN m-2) + real(r8), allocatable :: grainn_storage_p (:) ! grain storage N (gN m-2) + real(r8), allocatable :: grainn_xfer_p (:) ! grain transfer N (gN m-2) + real(r8), allocatable :: cropseedn_deficit_p (:) ! crop seed deficit N (gN m-2) + real(r8), allocatable :: harvdate_p (:) ! harvest date + integer , allocatable :: nyrs_crop_active_p (:) ! number of years of this crop has been active to calculate climate GDD + real(r8), allocatable :: retransn_p (:) ! retranslocated N (gN m-2) + real(r8), allocatable :: totvegn_p (:) ! total vegetation N, including available N (gN m-2) + + real(r8), allocatable :: tempsum_potential_gpp_p (:) ! temporary annual sum of potential GPP (gC m-2) + real(r8), allocatable :: tempmax_retransn_p (:) ! temporary annual max of retranslocated N (gN m-2) + real(r8), allocatable :: tempavg_tref_p (:) ! temporary annual average 2m air temperature (degree C) + real(r8), allocatable :: tempsum_npp_p (:) ! temporary annual sum NPP (gC m-2) + real(r8), allocatable :: tempsum_litfall_p (:) ! temporary annual sum litterfall (gC m-2) + real(r8), allocatable :: annsum_potential_gpp_p (:) ! annual sum of potential GPP (gC m-2) + real(r8), allocatable :: annmax_retransn_p (:) ! annual max of retranslocated N (gN m-2) + real(r8), allocatable :: annavg_tref_p (:) ! annual average 2m air temperature (degree C) + real(r8), allocatable :: annsum_npp_p (:) ! annual sum NPP (gC m-2) + real(r8), allocatable :: annsum_litfall_p (:) ! annual sum litterfall (gC m-2) + + real(r8), allocatable :: bglfr_p (:) ! background litterfall rate (1/s) + real(r8), allocatable :: bgtr_p (:) ! background transfer rate (1/s) + real(r8), allocatable :: lgsf_p (:) ! long growing season factor (0-1) + real(r8), allocatable :: gdd0_p (:) ! GDD based on 0 degree C + real(r8), allocatable :: gdd8_p (:) ! GDD based on 8 degree C + real(r8), allocatable :: gdd10_p (:) ! GDD based on 10 degree C + real(r8), allocatable :: gdd020_p (:) ! 20-year mean of GDD based on 0 degree C + real(r8), allocatable :: gdd820_p (:) ! 20-year mean of GDD based on 8 degree C + real(r8), allocatable :: gdd1020_p (:) ! 20-year mean of GDD based on 10 degree C + + real(r8), allocatable :: offset_flag_p (:) ! flag, 1 if offset + real(r8), allocatable :: offset_counter_p (:) ! time left for offset (s) + real(r8), allocatable :: onset_flag_p (:) ! flag, 1 if onset + real(r8), allocatable :: onset_counter_p (:) ! time left for onset (s) + real(r8), allocatable :: onset_gddflag_p (:) ! flag, 1 if begin to accumulate GDD for onset + real(r8), allocatable :: onset_gdd_p (:) ! onset GDD + real(r8), allocatable :: onset_fdd_p (:) ! onset freezing degree days counter + real(r8), allocatable :: onset_swi_p (:) ! onset soil water index + real(r8), allocatable :: offset_fdd_p (:) ! offset freezing degree days counter + real(r8), allocatable :: offset_swi_p (:) ! offset soil water index + real(r8), allocatable :: dormant_flag_p (:) ! flag, 1 if dormancy, 0 if not + real(r8), allocatable :: prev_leafc_to_litter_p (:) ! previous timestep leaf display C to litter C (gN m-2 s-1) + real(r8), allocatable :: prev_frootc_to_litter_p (:) ! previous timestep fine root display C to litter C (gN m-2 s-1) + real(r8), allocatable :: days_active_p (:) ! phenology-associated state: number of days since last dormancy + + real(r8), allocatable :: burndate_p (:) ! burn date for crop + + real(r8), allocatable :: c_allometry_p (:) ! C allocation index + real(r8), allocatable :: n_allometry_p (:) ! N allocation index + real(r8), allocatable :: downreg_p (:) ! fractional reduction in GPP due to N limitation + real(r8), allocatable :: grain_flag_p (:) ! flag, 1 if grain fill, 0 if not + + real(r8), allocatable :: ctrunc_p (:) ! additional carbon from precision control, currently not used + real(r8), allocatable :: ntrunc_p (:) ! additional nitrogen from precision control, currently not used + real(r8), allocatable :: npool_p (:) ! available N (gN m-2) + +!--------------------- CROP variables for GPAM------------------------------ +#ifdef CROP + logical, allocatable :: croplive_p (:) ! flag, true if crop live, not harvested + real(r8),allocatable :: hui_p (:) ! heat unit index since planting + real(r8),allocatable :: gddplant_p (:) ! GDD since planting + integer ,allocatable :: peaklai_p (:) ! flag, 1 if lai at maximum allowed, 0 if lai not at maximum allowed + real(r8),allocatable :: aroot_p (:) ! root allocation coefficient + real(r8),allocatable :: astem_p (:) ! stem allocation coefficient + real(r8),allocatable :: arepr_p (:) ! reproduction (fruit) allocation coefficient + real(r8),allocatable :: aleaf_p (:) ! leaf allocation coefficient + real(r8),allocatable :: astemi_p (:) ! stem allocation coefficient of phase 2 + real(r8),allocatable :: aleafi_p (:) ! leaf allocation coefficient of phase 2 + real(r8),allocatable :: gddmaturity_p (:) ! gdd needed to harvest + + logical, allocatable :: cropplant_p (:) ! flag, true if crop planted, not harvested; but if winter cereal still live at begin of the year, it will be set false + integer ,allocatable :: idop_p (:) ! planting date + real(r8),allocatable :: a5tmin_p (:) ! 5-day running mean of min 2 m temperature (degree C) + real(r8),allocatable :: a10tmin_p (:) ! 10-day running mean of min 2 m temperature (degree C) + real(r8),allocatable :: t10_p (:) ! 10-day running mean of 2 m temperature (degree C) + real(r8),allocatable :: cumvd_p (:) ! effective vernalization days (d) + real(r8),allocatable :: vf_p (:) ! vernalization factor (0-1) + real(r8),allocatable :: cphase_p (:) ! phenology phase + real(r8),allocatable :: fert_counter_p (:) ! time left to fertilize (s) + real(r8),allocatable :: tref_min_p (:) ! daily min of average 2-m temperature (degree C) + real(r8),allocatable :: tref_max_p (:) ! daily max of average 2-m temperature (degree C) + real(r8),allocatable :: tref_min_inst_p (:) ! temporary daily min of average 2-m temperature (degree C) + real(r8),allocatable :: tref_max_inst_p (:) ! temporary daily max of average 2-m temperature (degree C) + real(r8),allocatable :: fertnitro_p (:) ! fertilizer nitrogen (gN m-2) + real(r8),allocatable :: manunitro_p (:) ! manure nitrogen (gN m-2) + real(r8),allocatable :: fert_p (:) ! fertilizer nitrogen (gN m-2) including manure + real(r8),allocatable :: latbaset_p (:) ! latitude vary base temperature for gddplant (degree C) + real(r8),allocatable :: plantdate_p (:) ! planting date (input) +#endif +! --------------------- END CROP variables ------------------------- + +! --------------------- SASU variables ----------------------------- + real(r8), allocatable :: leafcCap_p (:) ! leaf display C (gC m-2) + real(r8), allocatable :: leafc_storageCap_p (:) ! leaf storage C (gC m-2) + real(r8), allocatable :: leafc_xferCap_p (:) ! leaf transfer C (gC m-2) + real(r8), allocatable :: frootcCap_p (:) ! fine root display C (gC m-2) + real(r8), allocatable :: frootc_storageCap_p (:) ! fine root storage C (gC m-2) + real(r8), allocatable :: frootc_xferCap_p (:) ! fine root transfer C (gC m-2) + real(r8), allocatable :: livestemcCap_p (:) ! live stem display C (gC m-2) + real(r8), allocatable :: livestemc_storageCap_p (:) ! live stem storage C (gC m-2) + real(r8), allocatable :: livestemc_xferCap_p (:) ! live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemcCap_p (:) ! dead stem display C (gC m-2) + real(r8), allocatable :: deadstemc_storageCap_p (:) ! dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemc_xferCap_p (:) ! dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootcCap_p (:) ! live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootc_storageCap_p (:) ! live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootc_xferCap_p (:) ! live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootcCap_p (:) ! dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootc_storageCap_p (:) ! dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootc_xferCap_p (:) ! dead coarse root transfer C (gC m-2) + + real(r8), allocatable :: leafnCap_p (:) ! leaf display C (gC m-2) + real(r8), allocatable :: leafn_storageCap_p (:) ! leaf storage C (gC m-2) + real(r8), allocatable :: leafn_xferCap_p (:) ! leaf transfer C (gC m-2) + real(r8), allocatable :: frootnCap_p (:) ! fine root display C (gC m-2) + real(r8), allocatable :: frootn_storageCap_p (:) ! fine root storage C (gC m-2) + real(r8), allocatable :: frootn_xferCap_p (:) ! fine root transfer C (gC m-2) + real(r8), allocatable :: livestemnCap_p (:) ! live stem display C (gC m-2) + real(r8), allocatable :: livestemn_storageCap_p (:) ! live stem storage C (gC m-2) + real(r8), allocatable :: livestemn_xferCap_p (:) ! live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemnCap_p (:) ! dead stem display C (gC m-2) + real(r8), allocatable :: deadstemn_storageCap_p (:) ! dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemn_xferCap_p (:) ! dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootnCap_p (:) ! live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootn_storageCap_p (:) ! live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootn_xferCap_p (:) ! live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootnCap_p (:) ! dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootn_storageCap_p (:) ! dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootn_xferCap_p (:) ! dead coarse root transfer C (gC m-2) + + real(r8), allocatable :: leafc0_p (:) ! SASU spinup initial value: leaf display C (gC m-2) + real(r8), allocatable :: leafc0_storage_p (:) ! SASU spinup initial value: leaf storage C (gC m-2) + real(r8), allocatable :: leafc0_xfer_p (:) ! SASU spinup initial value: leaf transfer C (gC m-2) + real(r8), allocatable :: frootc0_p (:) ! SASU spinup initial value: fine root display C (gC m-2) + real(r8), allocatable :: frootc0_storage_p (:) ! SASU spinup initial value: fine root storage C (gC m-2) + real(r8), allocatable :: frootc0_xfer_p (:) ! SASU spinup initial value: fine root transfer C (gC m-2) + real(r8), allocatable :: livestemc0_p (:) ! SASU spinup initial value: live stem display C (gC m-2) + real(r8), allocatable :: livestemc0_storage_p (:) ! SASU spinup initial value: live stem storage C (gC m-2) + real(r8), allocatable :: livestemc0_xfer_p (:) ! SASU spinup initial value: live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemc0_p (:) ! SASU spinup initial value: dead stem display C (gC m-2) + real(r8), allocatable :: deadstemc0_storage_p (:) ! SASU spinup initial value: dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemc0_xfer_p (:) ! SASU spinup initial value: dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootc0_p (:) ! SASU spinup initial value: live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootc0_storage_p (:) ! SASU spinup initial value: live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootc0_xfer_p (:) ! SASU spinup initial value: live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootc0_p (:) ! SASU spinup initial value: dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootc0_storage_p (:) ! SASU spinup initial value: dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootc0_xfer_p (:) ! SASU spinup initial value: dead coarse root transfer C (gC m-2) + real(r8), allocatable :: grainc0_p (:) ! SASU spinup initial value: grain display C (gC m-2) + real(r8), allocatable :: grainc0_storage_p (:) ! SASU spinup initial value: grain storage C (gC m-2) + real(r8), allocatable :: grainc0_xfer_p (:) ! SASU spinup initial value: grain transfer C (gC m-2) + + real(r8), allocatable :: leafn0_p (:) ! SASU spinup initial value: leaf display N (gN m-2) + real(r8), allocatable :: leafn0_storage_p (:) ! SASU spinup initial value: leaf storage N (gN m-2) + real(r8), allocatable :: leafn0_xfer_p (:) ! SASU spinup initial value: leaf transfer N (gN m-2) + real(r8), allocatable :: frootn0_p (:) ! SASU spinup initial value: fine root display N (gN m-2) + real(r8), allocatable :: frootn0_storage_p (:) ! SASU spinup initial value: fine root storage N (gN m-2) + real(r8), allocatable :: frootn0_xfer_p (:) ! SASU spinup initial value: fine root transfer N (gN m-2) + real(r8), allocatable :: livestemn0_p (:) ! SASU spinup initial value: live stem display N (gN m-2) + real(r8), allocatable :: livestemn0_storage_p (:) ! SASU spinup initial value: live stem storage N (gN m-2) + real(r8), allocatable :: livestemn0_xfer_p (:) ! SASU spinup initial value: live stem transfer N (gN m-2) + real(r8), allocatable :: deadstemn0_p (:) ! SASU spinup initial value: dead stem display N (gN m-2) + real(r8), allocatable :: deadstemn0_storage_p (:) ! SASU spinup initial value: dead stem storage N (gN m-2) + real(r8), allocatable :: deadstemn0_xfer_p (:) ! SASU spinup initial value: dead stem transfer N (gN m-2) + real(r8), allocatable :: livecrootn0_p (:) ! SASU spinup initial value: live coarse root display N (gN m-2) + real(r8), allocatable :: livecrootn0_storage_p (:) ! SASU spinup initial value: live coarse root storage N (gN m-2) + real(r8), allocatable :: livecrootn0_xfer_p (:) ! SASU spinup initial value: live coarse root transfer N (gN m-2) + real(r8), allocatable :: deadcrootn0_p (:) ! SASU spinup initial value: dead coarse root display N (gN m-2) + real(r8), allocatable :: deadcrootn0_storage_p (:) ! SASU spinup initial value: dead coarse root storage N (gN m-2) + real(r8), allocatable :: deadcrootn0_xfer_p (:) ! SASU spinup initial value: dead coarse root transfer N (gN m-2) + real(r8), allocatable :: grainn0_p (:) ! SASU spinup initial value: grain display N (gN m-2) + real(r8), allocatable :: grainn0_storage_p (:) ! SASU spinup initial value: grain storage N (gN m-2) + real(r8), allocatable :: grainn0_xfer_p (:) ! SASU spinup initial value: grain transfer N (gN m-2) + real(r8), allocatable :: retransn0_p (:) ! SASU spinup initial value: retranslocated N (gN m-2) + + real(r8), allocatable :: I_leafc_p_acc (:) ! SASU spinup diagnostics: accumulated input to leaf display C (gC m-2) + real(r8), allocatable :: I_leafc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to leaf storage C (gC m-2) + real(r8), allocatable :: I_frootc_p_acc (:) ! SASU spinup diagnostics: accumulated input to fine root display C (gC m-2) + real(r8), allocatable :: I_frootc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to fine root storage C (gC m-2) + real(r8), allocatable :: I_livestemc_p_acc (:) ! SASU spinup diagnostics: accumulated input to live stem display C (gC m-2) + real(r8), allocatable :: I_livestemc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to live stem storage C (gC m-2) + real(r8), allocatable :: I_deadstemc_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead stem display C (gC m-2) + real(r8), allocatable :: I_deadstemc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead stem storage C (gC m-2) + real(r8), allocatable :: I_livecrootc_p_acc (:) ! SASU spinup diagnostics: accumulated input to live coarse root display C (gC m-2) + real(r8), allocatable :: I_livecrootc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to live coarse root storage C (gC m-2) + real(r8), allocatable :: I_deadcrootc_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead coarse root display C (gC m-2) + real(r8), allocatable :: I_deadcrootc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead coarse root storage C (gC m-2) + real(r8), allocatable :: I_grainc_p_acc (:) ! SASU spinup diagnostics: accumulated input to grain display C (gC m-2) + real(r8), allocatable :: I_grainc_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to grain storage C (gC m-2) + real(r8), allocatable :: I_leafn_p_acc (:) ! SASU spinup diagnostics: accumulated input to leaf display N (gN m-2) + real(r8), allocatable :: I_leafn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to leaf storage N (gN m-2) + real(r8), allocatable :: I_frootn_p_acc (:) ! SASU spinup diagnostics: accumulated input to fine root display N (gN m-2) + real(r8), allocatable :: I_frootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to fine root storage N (gN m-2) + real(r8), allocatable :: I_livestemn_p_acc (:) ! SASU spinup diagnostics: accumulated input to live stem display N (gN m-2) + real(r8), allocatable :: I_livestemn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to live stem storage N (gN m-2) + real(r8), allocatable :: I_deadstemn_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead stem display N (gN m-2) + real(r8), allocatable :: I_deadstemn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead stem storage N (gN m-2) + real(r8), allocatable :: I_livecrootn_p_acc (:) ! SASU spinup diagnostics: accumulated input to live coarse root display N (gN m-2) + real(r8), allocatable :: I_livecrootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to live coarse root storage N (gN m-2) + real(r8), allocatable :: I_deadcrootn_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead coarse root display N (gN m-2) + real(r8), allocatable :: I_deadcrootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to dead coarse root storage N (gN m-2) + real(r8), allocatable :: I_grainn_p_acc (:) ! SASU spinup diagnostics: accumulated input to grain display N (gN m-2) + real(r8), allocatable :: I_grainn_st_p_acc (:) ! SASU spinup diagnostics: accumulated input to grain storage N (gN m-2) + + real(r8), allocatable :: AKX_leafc_xf_to_leafc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_frootc_xf_to_frootc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_livestemc_xf_to_livestemc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_xf_to_deadstemc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead stem transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_xf_to_livecrootc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_xf_to_deadcrootc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead coarse root transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_grainc_xf_to_grainc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from grain transfer C to display C (gC m-2) + real(r8), allocatable :: AKX_livestemc_to_deadstemc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem display C to dead stem display C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_to_deadcrootc_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root display C to dead coarse root display C (gC m-2) + + real(r8), allocatable :: AKX_leafc_st_to_leafc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_frootc_st_to_frootc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_livestemc_st_to_livestemc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_st_to_deadstemc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead stem storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_st_to_livecrootc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_st_to_deadcrootc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead coarse root storage C to transfer C (gC m-2) + real(r8), allocatable :: AKX_grainc_st_to_grainc_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from grain storage C to transfer C (gC m-2) + + real(r8), allocatable :: AKX_leafc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf display C (gC m-2) + real(r8), allocatable :: AKX_frootc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root display C (gC m-2) + real(r8), allocatable :: AKX_livestemc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem display C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem display C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root display C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root display C (gC m-2) + real(r8), allocatable :: AKX_grainc_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain display C (gC m-2) + + real(r8), allocatable :: AKX_leafc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf storage C (gC m-2) + real(r8), allocatable :: AKX_frootc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root storage C (gC m-2) + real(r8), allocatable :: AKX_livestemc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem storage C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem storage C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root storage C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root storage C (gC m-2) + real(r8), allocatable :: AKX_grainc_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain storage C (gC m-2) + + real(r8), allocatable :: AKX_leafc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf transfer C (gC m-2) + real(r8), allocatable :: AKX_frootc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root transfer C (gC m-2) + real(r8), allocatable :: AKX_livestemc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem transfer C (gC m-2) + real(r8), allocatable :: AKX_deadstemc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem transfer C (gC m-2) + real(r8), allocatable :: AKX_livecrootc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root transfer C (gC m-2) + real(r8), allocatable :: AKX_deadcrootc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root transfer C (gC m-2) + real(r8), allocatable :: AKX_grainc_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain transfer C (gC m-2) + + real(r8), allocatable :: AKX_leafn_xf_to_leafn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_frootn_xf_to_frootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_livestemn_xf_to_livestemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_xf_to_deadstemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead stem transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_xf_to_livecrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_xf_to_deadcrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead coarse root transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_grainn_xf_to_grainn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from grain transfer N to display N (gN m-2) + real(r8), allocatable :: AKX_livestemn_to_deadstemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem display N to dead stem display N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_to_deadcrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root display N to dead coarse root display N (gN m-2) + + real(r8), allocatable :: AKX_leafn_st_to_leafn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_frootn_st_to_frootn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_livestemn_st_to_livestemn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_st_to_deadstemn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead stem storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_st_to_livecrootn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_st_to_deadcrootn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from dead coarse root storage N to transfer N (gN m-2) + real(r8), allocatable :: AKX_grainn_st_to_grainn_xf_p_acc (:) ! SASU spinup diagnostics: accumulated flux from grain storage N to transfer N (gN m-2) + + real(r8), allocatable :: AKX_leafn_to_retransn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from leaf display N to retranslocated N (gN m-2) + real(r8), allocatable :: AKX_frootn_to_retransn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from fine root display N to retranslocated N (gN m-2) + real(r8), allocatable :: AKX_livestemn_to_retransn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live stem display N to retranslocated N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_to_retransn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from live coarse root display N to retranslocated N (gN m-2) + + real(r8), allocatable :: AKX_retransn_to_leafn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to leaf display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_frootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to fine root display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_livestemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to live stem display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_deadstemn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to dead stem display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_livecrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to live coarse root display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_deadcrootn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to dead coarse root display N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_grainn_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to grain display N (gN m-2) + + real(r8), allocatable :: AKX_retransn_to_leafn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to leaf storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_frootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to fine root storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_livestemn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to live stem storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_deadstemn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to dead stem storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_livecrootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to live coarse root storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_deadcrootn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to dead coarse root storage N (gN m-2) + real(r8), allocatable :: AKX_retransn_to_grainn_st_p_acc (:) ! SASU spinup diagnostics: accumulated flux from retranslocated N to grain storage N (gN m-2) + + real(r8), allocatable :: AKX_leafn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf display N (gN m-2) + real(r8), allocatable :: AKX_frootn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root display N (gN m-2) + real(r8), allocatable :: AKX_livestemn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem display N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem display N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root display N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root display N (gN m-2) + real(r8), allocatable :: AKX_grainn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain display N (gN m-2) + real(r8), allocatable :: AKX_retransn_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from retranslocated N (gN m-2) + + real(r8), allocatable :: AKX_leafn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf storge N (gN m-2) + real(r8), allocatable :: AKX_frootn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root storge N (gN m-2) + real(r8), allocatable :: AKX_livestemn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem storge N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem storge N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root storge N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root storge N (gN m-2) + real(r8), allocatable :: AKX_grainn_st_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain storge N (gN m-2) + + real(r8), allocatable :: AKX_leafn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from leaf transfer N (gN m-2) + real(r8), allocatable :: AKX_frootn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from fine root transfer N (gN m-2) + real(r8), allocatable :: AKX_livestemn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live stem transfer N (gN m-2) + real(r8), allocatable :: AKX_deadstemn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead stem transfer N (gN m-2) + real(r8), allocatable :: AKX_livecrootn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from live coarse root transfer N (gN m-2) + real(r8), allocatable :: AKX_deadcrootn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from dead coarse root transfer N (gN m-2) + real(r8), allocatable :: AKX_grainn_xf_exit_p_acc (:) ! SASU spinup diagnostics: accumulated flux exiting from grain transfer N (gN m-2) + !------------------------- END BGC/SASU variables --------------------- + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_BGCPFTimeVariables + PUBLIC :: deallocate_BGCPFTimeVariables + PUBLIC :: READ_BGCPFTimeVariables + PUBLIC :: WRITE_BGCPFTimeVariables +#ifdef RangeCheck + PUBLIC :: check_BGCPFTimeVariables +#endif + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_BGCPFTimeVariables () +! ------------------------------------------------------ +! Allocates memory for CoLM 1d [numpft] variables +! ------------------------------------------------------ + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandPFT + USE MOD_Vars_Global + IMPLICIT NONE + + IF (.true.) THEN + IF (numpft > 0) THEN + ! bgc variables + allocate (leafc_p (numpft)); leafc_p (:) = spval + allocate (leafc_storage_p (numpft)); leafc_storage_p (:) = spval + allocate (leafc_xfer_p (numpft)); leafc_xfer_p (:) = spval + allocate (frootc_p (numpft)); frootc_p (:) = spval + allocate (frootc_storage_p (numpft)); frootc_storage_p (:) = spval + allocate (frootc_xfer_p (numpft)); frootc_xfer_p (:) = spval + allocate (livestemc_p (numpft)); livestemc_p (:) = spval + allocate (livestemc_storage_p (numpft)); livestemc_storage_p (:) = spval + allocate (livestemc_xfer_p (numpft)); livestemc_xfer_p (:) = spval + allocate (deadstemc_p (numpft)); deadstemc_p (:) = spval + allocate (deadstemc_storage_p (numpft)); deadstemc_storage_p (:) = spval + allocate (deadstemc_xfer_p (numpft)); deadstemc_xfer_p (:) = spval + allocate (livecrootc_p (numpft)); livecrootc_p (:) = spval + allocate (livecrootc_storage_p (numpft)); livecrootc_storage_p (:) = spval + allocate (livecrootc_xfer_p (numpft)); livecrootc_xfer_p (:) = spval + allocate (deadcrootc_p (numpft)); deadcrootc_p (:) = spval + allocate (deadcrootc_storage_p (numpft)); deadcrootc_storage_p (:) = spval + allocate (deadcrootc_xfer_p (numpft)); deadcrootc_xfer_p (:) = spval + allocate (grainc_p (numpft)); grainc_p (:) = spval + allocate (grainc_storage_p (numpft)); grainc_storage_p (:) = spval + allocate (grainc_xfer_p (numpft)); grainc_xfer_p (:) = spval + allocate (cropseedc_deficit_p (numpft)); cropseedc_deficit_p (:) = spval + allocate (xsmrpool_p (numpft)); xsmrpool_p (:) = spval + allocate (gresp_storage_p (numpft)); gresp_storage_p (:) = spval + allocate (gresp_xfer_p (numpft)); gresp_xfer_p (:) = spval + allocate (cpool_p (numpft)); cpool_p (:) = spval + allocate (totvegc_p (numpft)); totvegc_p (:) = spval + allocate (cropprod1c_p (numpft)); cropprod1c_p (:) = spval + + allocate (leaf_prof_p (nl_soil,numpft)) ; leaf_prof_p (:,:) = spval + allocate (froot_prof_p (nl_soil,numpft)) ; froot_prof_p (:,:) = spval + allocate (croot_prof_p (nl_soil,numpft)) ; croot_prof_p (:,:) = spval + allocate (stem_prof_p (nl_soil,numpft)) ; stem_prof_p (:,:) = spval + allocate (cinput_rootfr_p (nl_soil,numpft)) ; cinput_rootfr_p (:,:) = spval + + allocate (leafn_p (numpft)); leafn_p (:) = spval + allocate (leafn_storage_p (numpft)); leafn_storage_p (:) = spval + allocate (leafn_xfer_p (numpft)); leafn_xfer_p (:) = spval + allocate (frootn_p (numpft)); frootn_p (:) = spval + allocate (frootn_storage_p (numpft)); frootn_storage_p (:) = spval + allocate (frootn_xfer_p (numpft)); frootn_xfer_p (:) = spval + allocate (livestemn_p (numpft)); livestemn_p (:) = spval + allocate (livestemn_storage_p (numpft)); livestemn_storage_p (:) = spval + allocate (livestemn_xfer_p (numpft)); livestemn_xfer_p (:) = spval + allocate (deadstemn_p (numpft)); deadstemn_p (:) = spval + allocate (deadstemn_storage_p (numpft)); deadstemn_storage_p (:) = spval + allocate (deadstemn_xfer_p (numpft)); deadstemn_xfer_p (:) = spval + allocate (livecrootn_p (numpft)); livecrootn_p (:) = spval + allocate (livecrootn_storage_p (numpft)); livecrootn_storage_p (:) = spval + allocate (livecrootn_xfer_p (numpft)); livecrootn_xfer_p (:) = spval + allocate (deadcrootn_p (numpft)); deadcrootn_p (:) = spval + allocate (deadcrootn_storage_p (numpft)); deadcrootn_storage_p (:) = spval + allocate (deadcrootn_xfer_p (numpft)); deadcrootn_xfer_p (:) = spval + allocate (grainn_p (numpft)); grainn_p (:) = spval + allocate (grainn_storage_p (numpft)); grainn_storage_p (:) = spval + allocate (grainn_xfer_p (numpft)); grainn_xfer_p (:) = spval + allocate (cropseedn_deficit_p (numpft)); cropseedn_deficit_p (:) = spval + allocate (retransn_p (numpft)); retransn_p (:) = spval + allocate (totvegn_p (numpft)); totvegn_p (:) = spval + + allocate (harvdate_p (numpft)); harvdate_p (:) = spval + + allocate (tempsum_potential_gpp_p (numpft)); tempsum_potential_gpp_p (:) = spval + allocate (tempmax_retransn_p (numpft)); tempmax_retransn_p (:) = spval + allocate (tempavg_tref_p (numpft)); tempavg_tref_p (:) = spval + allocate (tempsum_npp_p (numpft)); tempsum_npp_p (:) = spval + allocate (tempsum_litfall_p (numpft)); tempsum_litfall_p (:) = spval + allocate (annsum_potential_gpp_p (numpft)); annsum_potential_gpp_p (:) = spval + allocate (annmax_retransn_p (numpft)); annmax_retransn_p (:) = spval + allocate (annavg_tref_p (numpft)); annavg_tref_p (:) = spval + allocate (annsum_npp_p (numpft)); annsum_npp_p (:) = spval + allocate (annsum_litfall_p (numpft)); annsum_litfall_p (:) = spval + + allocate (bglfr_p (numpft)); bglfr_p (:) = spval + allocate (bgtr_p (numpft)); bgtr_p (:) = spval + allocate (lgsf_p (numpft)); lgsf_p (:) = spval + allocate (gdd0_p (numpft)); gdd0_p (:) = spval + allocate (gdd8_p (numpft)); gdd8_p (:) = spval + allocate (gdd10_p (numpft)); gdd10_p (:) = spval + allocate (gdd020_p (numpft)); gdd020_p (:) = spval + allocate (gdd820_p (numpft)); gdd820_p (:) = spval + allocate (gdd1020_p (numpft)); gdd1020_p (:) = spval + allocate (nyrs_crop_active_p (numpft)); nyrs_crop_active_p (:) = spval_i4 + + allocate (offset_flag_p (numpft)); offset_flag_p (:) = spval + allocate (offset_counter_p (numpft)); offset_counter_p (:) = spval + allocate (onset_flag_p (numpft)); onset_flag_p (:) = spval + allocate (onset_counter_p (numpft)); onset_counter_p (:) = spval + allocate (onset_gddflag_p (numpft)); onset_gddflag_p (:) = spval + allocate (onset_gdd_p (numpft)); onset_gdd_p (:) = spval + allocate (onset_fdd_p (numpft)); onset_fdd_p (:) = spval + allocate (onset_swi_p (numpft)); onset_swi_p (:) = spval + allocate (offset_fdd_p (numpft)); offset_fdd_p (:) = spval + allocate (offset_swi_p (numpft)); offset_swi_p (:) = spval + allocate (dormant_flag_p (numpft)); dormant_flag_p (:) = spval + allocate (prev_leafc_to_litter_p (numpft)); prev_leafc_to_litter_p (:) = spval + allocate (prev_frootc_to_litter_p (numpft)); prev_frootc_to_litter_p (:) = spval + allocate (days_active_p (numpft)); days_active_p (:) = spval + + allocate (burndate_p (numpft)); burndate_p (:) = spval + + allocate (c_allometry_p (numpft)); c_allometry_p (:) = spval + allocate (n_allometry_p (numpft)); n_allometry_p (:) = spval + allocate (downreg_p (numpft)); downreg_p (:) = spval + allocate (grain_flag_p (numpft)); grain_flag_p (:) = spval + + allocate (ctrunc_p (numpft)); ctrunc_p (:) = spval + allocate (ntrunc_p (numpft)); ntrunc_p (:) = spval + allocate (npool_p (numpft)); npool_p (:) = spval + +#ifdef CROP +! crop variables + allocate (croplive_p (numpft)); croplive_p (:) = .false. + allocate (hui_p (numpft)); hui_p (:) = spval + allocate (gddplant_p (numpft)); gddplant_p (:) = spval + allocate (peaklai_p (numpft)); peaklai_p (:) = spval_i4 + allocate (aroot_p (numpft)); aroot_p (:) = spval + allocate (astem_p (numpft)); astem_p (:) = spval + allocate (arepr_p (numpft)); arepr_p (:) = spval + allocate (aleaf_p (numpft)); aleaf_p (:) = spval + allocate (astemi_p (numpft)); astemi_p (:) = spval + allocate (aleafi_p (numpft)); aleafi_p (:) = spval + allocate (gddmaturity_p (numpft)); gddmaturity_p (:) = spval + + allocate (cropplant_p (numpft)); cropplant_p (:) = .false. + allocate (idop_p (numpft)); idop_p (:) = spval_i4 + allocate (a5tmin_p (numpft)); a5tmin_p (:) = spval + allocate (a10tmin_p (numpft)); a10tmin_p (:) = spval + allocate (t10_p (numpft)); t10_p (:) = spval + allocate (cumvd_p (numpft)); cumvd_p (:) = spval + allocate (vf_p (numpft)); vf_p (:) = spval + allocate (cphase_p (numpft)); cphase_p (:) = spval + allocate (fert_counter_p (numpft)); fert_counter_p (:) = spval + allocate (tref_min_p (numpft)); tref_min_p (:) = spval + allocate (tref_max_p (numpft)); tref_max_p (:) = spval + allocate (tref_min_inst_p (numpft)); tref_min_inst_p (:) = spval + allocate (tref_max_inst_p (numpft)); tref_max_inst_p (:) = spval + allocate (fertnitro_p (numpft)); fertnitro_p (:) = spval + allocate (manunitro_p (numpft)); manunitro_p (:) = spval + allocate (fert_p (numpft)); fert_p (:) = spval + allocate (latbaset_p (numpft)); latbaset_p (:) = spval + allocate (plantdate_p (numpft)); plantdate_p (:) = spval +#endif + +! SASU variables + allocate (leafcCap_p (numpft)); leafcCap_p (:) = spval + allocate (leafc_storageCap_p (numpft)); leafc_storageCap_p (:) = spval + allocate (leafc_xferCap_p (numpft)); leafc_xferCap_p (:) = spval + allocate (frootcCap_p (numpft)); frootcCap_p (:) = spval + allocate (frootc_storageCap_p (numpft)); frootc_storageCap_p (:) = spval + allocate (frootc_xferCap_p (numpft)); frootc_xferCap_p (:) = spval + allocate (livestemcCap_p (numpft)); livestemcCap_p (:) = spval + allocate (livestemc_storageCap_p (numpft)); livestemc_storageCap_p (:) = spval + allocate (livestemc_xferCap_p (numpft)); livestemc_xferCap_p (:) = spval + allocate (deadstemcCap_p (numpft)); deadstemcCap_p (:) = spval + allocate (deadstemc_storageCap_p (numpft)); deadstemc_storageCap_p (:) = spval + allocate (deadstemc_xferCap_p (numpft)); deadstemc_xferCap_p (:) = spval + allocate (livecrootcCap_p (numpft)); livecrootcCap_p (:) = spval + allocate (livecrootc_storageCap_p (numpft)); livecrootc_storageCap_p (:) = spval + allocate (livecrootc_xferCap_p (numpft)); livecrootc_xferCap_p (:) = spval + allocate (deadcrootcCap_p (numpft)); deadcrootcCap_p (:) = spval + allocate (deadcrootc_storageCap_p (numpft)); deadcrootc_storageCap_p (:) = spval + allocate (deadcrootc_xferCap_p (numpft)); deadcrootc_xferCap_p (:) = spval + + allocate (leafnCap_p (numpft)); leafnCap_p (:) = spval + allocate (leafn_storageCap_p (numpft)); leafn_storageCap_p (:) = spval + allocate (leafn_xferCap_p (numpft)); leafn_xferCap_p (:) = spval + allocate (frootnCap_p (numpft)); frootnCap_p (:) = spval + allocate (frootn_storageCap_p (numpft)); frootn_storageCap_p (:) = spval + allocate (frootn_xferCap_p (numpft)); frootn_xferCap_p (:) = spval + allocate (livestemnCap_p (numpft)); livestemnCap_p (:) = spval + allocate (livestemn_storageCap_p (numpft)); livestemn_storageCap_p (:) = spval + allocate (livestemn_xferCap_p (numpft)); livestemn_xferCap_p (:) = spval + allocate (deadstemnCap_p (numpft)); deadstemnCap_p (:) = spval + allocate (deadstemn_storageCap_p (numpft)); deadstemn_storageCap_p (:) = spval + allocate (deadstemn_xferCap_p (numpft)); deadstemn_xferCap_p (:) = spval + allocate (livecrootnCap_p (numpft)); livecrootnCap_p (:) = spval + allocate (livecrootn_storageCap_p (numpft)); livecrootn_storageCap_p (:) = spval + allocate (livecrootn_xferCap_p (numpft)); livecrootn_xferCap_p (:) = spval + allocate (deadcrootnCap_p (numpft)); deadcrootnCap_p (:) = spval + allocate (deadcrootn_storageCap_p (numpft)); deadcrootn_storageCap_p (:) = spval + allocate (deadcrootn_xferCap_p (numpft)); deadcrootn_xferCap_p (:) = spval + + allocate (leafc0_p (numpft)); leafc0_p (:) = spval + allocate (leafc0_storage_p (numpft)); leafc0_storage_p (:) = spval + allocate (leafc0_xfer_p (numpft)); leafc0_xfer_p (:) = spval + allocate (frootc0_p (numpft)); frootc0_p (:) = spval + allocate (frootc0_storage_p (numpft)); frootc0_storage_p (:) = spval + allocate (frootc0_xfer_p (numpft)); frootc0_xfer_p (:) = spval + allocate (livestemc0_p (numpft)); livestemc0_p (:) = spval + allocate (livestemc0_storage_p (numpft)); livestemc0_storage_p (:) = spval + allocate (livestemc0_xfer_p (numpft)); livestemc0_xfer_p (:) = spval + allocate (deadstemc0_p (numpft)); deadstemc0_p (:) = spval + allocate (deadstemc0_storage_p (numpft)); deadstemc0_storage_p (:) = spval + allocate (deadstemc0_xfer_p (numpft)); deadstemc0_xfer_p (:) = spval + allocate (livecrootc0_p (numpft)); livecrootc0_p (:) = spval + allocate (livecrootc0_storage_p (numpft)); livecrootc0_storage_p (:) = spval + allocate (livecrootc0_xfer_p (numpft)); livecrootc0_xfer_p (:) = spval + allocate (deadcrootc0_p (numpft)); deadcrootc0_p (:) = spval + allocate (deadcrootc0_storage_p (numpft)); deadcrootc0_storage_p (:) = spval + allocate (deadcrootc0_xfer_p (numpft)); deadcrootc0_xfer_p (:) = spval + allocate (grainc0_p (numpft)); grainc0_p (:) = spval + allocate (grainc0_storage_p (numpft)); grainc0_storage_p (:) = spval + allocate (grainc0_xfer_p (numpft)); grainc0_xfer_p (:) = spval + + allocate (leafn0_p (numpft)); leafn0_p (:) = spval + allocate (leafn0_storage_p (numpft)); leafn0_storage_p (:) = spval + allocate (leafn0_xfer_p (numpft)); leafn0_xfer_p (:) = spval + allocate (frootn0_p (numpft)); frootn0_p (:) = spval + allocate (frootn0_storage_p (numpft)); frootn0_storage_p (:) = spval + allocate (frootn0_xfer_p (numpft)); frootn0_xfer_p (:) = spval + allocate (livestemn0_p (numpft)); livestemn0_p (:) = spval + allocate (livestemn0_storage_p (numpft)); livestemn0_storage_p (:) = spval + allocate (livestemn0_xfer_p (numpft)); livestemn0_xfer_p (:) = spval + allocate (deadstemn0_p (numpft)); deadstemn0_p (:) = spval + allocate (deadstemn0_storage_p (numpft)); deadstemn0_storage_p (:) = spval + allocate (deadstemn0_xfer_p (numpft)); deadstemn0_xfer_p (:) = spval + allocate (livecrootn0_p (numpft)); livecrootn0_p (:) = spval + allocate (livecrootn0_storage_p (numpft)); livecrootn0_storage_p (:) = spval + allocate (livecrootn0_xfer_p (numpft)); livecrootn0_xfer_p (:) = spval + allocate (deadcrootn0_p (numpft)); deadcrootn0_p (:) = spval + allocate (deadcrootn0_storage_p (numpft)); deadcrootn0_storage_p (:) = spval + allocate (deadcrootn0_xfer_p (numpft)); deadcrootn0_xfer_p (:) = spval + allocate (grainn0_p (numpft)); grainn0_p (:) = spval + allocate (grainn0_storage_p (numpft)); grainn0_storage_p (:) = spval + allocate (grainn0_xfer_p (numpft)); grainn0_xfer_p (:) = spval + allocate (retransn0_p (numpft)); retransn0_p (:) = spval + + allocate (I_leafc_p_acc (numpft)); I_leafc_p_acc (:) = spval + allocate (I_leafc_st_p_acc (numpft)); I_leafc_st_p_acc (:) = spval + allocate (I_frootc_p_acc (numpft)); I_frootc_p_acc (:) = spval + allocate (I_frootc_st_p_acc (numpft)); I_frootc_st_p_acc (:) = spval + allocate (I_livestemc_p_acc (numpft)); I_livestemc_p_acc (:) = spval + allocate (I_livestemc_st_p_acc (numpft)); I_livestemc_st_p_acc (:) = spval + allocate (I_deadstemc_p_acc (numpft)); I_deadstemc_p_acc (:) = spval + allocate (I_deadstemc_st_p_acc (numpft)); I_deadstemc_st_p_acc (:) = spval + allocate (I_livecrootc_p_acc (numpft)); I_livecrootc_p_acc (:) = spval + allocate (I_livecrootc_st_p_acc (numpft)); I_livecrootc_st_p_acc (:) = spval + allocate (I_deadcrootc_p_acc (numpft)); I_deadcrootc_p_acc (:) = spval + allocate (I_deadcrootc_st_p_acc (numpft)); I_deadcrootc_st_p_acc (:) = spval + allocate (I_grainc_p_acc (numpft)); I_grainc_p_acc (:) = spval + allocate (I_grainc_st_p_acc (numpft)); I_grainc_st_p_acc (:) = spval + allocate (I_leafn_p_acc (numpft)); I_leafn_p_acc (:) = spval + allocate (I_leafn_st_p_acc (numpft)); I_leafn_st_p_acc (:) = spval + allocate (I_frootn_p_acc (numpft)); I_frootn_p_acc (:) = spval + allocate (I_frootn_st_p_acc (numpft)); I_frootn_st_p_acc (:) = spval + allocate (I_livestemn_p_acc (numpft)); I_livestemn_p_acc (:) = spval + allocate (I_livestemn_st_p_acc (numpft)); I_livestemn_st_p_acc (:) = spval + allocate (I_deadstemn_p_acc (numpft)); I_deadstemn_p_acc (:) = spval + allocate (I_deadstemn_st_p_acc (numpft)); I_deadstemn_st_p_acc (:) = spval + allocate (I_livecrootn_p_acc (numpft)); I_livecrootn_p_acc (:) = spval + allocate (I_livecrootn_st_p_acc (numpft)); I_livecrootn_st_p_acc (:) = spval + allocate (I_deadcrootn_p_acc (numpft)); I_deadcrootn_p_acc (:) = spval + allocate (I_deadcrootn_st_p_acc (numpft)); I_deadcrootn_st_p_acc (:) = spval + allocate (I_grainn_p_acc (numpft)); I_grainn_p_acc (:) = spval + allocate (I_grainn_st_p_acc (numpft)); I_grainn_st_p_acc (:) = spval + + allocate (AKX_leafc_xf_to_leafc_p_acc (numpft)); AKX_leafc_xf_to_leafc_p_acc (:) = spval + allocate (AKX_frootc_xf_to_frootc_p_acc (numpft)); AKX_frootc_xf_to_frootc_p_acc (:) = spval + allocate (AKX_livestemc_xf_to_livestemc_p_acc (numpft)); AKX_livestemc_xf_to_livestemc_p_acc (:) = spval + allocate (AKX_deadstemc_xf_to_deadstemc_p_acc (numpft)); AKX_deadstemc_xf_to_deadstemc_p_acc (:) = spval + allocate (AKX_livecrootc_xf_to_livecrootc_p_acc (numpft)); AKX_livecrootc_xf_to_livecrootc_p_acc (:) = spval + allocate (AKX_deadcrootc_xf_to_deadcrootc_p_acc (numpft)); AKX_deadcrootc_xf_to_deadcrootc_p_acc (:) = spval + allocate (AKX_grainc_xf_to_grainc_p_acc (numpft)); AKX_grainc_xf_to_grainc_p_acc (:) = spval + allocate (AKX_livestemc_to_deadstemc_p_acc (numpft)); AKX_livestemc_to_deadstemc_p_acc (:) = spval + allocate (AKX_livecrootc_to_deadcrootc_p_acc (numpft)); AKX_livecrootc_to_deadcrootc_p_acc (:) = spval + + allocate (AKX_leafc_st_to_leafc_xf_p_acc (numpft)); AKX_leafc_st_to_leafc_xf_p_acc (:) = spval + allocate (AKX_frootc_st_to_frootc_xf_p_acc (numpft)); AKX_frootc_st_to_frootc_xf_p_acc (:) = spval + allocate (AKX_livestemc_st_to_livestemc_xf_p_acc (numpft)); AKX_livestemc_st_to_livestemc_xf_p_acc (:) = spval + allocate (AKX_deadstemc_st_to_deadstemc_xf_p_acc (numpft)); AKX_deadstemc_st_to_deadstemc_xf_p_acc (:) = spval + allocate (AKX_livecrootc_st_to_livecrootc_xf_p_acc (numpft)); AKX_livecrootc_st_to_livecrootc_xf_p_acc (:) = spval + allocate (AKX_deadcrootc_st_to_deadcrootc_xf_p_acc (numpft)); AKX_deadcrootc_st_to_deadcrootc_xf_p_acc (:) = spval + allocate (AKX_grainc_st_to_grainc_xf_p_acc (numpft)); AKX_grainc_st_to_grainc_xf_p_acc (:) = spval + + allocate (AKX_leafc_exit_p_acc (numpft)); AKX_leafc_exit_p_acc (:) = spval + allocate (AKX_frootc_exit_p_acc (numpft)); AKX_frootc_exit_p_acc (:) = spval + allocate (AKX_livestemc_exit_p_acc (numpft)); AKX_livestemc_exit_p_acc (:) = spval + allocate (AKX_deadstemc_exit_p_acc (numpft)); AKX_deadstemc_exit_p_acc (:) = spval + allocate (AKX_livecrootc_exit_p_acc (numpft)); AKX_livecrootc_exit_p_acc (:) = spval + allocate (AKX_deadcrootc_exit_p_acc (numpft)); AKX_deadcrootc_exit_p_acc (:) = spval + allocate (AKX_grainc_exit_p_acc (numpft)); AKX_grainc_exit_p_acc (:) = spval + + allocate (AKX_leafc_st_exit_p_acc (numpft)); AKX_leafc_st_exit_p_acc (:) = spval + allocate (AKX_frootc_st_exit_p_acc (numpft)); AKX_frootc_st_exit_p_acc (:) = spval + allocate (AKX_livestemc_st_exit_p_acc (numpft)); AKX_livestemc_st_exit_p_acc (:) = spval + allocate (AKX_deadstemc_st_exit_p_acc (numpft)); AKX_deadstemc_st_exit_p_acc (:) = spval + allocate (AKX_livecrootc_st_exit_p_acc (numpft)); AKX_livecrootc_st_exit_p_acc (:) = spval + allocate (AKX_deadcrootc_st_exit_p_acc (numpft)); AKX_deadcrootc_st_exit_p_acc (:) = spval + allocate (AKX_grainc_st_exit_p_acc (numpft)); AKX_grainc_st_exit_p_acc (:) = spval + + allocate (AKX_leafc_xf_exit_p_acc (numpft)); AKX_leafc_xf_exit_p_acc (:) = spval + allocate (AKX_frootc_xf_exit_p_acc (numpft)); AKX_frootc_xf_exit_p_acc (:) = spval + allocate (AKX_livestemc_xf_exit_p_acc (numpft)); AKX_livestemc_xf_exit_p_acc (:) = spval + allocate (AKX_deadstemc_xf_exit_p_acc (numpft)); AKX_deadstemc_xf_exit_p_acc (:) = spval + allocate (AKX_livecrootc_xf_exit_p_acc (numpft)); AKX_livecrootc_xf_exit_p_acc (:) = spval + allocate (AKX_deadcrootc_xf_exit_p_acc (numpft)); AKX_deadcrootc_xf_exit_p_acc (:) = spval + allocate (AKX_grainc_xf_exit_p_acc (numpft)); AKX_grainc_xf_exit_p_acc (:) = spval + + allocate (AKX_leafn_xf_to_leafn_p_acc (numpft)); AKX_leafn_xf_to_leafn_p_acc (:) = spval + allocate (AKX_frootn_xf_to_frootn_p_acc (numpft)); AKX_frootn_xf_to_frootn_p_acc (:) = spval + allocate (AKX_livestemn_xf_to_livestemn_p_acc (numpft)); AKX_livestemn_xf_to_livestemn_p_acc (:) = spval + allocate (AKX_deadstemn_xf_to_deadstemn_p_acc (numpft)); AKX_deadstemn_xf_to_deadstemn_p_acc (:) = spval + allocate (AKX_livecrootn_xf_to_livecrootn_p_acc (numpft)); AKX_livecrootn_xf_to_livecrootn_p_acc (:) = spval + allocate (AKX_deadcrootn_xf_to_deadcrootn_p_acc (numpft)); AKX_deadcrootn_xf_to_deadcrootn_p_acc (:) = spval + allocate (AKX_grainn_xf_to_grainn_p_acc (numpft)); AKX_grainn_xf_to_grainn_p_acc (:) = spval + allocate (AKX_livestemn_to_deadstemn_p_acc (numpft)); AKX_livestemn_to_deadstemn_p_acc (:) = spval + allocate (AKX_livecrootn_to_deadcrootn_p_acc (numpft)); AKX_livecrootn_to_deadcrootn_p_acc (:) = spval + + allocate (AKX_leafn_st_to_leafn_xf_p_acc (numpft)); AKX_leafn_st_to_leafn_xf_p_acc (:) = spval + allocate (AKX_frootn_st_to_frootn_xf_p_acc (numpft)); AKX_frootn_st_to_frootn_xf_p_acc (:) = spval + allocate (AKX_livestemn_st_to_livestemn_xf_p_acc (numpft)); AKX_livestemn_st_to_livestemn_xf_p_acc (:) = spval + allocate (AKX_deadstemn_st_to_deadstemn_xf_p_acc (numpft)); AKX_deadstemn_st_to_deadstemn_xf_p_acc (:) = spval + allocate (AKX_livecrootn_st_to_livecrootn_xf_p_acc (numpft)); AKX_livecrootn_st_to_livecrootn_xf_p_acc (:) = spval + allocate (AKX_deadcrootn_st_to_deadcrootn_xf_p_acc (numpft)); AKX_deadcrootn_st_to_deadcrootn_xf_p_acc (:) = spval + allocate (AKX_grainn_st_to_grainn_xf_p_acc (numpft)); AKX_grainn_st_to_grainn_xf_p_acc (:) = spval + + allocate (AKX_leafn_to_retransn_p_acc (numpft)); AKX_leafn_to_retransn_p_acc (:) = spval + allocate (AKX_frootn_to_retransn_p_acc (numpft)); AKX_frootn_to_retransn_p_acc (:) = spval + allocate (AKX_livestemn_to_retransn_p_acc (numpft)); AKX_livestemn_to_retransn_p_acc (:) = spval + allocate (AKX_livecrootn_to_retransn_p_acc (numpft)); AKX_livecrootn_to_retransn_p_acc (:) = spval + + allocate (AKX_retransn_to_leafn_p_acc (numpft)); AKX_retransn_to_leafn_p_acc (:) = spval + allocate (AKX_retransn_to_frootn_p_acc (numpft)); AKX_retransn_to_frootn_p_acc (:) = spval + allocate (AKX_retransn_to_livestemn_p_acc (numpft)); AKX_retransn_to_livestemn_p_acc (:) = spval + allocate (AKX_retransn_to_deadstemn_p_acc (numpft)); AKX_retransn_to_deadstemn_p_acc (:) = spval + allocate (AKX_retransn_to_livecrootn_p_acc (numpft)); AKX_retransn_to_livecrootn_p_acc (:) = spval + allocate (AKX_retransn_to_deadcrootn_p_acc (numpft)); AKX_retransn_to_deadcrootn_p_acc (:) = spval + allocate (AKX_retransn_to_grainn_p_acc (numpft)); AKX_retransn_to_grainn_p_acc (:) = spval + + allocate (AKX_retransn_to_leafn_st_p_acc (numpft)); AKX_retransn_to_leafn_st_p_acc (:) = spval + allocate (AKX_retransn_to_frootn_st_p_acc (numpft)); AKX_retransn_to_frootn_st_p_acc (:) = spval + allocate (AKX_retransn_to_livestemn_st_p_acc (numpft)); AKX_retransn_to_livestemn_st_p_acc (:) = spval + allocate (AKX_retransn_to_deadstemn_st_p_acc (numpft)); AKX_retransn_to_deadstemn_st_p_acc (:) = spval + allocate (AKX_retransn_to_livecrootn_st_p_acc (numpft)); AKX_retransn_to_livecrootn_st_p_acc (:) = spval + allocate (AKX_retransn_to_deadcrootn_st_p_acc (numpft)); AKX_retransn_to_deadcrootn_st_p_acc (:) = spval + allocate (AKX_retransn_to_grainn_st_p_acc (numpft)); AKX_retransn_to_grainn_st_p_acc (:) = spval + + allocate (AKX_leafn_exit_p_acc (numpft)); AKX_leafn_exit_p_acc (:) = spval + allocate (AKX_frootn_exit_p_acc (numpft)); AKX_frootn_exit_p_acc (:) = spval + allocate (AKX_livestemn_exit_p_acc (numpft)); AKX_livestemn_exit_p_acc (:) = spval + allocate (AKX_deadstemn_exit_p_acc (numpft)); AKX_deadstemn_exit_p_acc (:) = spval + allocate (AKX_livecrootn_exit_p_acc (numpft)); AKX_livecrootn_exit_p_acc (:) = spval + allocate (AKX_deadcrootn_exit_p_acc (numpft)); AKX_deadcrootn_exit_p_acc (:) = spval + allocate (AKX_grainn_exit_p_acc (numpft)); AKX_grainn_exit_p_acc (:) = spval + allocate (AKX_retransn_exit_p_acc (numpft)); AKX_retransn_exit_p_acc (:) = spval + + allocate (AKX_leafn_st_exit_p_acc (numpft)); AKX_leafn_st_exit_p_acc (:) = spval + allocate (AKX_frootn_st_exit_p_acc (numpft)); AKX_frootn_st_exit_p_acc (:) = spval + allocate (AKX_livestemn_st_exit_p_acc (numpft)); AKX_livestemn_st_exit_p_acc (:) = spval + allocate (AKX_deadstemn_st_exit_p_acc (numpft)); AKX_deadstemn_st_exit_p_acc (:) = spval + allocate (AKX_livecrootn_st_exit_p_acc (numpft)); AKX_livecrootn_st_exit_p_acc (:) = spval + allocate (AKX_deadcrootn_st_exit_p_acc (numpft)); AKX_deadcrootn_st_exit_p_acc (:) = spval + allocate (AKX_grainn_st_exit_p_acc (numpft)); AKX_grainn_st_exit_p_acc (:) = spval + + allocate (AKX_leafn_xf_exit_p_acc (numpft)); AKX_leafn_xf_exit_p_acc (:) = spval + allocate (AKX_frootn_xf_exit_p_acc (numpft)); AKX_frootn_xf_exit_p_acc (:) = spval + allocate (AKX_livestemn_xf_exit_p_acc (numpft)); AKX_livestemn_xf_exit_p_acc (:) = spval + allocate (AKX_deadstemn_xf_exit_p_acc (numpft)); AKX_deadstemn_xf_exit_p_acc (:) = spval + allocate (AKX_livecrootn_xf_exit_p_acc (numpft)); AKX_livecrootn_xf_exit_p_acc (:) = spval + allocate (AKX_deadcrootn_xf_exit_p_acc (numpft)); AKX_deadcrootn_xf_exit_p_acc (:) = spval + allocate (AKX_grainn_xf_exit_p_acc (numpft)); AKX_grainn_xf_exit_p_acc (:) = spval + ENDIF + ENDIF + + END SUBROUTINE allocate_BGCPFTimeVariables + + SUBROUTINE READ_BGCPFTimeVariables (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandPFT + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + +! bgc variables + CALL ncio_read_vector (file_restart, 'leafc_p ', landpft, leafc_p ) + CALL ncio_read_vector (file_restart, 'leafc_storage_p ', landpft, leafc_storage_p ) + CALL ncio_read_vector (file_restart, 'leafc_xfer_p ', landpft, leafc_xfer_p ) + CALL ncio_read_vector (file_restart, 'frootc_p ', landpft, frootc_p ) + CALL ncio_read_vector (file_restart, 'frootc_storage_p ', landpft, frootc_storage_p ) + CALL ncio_read_vector (file_restart, 'frootc_xfer_p ', landpft, frootc_xfer_p ) + CALL ncio_read_vector (file_restart, 'livestemc_p ', landpft, livestemc_p ) + CALL ncio_read_vector (file_restart, 'livestemc_storage_p ', landpft, livestemc_storage_p ) + CALL ncio_read_vector (file_restart, 'livestemc_xfer_p ', landpft, livestemc_xfer_p ) + CALL ncio_read_vector (file_restart, 'deadstemc_p ', landpft, deadstemc_p ) + CALL ncio_read_vector (file_restart, 'deadstemc_storage_p ', landpft, deadstemc_storage_p ) + CALL ncio_read_vector (file_restart, 'deadstemc_xfer_p ', landpft, deadstemc_xfer_p ) + CALL ncio_read_vector (file_restart, 'livecrootc_p ', landpft, livecrootc_p ) + CALL ncio_read_vector (file_restart, 'livecrootc_storage_p ', landpft, livecrootc_storage_p ) + CALL ncio_read_vector (file_restart, 'livecrootc_xfer_p ', landpft, livecrootc_xfer_p ) + CALL ncio_read_vector (file_restart, 'deadcrootc_p ', landpft, deadcrootc_p ) + CALL ncio_read_vector (file_restart, 'deadcrootc_storage_p ', landpft, deadcrootc_storage_p ) + CALL ncio_read_vector (file_restart, 'deadcrootc_xfer_p ', landpft, deadcrootc_xfer_p ) + CALL ncio_read_vector (file_restart, 'grainc_p ', landpft, grainc_p ) + CALL ncio_read_vector (file_restart, 'grainc_storage_p ', landpft, grainc_storage_p ) + CALL ncio_read_vector (file_restart, 'grainc_xfer_p ', landpft, grainc_xfer_p ) + CALL ncio_read_vector (file_restart, 'cropseedc_deficit_p ', landpft, cropseedc_deficit_p ) + CALL ncio_read_vector (file_restart, 'xsmrpool_p ', landpft, xsmrpool_p ) + CALL ncio_read_vector (file_restart, 'gresp_storage_p ', landpft, gresp_storage_p ) + CALL ncio_read_vector (file_restart, 'gresp_xfer_p ', landpft, gresp_xfer_p ) + CALL ncio_read_vector (file_restart, 'cpool_p ', landpft, cpool_p ) + ! CALL ncio_read_vector (file_restart, 'totvegc_p ', landpft, totvegc_p ) + CALL ncio_read_vector (file_restart, 'cropprod1c_p ', landpft, cropprod1c_p ) + + CALL ncio_read_vector (file_restart, 'leafn_p ', landpft, leafn_p ) + CALL ncio_read_vector (file_restart, 'leafn_storage_p ', landpft, leafn_storage_p ) + CALL ncio_read_vector (file_restart, 'leafn_xfer_p ', landpft, leafn_xfer_p ) + CALL ncio_read_vector (file_restart, 'frootn_p ', landpft, frootn_p ) + CALL ncio_read_vector (file_restart, 'frootn_storage_p ', landpft, frootn_storage_p ) + CALL ncio_read_vector (file_restart, 'frootn_xfer_p ', landpft, frootn_xfer_p ) + CALL ncio_read_vector (file_restart, 'livestemn_p ', landpft, livestemn_p ) + CALL ncio_read_vector (file_restart, 'livestemn_storage_p ', landpft, livestemn_storage_p ) + CALL ncio_read_vector (file_restart, 'livestemn_xfer_p ', landpft, livestemn_xfer_p ) + CALL ncio_read_vector (file_restart, 'deadstemn_p ', landpft, deadstemn_p ) + CALL ncio_read_vector (file_restart, 'deadstemn_storage_p ', landpft, deadstemn_storage_p ) + CALL ncio_read_vector (file_restart, 'deadstemn_xfer_p ', landpft, deadstemn_xfer_p ) + CALL ncio_read_vector (file_restart, 'livecrootn_p ', landpft, livecrootn_p ) + CALL ncio_read_vector (file_restart, 'livecrootn_storage_p ', landpft, livecrootn_storage_p ) + CALL ncio_read_vector (file_restart, 'livecrootn_xfer_p ', landpft, livecrootn_xfer_p ) + CALL ncio_read_vector (file_restart, 'deadcrootn_p ', landpft, deadcrootn_p ) + CALL ncio_read_vector (file_restart, 'deadcrootn_storage_p ', landpft, deadcrootn_storage_p ) + CALL ncio_read_vector (file_restart, 'deadcrootn_xfer_p ', landpft, deadcrootn_xfer_p ) + CALL ncio_read_vector (file_restart, 'grainn_p ', landpft, grainn_p ) + CALL ncio_read_vector (file_restart, 'grainn_storage_p ', landpft, grainn_storage_p ) + CALL ncio_read_vector (file_restart, 'grainn_xfer_p ', landpft, grainn_xfer_p ) + CALL ncio_read_vector (file_restart, 'cropseedn_deficit_p ', landpft, cropseedn_deficit_p ) + CALL ncio_read_vector (file_restart, 'retransn_p ', landpft, retransn_p ) + ! CALL ncio_read_vector (file_restart, 'totvegn_p ', landpft, totvegn_p ) + + CALL ncio_read_vector (file_restart, 'harvdate_p ', landpft, harvdate_p ) + + CALL ncio_read_vector (file_restart, 'tempsum_potential_gpp_p', landpft, tempsum_potential_gpp_p) + CALL ncio_read_vector (file_restart, 'tempmax_retransn_p ', landpft, tempmax_retransn_p ) + CALL ncio_read_vector (file_restart, 'tempavg_tref_p ', landpft, tempavg_tref_p ) + CALL ncio_read_vector (file_restart, 'tempsum_npp_p ', landpft, tempsum_npp_p ) + CALL ncio_read_vector (file_restart, 'tempsum_litfall_p ', landpft, tempsum_litfall_p ) + CALL ncio_read_vector (file_restart, 'annsum_potential_gpp_p ', landpft, annsum_potential_gpp_p) + CALL ncio_read_vector (file_restart, 'annmax_retransn_p ', landpft, annmax_retransn_p ) + CALL ncio_read_vector (file_restart, 'annavg_tref_p ', landpft, annavg_tref_p ) + CALL ncio_read_vector (file_restart, 'annsum_npp_p ', landpft, annsum_npp_p ) + CALL ncio_read_vector (file_restart, 'annsum_litfall_p ', landpft, annsum_litfall_p ) + + CALL ncio_read_vector (file_restart, 'bglfr_p ', landpft, bglfr_p ) + CALL ncio_read_vector (file_restart, 'bgtr_p ', landpft, bgtr_p ) + CALL ncio_read_vector (file_restart, 'lgsf_p ', landpft, lgsf_p ) + CALL ncio_read_vector (file_restart, 'gdd0_p ', landpft, gdd0_p ) + CALL ncio_read_vector (file_restart, 'gdd8_p ', landpft, gdd8_p ) + CALL ncio_read_vector (file_restart, 'gdd10_p ', landpft, gdd10_p ) + CALL ncio_read_vector (file_restart, 'gdd020_p ', landpft, gdd020_p ) + CALL ncio_read_vector (file_restart, 'gdd820_p ', landpft, gdd820_p ) + CALL ncio_read_vector (file_restart, 'gdd1020_p ', landpft, gdd1020_p ) + CALL ncio_read_vector (file_restart, 'nyrs_crop_active_p ', landpft, nyrs_crop_active_p ) + + CALL ncio_read_vector (file_restart, 'offset_flag_p ', landpft, offset_flag_p ) + CALL ncio_read_vector (file_restart, 'offset_counter_p ', landpft, offset_counter_p ) + CALL ncio_read_vector (file_restart, 'onset_flag_p ', landpft, onset_flag_p ) + CALL ncio_read_vector (file_restart, 'onset_counter_p ', landpft, onset_counter_p ) + CALL ncio_read_vector (file_restart, 'onset_gddflag_p ', landpft, onset_gddflag_p ) + CALL ncio_read_vector (file_restart, 'onset_gdd_p ', landpft, onset_gdd_p ) + CALL ncio_read_vector (file_restart, 'onset_fdd_p ', landpft, onset_fdd_p ) + CALL ncio_read_vector (file_restart, 'onset_swi_p ', landpft, onset_swi_p ) + CALL ncio_read_vector (file_restart, 'offset_fdd_p ', landpft, offset_fdd_p ) + CALL ncio_read_vector (file_restart, 'offset_swi_p ', landpft, offset_swi_p ) + CALL ncio_read_vector (file_restart, 'dormant_flag_p ', landpft, dormant_flag_p ) + CALL ncio_read_vector (file_restart, 'prev_leafc_to_litter_p ', landpft, prev_leafc_to_litter_p) + CALL ncio_read_vector (file_restart, 'prev_frootc_to_litter_p', landpft, prev_frootc_to_litter_p) + CALL ncio_read_vector (file_restart, 'days_active_p ', landpft, days_active_p ) + + CALL ncio_read_vector (file_restart, 'burndate_p ', landpft, burndate_p ) + CALL ncio_read_vector (file_restart, 'grain_flag_p ', landpft, grain_flag_p ) + CALL ncio_read_vector (file_restart, 'ctrunc_p ', landpft, ctrunc_p ) + CALL ncio_read_vector (file_restart, 'ntrunc_p ', landpft, ntrunc_p ) + CALL ncio_read_vector (file_restart, 'npool_p ', landpft, npool_p ) + +#ifdef CROP +! crop variables + CALL ncio_read_vector (file_restart, 'croplive_p ', landpft, croplive_p ) + CALL ncio_read_vector (file_restart, 'hui_p ', landpft, hui_p ) + CALL ncio_read_vector (file_restart, 'gddplant_p ', landpft, gddplant_p ) + CALL ncio_read_vector (file_restart, 'peaklai_p ', landpft, peaklai_p ) + CALL ncio_read_vector (file_restart, 'aroot_p ', landpft, aroot_p ) + CALL ncio_read_vector (file_restart, 'astem_p ', landpft, astem_p ) + CALL ncio_read_vector (file_restart, 'arepr_p ', landpft, arepr_p ) + CALL ncio_read_vector (file_restart, 'aleaf_p ', landpft, aleaf_p ) + CALL ncio_read_vector (file_restart, 'astemi_p ', landpft, astemi_p ) + CALL ncio_read_vector (file_restart, 'aleafi_p ', landpft, aleafi_p ) + CALL ncio_read_vector (file_restart, 'gddmaturity_p ', landpft, gddmaturity_p ) + + CALL ncio_read_vector (file_restart, 'cropplant_p ', landpft, cropplant_p ) + CALL ncio_read_vector (file_restart, 'idop_p ', landpft, idop_p ) + CALL ncio_read_vector (file_restart, 'a5tmin_p ', landpft, a5tmin_p ) + CALL ncio_read_vector (file_restart, 'a10tmin_p ', landpft, a10tmin_p ) + CALL ncio_read_vector (file_restart, 't10_p ', landpft, t10_p ) + CALL ncio_read_vector (file_restart, 'cumvd_p ', landpft, cumvd_p ) + CALL ncio_read_vector (file_restart, 'vf_p ', landpft, vf_p ) + CALL ncio_read_vector (file_restart, 'cphase_p ', landpft, cphase_p ) + CALL ncio_read_vector (file_restart, 'fert_counter_p ', landpft, fert_counter_p ) + CALL ncio_read_vector (file_restart, 'tref_min_p ', landpft, tref_min_p ) + CALL ncio_read_vector (file_restart, 'tref_max_p ', landpft, tref_max_p ) + CALL ncio_read_vector (file_restart, 'tref_min_inst_p ', landpft, tref_min_inst_p ) + CALL ncio_read_vector (file_restart, 'tref_max_inst_p ', landpft, tref_max_inst_p ) + CALL ncio_read_vector (file_restart, 'fertnitro_p ', landpft, fertnitro_p ) + CALL ncio_read_vector (file_restart, 'manunitro_p ', landpft, manunitro_p ) + CALL ncio_read_vector (file_restart, 'fert_p ', landpft, fert_p ) + CALL ncio_read_vector (file_restart, 'latbaset_p ', landpft, latbaset_p ) + CALL ncio_read_vector (file_restart, 'plantdate_p ', landpft, plantdate_p ) +#endif + + IF(DEF_USE_DiagMatrix)THEN +! SASU variables + CALL ncio_read_vector (file_restart, 'leafcCap_p ', landpft, leafcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafc_storageCap_p ', landpft, leafc_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafc_xferCap_p ', landpft, leafc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootcCap_p ', landpft, frootcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc_storageCap_p ', landpft, frootc_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc_xferCap_p ', landpft, frootc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemcCap_p ', landpft, livestemcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc_storageCap_p ', landpft, livestemc_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc_xferCap_p ', landpft, livestemc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemcCap_p ', landpft, deadstemcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc_storageCap_p ', landpft, deadstemc_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc_xferCap_p ', landpft, deadstemc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootcCap_p ', landpft, livecrootcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc_storageCap_p', landpft, livecrootc_storageCap_p, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc_xferCap_p ', landpft, livecrootc_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootcCap_p ', landpft, deadcrootcCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc_storageCap_p', landpft, deadcrootc_storageCap_p, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc_xferCap_p ', landpft, deadcrootc_xferCap_p , defval = 1._r8) + + CALL ncio_read_vector (file_restart, 'leafnCap_p ', landpft, leafnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafn_storageCap_p ', landpft, leafn_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafn_xferCap_p ', landpft, leafn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootnCap_p ', landpft, frootnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn_storageCap_p ', landpft, frootn_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn_xferCap_p ', landpft, frootn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemnCap_p ', landpft, livestemnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn_storageCap_p ', landpft, livestemn_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn_xferCap_p ', landpft, livestemn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemnCap_p ', landpft, deadstemnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn_storageCap_p ', landpft, deadstemn_storageCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn_xferCap_p ', landpft, deadstemn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootnCap_p ', landpft, livecrootnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn_storageCap_p', landpft, livecrootn_storageCap_p, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn_xferCap_p ', landpft, livecrootn_xferCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootnCap_p ', landpft, deadcrootnCap_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn_storageCap_p', landpft, deadcrootn_storageCap_p, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn_xferCap_p ', landpft, deadcrootn_xferCap_p , defval = 1._r8) + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + CALL ncio_read_vector (file_restart, 'leafc0_p ', landpft, leafc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafc0_storage_p ', landpft, leafc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafc0_xfer_p ', landpft, leafc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc0_p ', landpft, frootc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc0_storage_p ', landpft, frootc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootc0_xfer_p ', landpft, frootc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc0_p ', landpft, livestemc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc0_storage_p ', landpft, livestemc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemc0_xfer_p ', landpft, livestemc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc0_p ', landpft, deadstemc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc0_storage_p ', landpft, deadstemc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemc0_xfer_p ', landpft, deadstemc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc0_p ', landpft, livecrootc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc0_storage_p ', landpft, livecrootc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootc0_xfer_p ', landpft, livecrootc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc0_p ', landpft, deadcrootc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc0_storage_p ', landpft, deadcrootc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootc0_xfer_p ', landpft, deadcrootc0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainc0_p ', landpft, grainc0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainc0_storage_p ', landpft, grainc0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainc0_xfer_p ', landpft, grainc0_xfer_p , defval = 1._r8) + + CALL ncio_read_vector (file_restart, 'leafn0_p ', landpft, leafn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafn0_storage_p ', landpft, leafn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'leafn0_xfer_p ', landpft, leafn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn0_p ', landpft, frootn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn0_storage_p ', landpft, frootn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'frootn0_xfer_p ', landpft, frootn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn0_p ', landpft, livestemn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn0_storage_p ', landpft, livestemn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livestemn0_xfer_p ', landpft, livestemn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn0_p ', landpft, deadstemn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn0_storage_p ', landpft, deadstemn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadstemn0_xfer_p ', landpft, deadstemn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn0_p ', landpft, livecrootn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn0_storage_p ', landpft, livecrootn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'livecrootn0_xfer_p ', landpft, livecrootn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn0_p ', landpft, deadcrootn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn0_storage_p ', landpft, deadcrootn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'deadcrootn0_xfer_p ', landpft, deadcrootn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainn0_p ', landpft, grainn0_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainn0_storage_p ', landpft, grainn0_storage_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'grainn0_xfer_p ', landpft, grainn0_xfer_p , defval = 1._r8) + CALL ncio_read_vector (file_restart, 'retransn0_p ', landpft, retransn0_p , defval = 1._r8) + + CALL ncio_read_vector (file_restart, 'I_leafc_p_acc ', landpft, I_leafc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_leafc_st_p_acc ', landpft, I_leafc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_frootc_p_acc ', landpft, I_frootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_frootc_st_p_acc ', landpft, I_frootc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livestemc_p_acc ', landpft, I_livestemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livestemc_st_p_acc ', landpft, I_livestemc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadstemc_p_acc ', landpft, I_deadstemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadstemc_st_p_acc ', landpft, I_deadstemc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livecrootc_p_acc ', landpft, I_livecrootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livecrootc_st_p_acc ', landpft, I_livecrootc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadcrootc_p_acc ', landpft, I_deadcrootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadcrootc_st_p_acc ', landpft, I_deadcrootc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_grainc_p_acc ', landpft, I_grainc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_grainc_st_p_acc ', landpft, I_grainc_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_leafn_p_acc ', landpft, I_leafn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_leafn_st_p_acc ', landpft, I_leafn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_frootn_p_acc ', landpft, I_frootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_frootn_st_p_acc ', landpft, I_frootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livestemn_p_acc ', landpft, I_livestemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livestemn_st_p_acc ', landpft, I_livestemn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadstemn_p_acc ', landpft, I_deadstemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadstemn_st_p_acc ', landpft, I_deadstemn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livecrootn_p_acc ', landpft, I_livecrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_livecrootn_st_p_acc ', landpft, I_livecrootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadcrootn_p_acc ', landpft, I_deadcrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_deadcrootn_st_p_acc ', landpft, I_deadcrootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_grainn_p_acc ', landpft, I_grainn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'I_grainn_st_p_acc ', landpft, I_grainn_st_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafc_xf_to_leafc_p_acc ', landpft, & + AKX_leafc_xf_to_leafc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_xf_to_frootc_p_acc ', landpft, & + AKX_frootc_xf_to_frootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_xf_to_livestemc_p_acc ', landpft, & + AKX_livestemc_xf_to_livestemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_xf_to_deadstemc_p_acc ', landpft, & + AKX_deadstemc_xf_to_deadstemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_xf_to_livecrootc_p_acc ', landpft, & + AKX_livecrootc_xf_to_livecrootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_xf_to_deadcrootc_p_acc ', landpft, & + AKX_deadcrootc_xf_to_deadcrootc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_xf_to_grainc_p_acc ', landpft, & + AKX_grainc_xf_to_grainc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_to_deadstemc_p_acc ', landpft, & + AKX_livestemc_to_deadstemc_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_to_deadcrootc_p_acc ', landpft, & + AKX_livecrootc_to_deadcrootc_p_acc , defval = 0._r8) + + + CALL ncio_read_vector (file_restart, 'AKX_leafc_st_to_leafc_xf_p_acc ', landpft, & + AKX_leafc_st_to_leafc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_st_to_frootc_xf_p_acc ', landpft, & + AKX_frootc_st_to_frootc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_st_to_livestemc_xf_p_acc ', landpft, & + AKX_livestemc_st_to_livestemc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_st_to_deadstemc_xf_p_acc ', landpft, & + AKX_deadstemc_st_to_deadstemc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_st_to_livecrootc_xf_p_acc ', landpft, & + AKX_livecrootc_st_to_livecrootc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ', landpft, & + AKX_deadcrootc_st_to_deadcrootc_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_st_to_grainc_xf_p_acc ', landpft, & + AKX_grainc_st_to_grainc_xf_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafc_exit_p_acc ', landpft, & + AKX_leafc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_exit_p_acc ', landpft, & + AKX_frootc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_exit_p_acc ', landpft, & + AKX_livestemc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_exit_p_acc ', landpft, & + AKX_deadstemc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_exit_p_acc ', landpft, & + AKX_livecrootc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_exit_p_acc ', landpft, & + AKX_deadcrootc_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_exit_p_acc ', landpft, & + AKX_grainc_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafc_st_exit_p_acc ', landpft, & + AKX_leafc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_st_exit_p_acc ', landpft, & + AKX_frootc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_st_exit_p_acc ', landpft, & + AKX_livestemc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_st_exit_p_acc ', landpft, & + AKX_deadstemc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_st_exit_p_acc ', landpft, & + AKX_livecrootc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_st_exit_p_acc ', landpft, & + AKX_deadcrootc_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_st_exit_p_acc ', landpft, & + AKX_grainc_st_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafc_xf_exit_p_acc ', landpft, & + AKX_leafc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootc_xf_exit_p_acc ', landpft, & + AKX_frootc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemc_xf_exit_p_acc ', landpft, & + AKX_livestemc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemc_xf_exit_p_acc ', landpft, & + AKX_deadstemc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootc_xf_exit_p_acc ', landpft, & + AKX_livecrootc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootc_xf_exit_p_acc ', landpft, & + AKX_deadcrootc_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainc_xf_exit_p_acc ', landpft, & + AKX_grainc_xf_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_xf_to_leafn_p_acc ', landpft, & + AKX_leafn_xf_to_leafn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_xf_to_frootn_p_acc ', landpft, & + AKX_frootn_xf_to_frootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_xf_to_livestemn_p_acc ', landpft, & + AKX_livestemn_xf_to_livestemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_xf_to_deadstemn_p_acc ', landpft, & + AKX_deadstemn_xf_to_deadstemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_xf_to_livecrootn_p_acc ', landpft, & + AKX_livecrootn_xf_to_livecrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_xf_to_deadcrootn_p_acc ', landpft, & + AKX_deadcrootn_xf_to_deadcrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_xf_to_grainn_p_acc ', landpft, & + AKX_grainn_xf_to_grainn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_to_deadstemn_p_acc ', landpft, & + AKX_livestemn_to_deadstemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_to_deadcrootn_p_acc ', landpft, & + AKX_livecrootn_to_deadcrootn_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_st_to_leafn_xf_p_acc ', landpft, & + AKX_leafn_st_to_leafn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_st_to_frootn_xf_p_acc ', landpft, & + AKX_frootn_st_to_frootn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_st_to_livestemn_xf_p_acc ', landpft, & + AKX_livestemn_st_to_livestemn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_st_to_deadstemn_xf_p_acc ', landpft, & + AKX_deadstemn_st_to_deadstemn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_st_to_livecrootn_xf_p_acc ', landpft, & + AKX_livecrootn_st_to_livecrootn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ', landpft, & + AKX_deadcrootn_st_to_deadcrootn_xf_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_st_to_grainn_xf_p_acc ', landpft, & + AKX_grainn_st_to_grainn_xf_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_to_retransn_p_acc ', landpft, & + AKX_leafn_to_retransn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_to_retransn_p_acc ', landpft, & + AKX_frootn_to_retransn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_to_retransn_p_acc ', landpft, & + AKX_livestemn_to_retransn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_to_retransn_p_acc ', landpft, & + AKX_livecrootn_to_retransn_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_leafn_p_acc ', landpft, & + AKX_retransn_to_leafn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_frootn_p_acc ', landpft, & + AKX_retransn_to_frootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_livestemn_p_acc ', landpft, & + AKX_retransn_to_livestemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_deadstemn_p_acc ', landpft, & + AKX_retransn_to_deadstemn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_livecrootn_p_acc ', landpft, & + AKX_retransn_to_livecrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_deadcrootn_p_acc ', landpft, & + AKX_retransn_to_deadcrootn_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_grainn_p_acc ', landpft, & + AKX_retransn_to_grainn_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_leafn_st_p_acc ', landpft, & + AKX_retransn_to_leafn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_frootn_st_p_acc ', landpft, & + AKX_retransn_to_frootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_livestemn_st_p_acc ', landpft, & + AKX_retransn_to_livestemn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_deadstemn_st_p_acc ', landpft, & + AKX_retransn_to_deadstemn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_livecrootn_st_p_acc ', landpft, & + AKX_retransn_to_livecrootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_deadcrootn_st_p_acc ', landpft, & + AKX_retransn_to_deadcrootn_st_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_to_grainn_st_p_acc ', landpft, & + AKX_retransn_to_grainn_st_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_exit_p_acc ', landpft, & + AKX_leafn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_exit_p_acc ', landpft, & + AKX_frootn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_exit_p_acc ', landpft, & + AKX_livestemn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_exit_p_acc ', landpft, & + AKX_deadstemn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_exit_p_acc ', landpft, & + AKX_livecrootn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_exit_p_acc ', landpft, & + AKX_deadcrootn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_exit_p_acc ', landpft, & + AKX_grainn_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_retransn_exit_p_acc ', landpft, & + AKX_retransn_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_st_exit_p_acc ', landpft, & + AKX_leafn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_st_exit_p_acc ', landpft, & + AKX_frootn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_st_exit_p_acc ', landpft, & + AKX_livestemn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_st_exit_p_acc ', landpft, & + AKX_deadstemn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_st_exit_p_acc ', landpft, & + AKX_livecrootn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_st_exit_p_acc ', landpft, & + AKX_deadcrootn_st_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_st_exit_p_acc ', landpft, & + AKX_grainn_st_exit_p_acc , defval = 0._r8) + + CALL ncio_read_vector (file_restart, 'AKX_leafn_xf_exit_p_acc ', landpft, & + AKX_leafn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_frootn_xf_exit_p_acc ', landpft, & + AKX_frootn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livestemn_xf_exit_p_acc ', landpft, & + AKX_livestemn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadstemn_xf_exit_p_acc ', landpft, & + AKX_deadstemn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_livecrootn_xf_exit_p_acc ', landpft, & + AKX_livecrootn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_deadcrootn_xf_exit_p_acc ', landpft, & + AKX_deadcrootn_xf_exit_p_acc , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'AKX_grainn_xf_exit_p_acc ', landpft, & + AKX_grainn_xf_exit_p_acc , defval = 0._r8) + ENDIF + END SUBROUTINE READ_BGCPFTimeVariables + + SUBROUTINE WRITE_BGCPFTimeVariables (file_restart) + + USE MOD_Namelist, only: DEF_REST_CompressLevel + USE MOD_LandPFT + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local variables + integer :: compress + + compress = DEF_REST_CompressLevel + + ! bgc variables + CALL ncio_write_vector (file_restart, 'leafc_p ', 'pft', landpft, & + leafc_p , compress) + CALL ncio_write_vector (file_restart, 'leafc_storage_p ', 'pft', landpft, & + leafc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'leafc_xfer_p ', 'pft', landpft, & + leafc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_p ', 'pft', landpft, & + frootc_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_storage_p ', 'pft', landpft, & + frootc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_xfer_p ', 'pft', landpft, & + frootc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_p ', 'pft', landpft, & + livestemc_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_storage_p ', 'pft', landpft, & + livestemc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_xfer_p ', 'pft', landpft, & + livestemc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_p ', 'pft', landpft, & + deadstemc_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_storage_p ', 'pft', landpft, & + deadstemc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_xfer_p ', 'pft', landpft, & + deadstemc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_p ', 'pft', landpft, & + livecrootc_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_storage_p ', 'pft', landpft, & + livecrootc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_xfer_p ', 'pft', landpft, & + livecrootc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_p ', 'pft', landpft, & + deadcrootc_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_storage_p ', 'pft', landpft, & + deadcrootc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_xfer_p ', 'pft', landpft, & + deadcrootc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'grainc_p ', 'pft', landpft, & + grainc_p , compress) + CALL ncio_write_vector (file_restart, 'grainc_storage_p ', 'pft', landpft, & + grainc_storage_p , compress) + CALL ncio_write_vector (file_restart, 'grainc_xfer_p ', 'pft', landpft, & + grainc_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'cropseedc_deficit_p ', 'pft', landpft, & + cropseedc_deficit_p , compress) + CALL ncio_write_vector (file_restart, 'xsmrpool_p ', 'pft', landpft, & + xsmrpool_p , compress) + CALL ncio_write_vector (file_restart, 'gresp_storage_p ', 'pft', landpft, & + gresp_storage_p , compress) + CALL ncio_write_vector (file_restart, 'gresp_xfer_p ', 'pft', landpft, & + gresp_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'cpool_p ', 'pft', landpft, & + cpool_p , compress) + ! CALL ncio_write_vector (file_restart, 'totvegc_p ', 'pft', landpft, & + ! totvegc_p , compress) + CALL ncio_write_vector (file_restart, 'cropprod1c_p ', 'pft', landpft, & + cropprod1c_p , compress) + + CALL ncio_write_vector (file_restart, 'leafn_p ', 'pft', landpft, & + leafn_p , compress) + CALL ncio_write_vector (file_restart, 'leafn_storage_p ', 'pft', landpft, & + leafn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'leafn_xfer_p ', 'pft', landpft, & + leafn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_p ', 'pft', landpft, & + frootn_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_storage_p ', 'pft', landpft, & + frootn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_xfer_p ', 'pft', landpft, & + frootn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_p ', 'pft', landpft, & + livestemn_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_storage_p ', 'pft', landpft, & + livestemn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_xfer_p ', 'pft', landpft, & + livestemn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_p ', 'pft', landpft, & + deadstemn_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_storage_p ', 'pft', landpft, & + deadstemn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_xfer_p ', 'pft', landpft, & + deadstemn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_p ', 'pft', landpft, & + livecrootn_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_storage_p ', 'pft', landpft, & + livecrootn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_xfer_p ', 'pft', landpft, & + livecrootn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_p ', 'pft', landpft, & + deadcrootn_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_storage_p ', 'pft', landpft, & + deadcrootn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_xfer_p ', 'pft', landpft, & + deadcrootn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'grainn_p ', 'pft', landpft, & + grainn_p , compress) + CALL ncio_write_vector (file_restart, 'grainn_storage_p ', 'pft', landpft, & + grainn_storage_p , compress) + CALL ncio_write_vector (file_restart, 'grainn_xfer_p ', 'pft', landpft, & + grainn_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'cropseedn_deficit_p ', 'pft', landpft, & + cropseedn_deficit_p , compress) + CALL ncio_write_vector (file_restart, 'retransn_p ', 'pft', landpft, & + retransn_p , compress) + ! CALL ncio_write_vector (file_restart, 'totvegn_p ', 'pft', landpft, & + ! totvegn_p , compress) + + CALL ncio_write_vector (file_restart, 'harvdate_p ', 'pft', landpft, & + harvdate_p , compress) + + CALL ncio_write_vector (file_restart, 'tempsum_potential_gpp_p', 'pft', landpft, & + tempsum_potential_gpp_p, compress) + CALL ncio_write_vector (file_restart, 'tempmax_retransn_p ', 'pft', landpft, & + tempmax_retransn_p , compress) + CALL ncio_write_vector (file_restart, 'tempavg_tref_p ', 'pft', landpft, & + tempavg_tref_p , compress) + CALL ncio_write_vector (file_restart, 'tempsum_npp_p ', 'pft', landpft, & + tempsum_npp_p , compress) + CALL ncio_write_vector (file_restart, 'tempsum_litfall_p ', 'pft', landpft, & + tempsum_litfall_p , compress) + CALL ncio_write_vector (file_restart, 'annsum_potential_gpp_p ', 'pft', landpft, & + annsum_potential_gpp_p, compress) + CALL ncio_write_vector (file_restart, 'annmax_retransn_p ', 'pft', landpft, & + annmax_retransn_p , compress) + CALL ncio_write_vector (file_restart, 'annavg_tref_p ', 'pft', landpft, & + annavg_tref_p , compress) + CALL ncio_write_vector (file_restart, 'annsum_npp_p ', 'pft', landpft, & + annsum_npp_p , compress) + CALL ncio_write_vector (file_restart, 'annsum_litfall_p ', 'pft', landpft, & + annsum_litfall_p , compress) + + CALL ncio_write_vector (file_restart, 'bglfr_p ', 'pft', landpft, & + bglfr_p , compress) + CALL ncio_write_vector (file_restart, 'bgtr_p ', 'pft', landpft, & + bgtr_p , compress) + CALL ncio_write_vector (file_restart, 'lgsf_p ', 'pft', landpft, & + lgsf_p , compress) + CALL ncio_write_vector (file_restart, 'gdd0_p ', 'pft', landpft, & + gdd0_p , compress) + CALL ncio_write_vector (file_restart, 'gdd8_p ', 'pft', landpft, & + gdd8_p , compress) + CALL ncio_write_vector (file_restart, 'gdd10_p ', 'pft', landpft, & + gdd10_p , compress) + CALL ncio_write_vector (file_restart, 'gdd020_p ', 'pft', landpft, & + gdd020_p , compress) + CALL ncio_write_vector (file_restart, 'gdd820_p ', 'pft', landpft, & + gdd820_p , compress) + CALL ncio_write_vector (file_restart, 'gdd1020_p ', 'pft', landpft, & + gdd1020_p , compress) + CALL ncio_write_vector (file_restart, 'nyrs_crop_active_p ', 'pft', landpft, & + nyrs_crop_active_p , compress) + + CALL ncio_write_vector (file_restart, 'offset_flag_p ', 'pft', landpft, & + offset_flag_p , compress) + CALL ncio_write_vector (file_restart, 'offset_counter_p ', 'pft', landpft, & + offset_counter_p , compress) + CALL ncio_write_vector (file_restart, 'onset_flag_p ', 'pft', landpft, & + onset_flag_p , compress) + CALL ncio_write_vector (file_restart, 'onset_counter_p ', 'pft', landpft, & + onset_counter_p , compress) + CALL ncio_write_vector (file_restart, 'onset_gddflag_p ', 'pft', landpft, & + onset_gddflag_p , compress) + CALL ncio_write_vector (file_restart, 'onset_gdd_p ', 'pft', landpft, & + onset_gdd_p , compress) + CALL ncio_write_vector (file_restart, 'onset_fdd_p ', 'pft', landpft, & + onset_fdd_p , compress) + CALL ncio_write_vector (file_restart, 'onset_swi_p ', 'pft', landpft, & + onset_swi_p , compress) + CALL ncio_write_vector (file_restart, 'offset_fdd_p ', 'pft', landpft, & + offset_fdd_p , compress) + CALL ncio_write_vector (file_restart, 'offset_swi_p ', 'pft', landpft, & + offset_swi_p , compress) + CALL ncio_write_vector (file_restart, 'dormant_flag_p ', 'pft', landpft, & + dormant_flag_p , compress) + CALL ncio_write_vector (file_restart, 'prev_leafc_to_litter_p ', 'pft', landpft, & + prev_leafc_to_litter_p, compress) + CALL ncio_write_vector (file_restart, 'prev_frootc_to_litter_p', 'pft', landpft, & + prev_frootc_to_litter_p, compress) + CALL ncio_write_vector (file_restart, 'days_active_p ', 'pft', landpft, & + days_active_p , compress) + + CALL ncio_write_vector (file_restart, 'burndate_p ', 'pft', landpft, & + burndate_p , compress) + CALL ncio_write_vector (file_restart, 'grain_flag_p ', 'pft', landpft, & + grain_flag_p , compress) + CALL ncio_write_vector (file_restart, 'ctrunc_p ', 'pft', landpft, & + ctrunc_p , compress) + CALL ncio_write_vector (file_restart, 'ntrunc_p ', 'pft', landpft, & + ntrunc_p , compress) + CALL ncio_write_vector (file_restart, 'npool_p ', 'pft', landpft, & + npool_p , compress) + +#ifdef CROP +! crop variables + CALL ncio_write_vector (file_restart, 'croplive_p ', 'pft', landpft, & + croplive_p , compress) + CALL ncio_write_vector (file_restart, 'hui_p ', 'pft', landpft, & + hui_p , compress) + CALL ncio_write_vector (file_restart, 'gddplant_p ', 'pft', landpft, & + gddplant_p , compress) + CALL ncio_write_vector (file_restart, 'peaklai_p ', 'pft', landpft, & + peaklai_p , compress) + CALL ncio_write_vector (file_restart, 'aroot_p ', 'pft', landpft, & + aroot_p , compress) + CALL ncio_write_vector (file_restart, 'astem_p ', 'pft', landpft, & + astem_p , compress) + CALL ncio_write_vector (file_restart, 'arepr_p ', 'pft', landpft, & + arepr_p , compress) + CALL ncio_write_vector (file_restart, 'aleaf_p ', 'pft', landpft, & + aleaf_p , compress) + CALL ncio_write_vector (file_restart, 'astemi_p ', 'pft', landpft, & + astemi_p , compress) + CALL ncio_write_vector (file_restart, 'aleafi_p ', 'pft', landpft, & + aleafi_p , compress) + CALL ncio_write_vector (file_restart, 'gddmaturity_p ', 'pft', landpft, & + gddmaturity_p , compress) + + CALL ncio_write_vector (file_restart, 'cropplant_p ', 'pft', landpft, & + cropplant_p , compress) + CALL ncio_write_vector (file_restart, 'idop_p ', 'pft', landpft, & + idop_p , compress) + CALL ncio_write_vector (file_restart, 'a5tmin_p ', 'pft', landpft, & + a5tmin_p , compress) + CALL ncio_write_vector (file_restart, 'a10tmin_p ', 'pft', landpft, & + a10tmin_p , compress) + CALL ncio_write_vector (file_restart, 't10_p ', 'pft', landpft, & + t10_p , compress) + CALL ncio_write_vector (file_restart, 'cumvd_p ', 'pft', landpft, & + cumvd_p , compress) + CALL ncio_write_vector (file_restart, 'vf_p ', 'pft', landpft, & + vf_p , compress) + CALL ncio_write_vector (file_restart, 'cphase_p ', 'pft', landpft, & + cphase_p , compress) + CALL ncio_write_vector (file_restart, 'fert_counter_p ', 'pft', landpft, & + fert_counter_p , compress) + CALL ncio_write_vector (file_restart, 'tref_min_p ', 'pft', landpft, & + tref_min_p , compress) + CALL ncio_write_vector (file_restart, 'tref_max_p ', 'pft', landpft, & + tref_max_p , compress) + CALL ncio_write_vector (file_restart, 'tref_min_inst_p ', 'pft', landpft, & + tref_min_inst_p , compress) + CALL ncio_write_vector (file_restart, 'tref_max_inst_p ', 'pft', landpft, & + tref_max_inst_p , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_p ', 'pft', landpft, & + fertnitro_p , compress) + CALL ncio_write_vector (file_restart, 'manunitro_p ', 'pft', landpft, & + manunitro_p , compress) + CALL ncio_write_vector (file_restart, 'fert_p ', 'pft', landpft, & + fert_p , compress) + CALL ncio_write_vector (file_restart, 'latbaset_p ', 'pft', landpft, & + latbaset_p , compress) + CALL ncio_write_vector (file_restart, 'plantdate_p ', 'pft', landpft, & + plantdate_p , compress) +#endif + + IF(DEF_USE_DiagMatrix)THEN +! SASU variables + CALL ncio_write_vector (file_restart, 'leafcCap_p ', 'pft', landpft, & + leafcCap_p , compress) + CALL ncio_write_vector (file_restart, 'leafc_storageCap_p ', 'pft', landpft, & + leafc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'leafc_xferCap_p ', 'pft', landpft, & + leafc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootcCap_p ', 'pft', landpft, & + frootcCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_storageCap_p ', 'pft', landpft, & + frootc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootc_xferCap_p ', 'pft', landpft, & + frootc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemcCap_p ', 'pft', landpft, & + livestemcCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_storageCap_p ', 'pft', landpft, & + livestemc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc_xferCap_p ', 'pft', landpft, & + livestemc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemcCap_p ', 'pft', landpft, & + deadstemcCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_storageCap_p ', 'pft', landpft, & + deadstemc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc_xferCap_p ', 'pft', landpft, & + deadstemc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootcCap_p ', 'pft', landpft, & + livecrootcCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_storageCap_p ', 'pft', landpft, & + livecrootc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc_xferCap_p ', 'pft', landpft, & + livecrootc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootcCap_p ', 'pft', landpft, & + deadcrootcCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_storageCap_p ', 'pft', landpft, & + deadcrootc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc_xferCap_p ', 'pft', landpft, & + deadcrootc_xferCap_p , compress) + + CALL ncio_write_vector (file_restart, 'leafnCap_p ', 'pft', landpft, & + leafcCap_p , compress) + CALL ncio_write_vector (file_restart, 'leafn_storageCap_p ', 'pft', landpft, & + leafc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'leafn_xferCap_p ', 'pft', landpft, & + leafc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootnCap_p ', 'pft', landpft, & + frootcCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_storageCap_p ', 'pft', landpft, & + frootc_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'frootn_xferCap_p ', 'pft', landpft, & + frootc_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemnCap_p ', 'pft', landpft, & + livestemnCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_storageCap_p ', 'pft', landpft, & + livestemn_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn_xferCap_p ', 'pft', landpft, & + livestemn_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemnCap_p ', 'pft', landpft, & + deadstemnCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_storageCap_p ', 'pft', landpft, & + deadstemn_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn_xferCap_p ', 'pft', landpft, & + deadstemn_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootnCap_p ', 'pft', landpft, & + livecrootnCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_storageCap_p ', 'pft', landpft, & + livecrootn_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn_xferCap_p ', 'pft', landpft, & + livecrootn_xferCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootnCap_p ', 'pft', landpft, & + deadcrootnCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_storageCap_p ', 'pft', landpft, & + deadcrootn_storageCap_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn_xferCap_p ', 'pft', landpft, & + deadcrootn_xferCap_p , compress) + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + CALL ncio_write_vector (file_restart, 'leafc0_p ', 'pft', landpft, & + leafc0_p , compress) + CALL ncio_write_vector (file_restart, 'leafc0_storage_p ', 'pft', landpft, & + leafc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'leafc0_xfer_p ', 'pft', landpft, & + leafc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'frootc0_p ', 'pft', landpft, & + frootc0_p , compress) + CALL ncio_write_vector (file_restart, 'frootc0_storage_p ', 'pft', landpft, & + frootc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'frootc0_xfer_p ', 'pft', landpft, & + frootc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc0_p ', 'pft', landpft, & + livestemc0_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc0_storage_p ', 'pft', landpft, & + livestemc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livestemc0_xfer_p ', 'pft', landpft, & + livestemc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc0_p ', 'pft', landpft, & + deadstemc0_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc0_storage_p ', 'pft', landpft, & + deadstemc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemc0_xfer_p ', 'pft', landpft, & + deadstemc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc0_p ', 'pft', landpft, & + livecrootc0_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc0_storage_p ', 'pft', landpft, & + livecrootc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootc0_xfer_p ', 'pft', landpft, & + livecrootc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc0_p ', 'pft', landpft, & + deadcrootc0_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc0_storage_p ', 'pft', landpft, & + deadcrootc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootc0_xfer_p ', 'pft', landpft, & + deadcrootc0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'grainc0_p ', 'pft', landpft, & + grainc0_p , compress) + CALL ncio_write_vector (file_restart, 'grainc0_storage_p ', 'pft', landpft, & + grainc0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'grainc0_xfer_p ', 'pft', landpft, & + grainc0_xfer_p , compress) + + CALL ncio_write_vector (file_restart, 'leafn0_p ', 'pft', landpft, & + leafn0_p , compress) + CALL ncio_write_vector (file_restart, 'leafn0_storage_p ', 'pft', landpft, & + leafn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'leafn0_xfer_p ', 'pft', landpft, & + leafn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'frootn0_p ', 'pft', landpft, & + frootn0_p , compress) + CALL ncio_write_vector (file_restart, 'frootn0_storage_p ', 'pft', landpft, & + frootn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'frootn0_xfer_p ', 'pft', landpft, & + frootn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn0_p ', 'pft', landpft, & + livestemn0_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn0_storage_p ', 'pft', landpft, & + livestemn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livestemn0_xfer_p ', 'pft', landpft, & + livestemn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn0_p ', 'pft', landpft, & + deadstemn0_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn0_storage_p ', 'pft', landpft, & + deadstemn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadstemn0_xfer_p ', 'pft', landpft, & + deadstemn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn0_p ', 'pft', landpft, & + livecrootn0_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn0_storage_p ', 'pft', landpft, & + livecrootn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'livecrootn0_xfer_p ', 'pft', landpft, & + livecrootn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn0_p ', 'pft', landpft, & + deadcrootn0_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn0_storage_p ', 'pft', landpft, & + deadcrootn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'deadcrootn0_xfer_p ', 'pft', landpft, & + deadcrootn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'grainn0_p ', 'pft', landpft, & + grainn0_p , compress) + CALL ncio_write_vector (file_restart, 'grainn0_storage_p ', 'pft', landpft, & + grainn0_storage_p , compress) + CALL ncio_write_vector (file_restart, 'grainn0_xfer_p ', 'pft', landpft, & + grainn0_xfer_p , compress) + CALL ncio_write_vector (file_restart, 'retransn0_p ', 'pft', landpft, & + retransn0_p , compress) + + CALL ncio_write_vector (file_restart, 'I_leafc_p_acc ', 'pft', landpft, & + I_leafc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_leafc_st_p_acc ', 'pft', landpft, & + I_leafc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_frootc_p_acc ', 'pft', landpft, & + I_frootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_frootc_st_p_acc ', 'pft', landpft, & + I_frootc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livestemc_p_acc ', 'pft', landpft, & + I_livestemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livestemc_st_p_acc ', 'pft', landpft, & + I_livestemc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadstemc_p_acc ', 'pft', landpft, & + I_deadstemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadstemc_st_p_acc ', 'pft', landpft, & + I_deadstemc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livecrootc_p_acc ', 'pft', landpft, & + I_livecrootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livecrootc_st_p_acc ', 'pft', landpft, & + I_livecrootc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadcrootc_p_acc ', 'pft', landpft, & + I_deadcrootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadcrootc_st_p_acc ', 'pft', landpft, & + I_deadcrootc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_grainc_p_acc ', 'pft', landpft, & + I_grainc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_grainc_st_p_acc ', 'pft', landpft, & + I_grainc_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_leafn_p_acc ', 'pft', landpft, & + I_leafn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_leafn_st_p_acc ', 'pft', landpft, & + I_leafn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_frootn_p_acc ', 'pft', landpft, & + I_frootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_frootn_st_p_acc ', 'pft', landpft, & + I_frootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livestemn_p_acc ', 'pft', landpft, & + I_livestemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livestemn_st_p_acc ', 'pft', landpft, & + I_livestemn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadstemn_p_acc ', 'pft', landpft, & + I_deadstemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadstemn_st_p_acc ', 'pft', landpft, & + I_deadstemn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livecrootn_p_acc ', 'pft', landpft, & + I_livecrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_livecrootn_st_p_acc ', 'pft', landpft, & + I_livecrootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadcrootn_p_acc ', 'pft', landpft, & + I_deadcrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_deadcrootn_st_p_acc ', 'pft', landpft, & + I_deadcrootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_grainn_p_acc ', 'pft', landpft, & + I_grainn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'I_grainn_st_p_acc ', 'pft', landpft, & + I_grainn_st_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafc_xf_to_leafc_p_acc ', 'pft', landpft, & + AKX_leafc_xf_to_leafc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_xf_to_frootc_p_acc ', 'pft', landpft, & + AKX_frootc_xf_to_frootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_xf_to_livestemc_p_acc ', 'pft', landpft, & + AKX_livestemc_xf_to_livestemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_xf_to_deadstemc_p_acc ', 'pft', landpft, & + AKX_deadstemc_xf_to_deadstemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_xf_to_livecrootc_p_acc ', 'pft', landpft, & + AKX_livecrootc_xf_to_livecrootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_xf_to_deadcrootc_p_acc ', 'pft', landpft, & + AKX_deadcrootc_xf_to_deadcrootc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_xf_to_grainc_p_acc ', 'pft', landpft, & + AKX_grainc_xf_to_grainc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_to_deadstemc_p_acc ', 'pft', landpft, & + AKX_livestemc_to_deadstemc_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_to_deadcrootc_p_acc ', 'pft', landpft, & + AKX_livecrootc_to_deadcrootc_p_acc , compress) + + + CALL ncio_write_vector (file_restart, 'AKX_leafc_st_to_leafc_xf_p_acc ', 'pft', landpft, & + AKX_leafc_st_to_leafc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_st_to_frootc_xf_p_acc ', 'pft', landpft, & + AKX_frootc_st_to_frootc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_st_to_livestemc_xf_p_acc ', 'pft', landpft, & + AKX_livestemc_st_to_livestemc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_st_to_deadstemc_xf_p_acc ', 'pft', landpft, & + AKX_deadstemc_st_to_deadstemc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_st_to_livecrootc_xf_p_acc ', 'pft', landpft, & + AKX_livecrootc_st_to_livecrootc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ', 'pft', landpft, & + AKX_deadcrootc_st_to_deadcrootc_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_st_to_grainc_xf_p_acc ', 'pft', landpft, & + AKX_grainc_st_to_grainc_xf_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafc_exit_p_acc ', 'pft', landpft, & + AKX_leafc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_exit_p_acc ', 'pft', landpft, & + AKX_frootc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_exit_p_acc ', 'pft', landpft, & + AKX_livestemc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_exit_p_acc ', 'pft', landpft, & + AKX_deadstemc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_exit_p_acc ', 'pft', landpft, & + AKX_livecrootc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootc_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_exit_p_acc ', 'pft', landpft, & + AKX_grainc_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafc_st_exit_p_acc ', 'pft', landpft, & + AKX_leafc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_st_exit_p_acc ', 'pft', landpft, & + AKX_frootc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_st_exit_p_acc ', 'pft', landpft, & + AKX_livestemc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_st_exit_p_acc ', 'pft', landpft, & + AKX_deadstemc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_st_exit_p_acc ', 'pft', landpft, & + AKX_livecrootc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_st_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootc_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_st_exit_p_acc ', 'pft', landpft, & + AKX_grainc_st_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafc_xf_exit_p_acc ', 'pft', landpft, & + AKX_leafc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootc_xf_exit_p_acc ', 'pft', landpft, & + AKX_frootc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemc_xf_exit_p_acc ', 'pft', landpft, & + AKX_livestemc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemc_xf_exit_p_acc ', 'pft', landpft, & + AKX_deadstemc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootc_xf_exit_p_acc ', 'pft', landpft, & + AKX_livecrootc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootc_xf_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootc_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainc_xf_exit_p_acc ', 'pft', landpft, & + AKX_grainc_xf_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_xf_to_leafn_p_acc ', 'pft', landpft, & + AKX_leafn_xf_to_leafn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_xf_to_frootn_p_acc ', 'pft', landpft, & + AKX_frootn_xf_to_frootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_xf_to_livestemn_p_acc ', 'pft', landpft, & + AKX_livestemn_xf_to_livestemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_xf_to_deadstemn_p_acc ', 'pft', landpft, & + AKX_deadstemn_xf_to_deadstemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_xf_to_livecrootn_p_acc ', 'pft', landpft, & + AKX_livecrootn_xf_to_livecrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_xf_to_deadcrootn_p_acc ', 'pft', landpft, & + AKX_deadcrootn_xf_to_deadcrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_xf_to_grainn_p_acc ', 'pft', landpft, & + AKX_grainn_xf_to_grainn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_to_deadstemn_p_acc ', 'pft', landpft, & + AKX_livestemn_to_deadstemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_to_deadcrootn_p_acc ', 'pft', landpft, & + AKX_livecrootn_to_deadcrootn_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_st_to_leafn_xf_p_acc ', 'pft', landpft, & + AKX_leafn_st_to_leafn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_st_to_frootn_xf_p_acc ', 'pft', landpft, & + AKX_frootn_st_to_frootn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_st_to_livestemn_xf_p_acc ', 'pft', landpft, & + AKX_livestemn_st_to_livestemn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_st_to_deadstemn_xf_p_acc ', 'pft', landpft, & + AKX_deadstemn_st_to_deadstemn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_st_to_livecrootn_xf_p_acc ', 'pft', landpft, & + AKX_livecrootn_st_to_livecrootn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ', 'pft', landpft, & + AKX_deadcrootn_st_to_deadcrootn_xf_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_st_to_grainn_xf_p_acc ', 'pft', landpft, & + AKX_grainn_st_to_grainn_xf_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_to_retransn_p_acc ', 'pft', landpft, & + AKX_leafn_to_retransn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_to_retransn_p_acc ', 'pft', landpft, & + AKX_frootn_to_retransn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_to_retransn_p_acc ', 'pft', landpft, & + AKX_livestemn_to_retransn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_to_retransn_p_acc ', 'pft', landpft, & + AKX_livecrootn_to_retransn_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_leafn_p_acc ', 'pft', landpft, & + AKX_retransn_to_leafn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_frootn_p_acc ', 'pft', landpft, & + AKX_retransn_to_frootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_livestemn_p_acc ', 'pft', landpft, & + AKX_retransn_to_livestemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_deadstemn_p_acc ', 'pft', landpft, & + AKX_retransn_to_deadstemn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_livecrootn_p_acc ', 'pft', landpft, & + AKX_retransn_to_livecrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_deadcrootn_p_acc ', 'pft', landpft, & + AKX_retransn_to_deadcrootn_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_grainn_p_acc ', 'pft', landpft, & + AKX_retransn_to_grainn_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_leafn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_leafn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_frootn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_frootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_livestemn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_livestemn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_deadstemn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_deadstemn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_livecrootn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_livecrootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_deadcrootn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_deadcrootn_st_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_to_grainn_st_p_acc ', 'pft', landpft, & + AKX_retransn_to_grainn_st_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_exit_p_acc ', 'pft', landpft, & + AKX_leafn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_exit_p_acc ', 'pft', landpft, & + AKX_frootn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_exit_p_acc ', 'pft', landpft, & + AKX_livestemn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_exit_p_acc ', 'pft', landpft, & + AKX_deadstemn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_exit_p_acc ', 'pft', landpft, & + AKX_livecrootn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_exit_p_acc ', 'pft', landpft, & + AKX_grainn_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_retransn_exit_p_acc ', 'pft', landpft, & + AKX_retransn_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_st_exit_p_acc ', 'pft', landpft, & + AKX_leafn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_st_exit_p_acc ', 'pft', landpft, & + AKX_frootn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_st_exit_p_acc ', 'pft', landpft, & + AKX_livestemn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_st_exit_p_acc ', 'pft', landpft, & + AKX_deadstemn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_st_exit_p_acc ', 'pft', landpft, & + AKX_livecrootn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_st_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootn_st_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_st_exit_p_acc ', 'pft', landpft, & + AKX_grainn_st_exit_p_acc , compress) + + CALL ncio_write_vector (file_restart, 'AKX_leafn_xf_exit_p_acc ', 'pft', landpft, & + AKX_leafn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_frootn_xf_exit_p_acc ', 'pft', landpft, & + AKX_frootn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livestemn_xf_exit_p_acc ', 'pft', landpft, & + AKX_livestemn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadstemn_xf_exit_p_acc ', 'pft', landpft, & + AKX_deadstemn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_livecrootn_xf_exit_p_acc ', 'pft', landpft, & + AKX_livecrootn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_deadcrootn_xf_exit_p_acc ', 'pft', landpft, & + AKX_deadcrootn_xf_exit_p_acc , compress) + CALL ncio_write_vector (file_restart, 'AKX_grainn_xf_exit_p_acc ', 'pft', landpft, & + AKX_grainn_xf_exit_p_acc , compress) + ENDIF + END SUBROUTINE WRITE_BGCPFTimeVariables + + + SUBROUTINE deallocate_BGCPFTimeVariables () +! -------------------------------------------------- +! Deallocates memory for CoLM 1d [numpft/numpc] variables +! -------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_LandPFT + + IF (.true.) THEN + IF (numpft > 0) THEN +! bgc variables + deallocate (leafc_p ) + deallocate (leafc_storage_p ) + deallocate (leafc_xfer_p ) + deallocate (frootc_p ) + deallocate (frootc_storage_p ) + deallocate (frootc_xfer_p ) + deallocate (livestemc_p ) + deallocate (livestemc_storage_p ) + deallocate (livestemc_xfer_p ) + deallocate (deadstemc_p ) + deallocate (deadstemc_storage_p ) + deallocate (deadstemc_xfer_p ) + deallocate (livecrootc_p ) + deallocate (livecrootc_storage_p ) + deallocate (livecrootc_xfer_p ) + deallocate (deadcrootc_p ) + deallocate (deadcrootc_storage_p ) + deallocate (deadcrootc_xfer_p ) + deallocate (grainc_p ) + deallocate (grainc_storage_p ) + deallocate (grainc_xfer_p ) + deallocate (cropseedc_deficit_p ) + deallocate (xsmrpool_p ) + deallocate (gresp_storage_p ) + deallocate (gresp_xfer_p ) + deallocate (cpool_p ) + deallocate (totvegc_p ) + deallocate (cropprod1c_p ) + + deallocate (leaf_prof_p ) + deallocate (froot_prof_p ) + deallocate (croot_prof_p ) + deallocate (stem_prof_p ) + deallocate (cinput_rootfr_p ) + + deallocate (leafn_p ) + deallocate (leafn_storage_p ) + deallocate (leafn_xfer_p ) + deallocate (frootn_p ) + deallocate (frootn_storage_p ) + deallocate (frootn_xfer_p ) + deallocate (livestemn_p ) + deallocate (livestemn_storage_p ) + deallocate (livestemn_xfer_p ) + deallocate (deadstemn_p ) + deallocate (deadstemn_storage_p ) + deallocate (deadstemn_xfer_p ) + deallocate (livecrootn_p ) + deallocate (livecrootn_storage_p ) + deallocate (livecrootn_xfer_p ) + deallocate (deadcrootn_p ) + deallocate (deadcrootn_storage_p ) + deallocate (deadcrootn_xfer_p ) + deallocate (grainn_p ) + deallocate (grainn_storage_p ) + deallocate (grainn_xfer_p ) + deallocate (cropseedn_deficit_p ) + deallocate (retransn_p ) + deallocate (totvegn_p ) + + deallocate (harvdate_p ) + + deallocate (tempsum_potential_gpp_p ) + deallocate (tempmax_retransn_p ) + deallocate (tempavg_tref_p ) + deallocate (tempsum_npp_p ) + deallocate (tempsum_litfall_p ) + deallocate (annsum_potential_gpp_p ) + deallocate (annmax_retransn_p ) + deallocate (annavg_tref_p ) + deallocate (annsum_npp_p ) + deallocate (annsum_litfall_p ) + + deallocate (bglfr_p ) + deallocate (bgtr_p ) + deallocate (lgsf_p ) + deallocate (gdd0_p ) + deallocate (gdd8_p ) + deallocate (gdd10_p ) + deallocate (gdd020_p ) + deallocate (gdd820_p ) + deallocate (gdd1020_p ) + deallocate (nyrs_crop_active_p ) + + deallocate (offset_flag_p ) + deallocate (offset_counter_p ) + deallocate (onset_flag_p ) + deallocate (onset_counter_p ) + deallocate (onset_gddflag_p ) + deallocate (onset_gdd_p ) + deallocate (onset_fdd_p ) + deallocate (onset_swi_p ) + deallocate (offset_fdd_p ) + deallocate (offset_swi_p ) + deallocate (dormant_flag_p ) + deallocate (prev_leafc_to_litter_p ) + deallocate (prev_frootc_to_litter_p ) + deallocate (days_active_p ) + + deallocate (burndate_p ) + + deallocate (c_allometry_p ) + deallocate (n_allometry_p ) + deallocate (downreg_p ) + deallocate (grain_flag_p ) + + deallocate (ctrunc_p ) + deallocate (ntrunc_p ) + deallocate (npool_p ) + +#ifdef CROP +! crop variables + deallocate (croplive_p ) + deallocate (hui_p ) + deallocate (gddplant_p ) + deallocate (peaklai_p ) + deallocate (aroot_p ) + deallocate (astem_p ) + deallocate (arepr_p ) + deallocate (aleaf_p ) + deallocate (astemi_p ) + deallocate (aleafi_p ) + deallocate (gddmaturity_p ) + + deallocate (cropplant_p ) + deallocate (idop_p ) + deallocate (a5tmin_p ) + deallocate (a10tmin_p ) + deallocate (t10_p ) + deallocate (cumvd_p ) + deallocate (vf_p ) + deallocate (cphase_p ) + deallocate (fert_counter_p ) + deallocate (tref_min_p ) + deallocate (tref_max_p ) + deallocate (tref_min_inst_p ) + deallocate (tref_max_inst_p ) + deallocate (fertnitro_p ) + deallocate (manunitro_p ) + deallocate (fert_p ) + deallocate (latbaset_p ) + deallocate (plantdate_p ) +#endif + +! SASU variables + deallocate (leafcCap_p ) + deallocate (leafc_storageCap_p ) + deallocate (leafc_xferCap_p ) + deallocate (frootcCap_p ) + deallocate (frootc_storageCap_p ) + deallocate (frootc_xferCap_p ) + deallocate (livestemcCap_p ) + deallocate (livestemc_storageCap_p ) + deallocate (livestemc_xferCap_p ) + deallocate (deadstemcCap_p ) + deallocate (deadstemc_storageCap_p ) + deallocate (deadstemc_xferCap_p ) + deallocate (livecrootcCap_p ) + deallocate (livecrootc_storageCap_p ) + deallocate (livecrootc_xferCap_p ) + deallocate (deadcrootcCap_p ) + deallocate (deadcrootc_storageCap_p ) + deallocate (deadcrootc_xferCap_p ) + + deallocate (leafnCap_p ) + deallocate (leafn_storageCap_p ) + deallocate (leafn_xferCap_p ) + deallocate (frootnCap_p ) + deallocate (frootn_storageCap_p ) + deallocate (frootn_xferCap_p ) + deallocate (livestemnCap_p ) + deallocate (livestemn_storageCap_p ) + deallocate (livestemn_xferCap_p ) + deallocate (deadstemnCap_p ) + deallocate (deadstemn_storageCap_p ) + deallocate (deadstemn_xferCap_p ) + deallocate (livecrootnCap_p ) + deallocate (livecrootn_storageCap_p ) + deallocate (livecrootn_xferCap_p ) + deallocate (deadcrootnCap_p ) + deallocate (deadcrootn_storageCap_p ) + deallocate (deadcrootn_xferCap_p ) + + deallocate (leafc0_p ) + deallocate (leafc0_storage_p ) + deallocate (leafc0_xfer_p ) + deallocate (frootc0_p ) + deallocate (frootc0_storage_p ) + deallocate (frootc0_xfer_p ) + deallocate (livestemc0_p ) + deallocate (livestemc0_storage_p ) + deallocate (livestemc0_xfer_p ) + deallocate (deadstemc0_p ) + deallocate (deadstemc0_storage_p ) + deallocate (deadstemc0_xfer_p ) + deallocate (livecrootc0_p ) + deallocate (livecrootc0_storage_p ) + deallocate (livecrootc0_xfer_p ) + deallocate (deadcrootc0_p ) + deallocate (deadcrootc0_storage_p ) + deallocate (deadcrootc0_xfer_p ) + deallocate (grainc0_p ) + deallocate (grainc0_storage_p ) + deallocate (grainc0_xfer_p ) + + deallocate (leafn0_p ) + deallocate (leafn0_storage_p ) + deallocate (leafn0_xfer_p ) + deallocate (frootn0_p ) + deallocate (frootn0_storage_p ) + deallocate (frootn0_xfer_p ) + deallocate (livestemn0_p ) + deallocate (livestemn0_storage_p ) + deallocate (livestemn0_xfer_p ) + deallocate (deadstemn0_p ) + deallocate (deadstemn0_storage_p ) + deallocate (deadstemn0_xfer_p ) + deallocate (livecrootn0_p ) + deallocate (livecrootn0_storage_p ) + deallocate (livecrootn0_xfer_p ) + deallocate (deadcrootn0_p ) + deallocate (deadcrootn0_storage_p ) + deallocate (deadcrootn0_xfer_p ) + deallocate (grainn0_p ) + deallocate (grainn0_storage_p ) + deallocate (grainn0_xfer_p ) + deallocate (retransn0_p ) + + deallocate (I_leafc_p_acc ) + deallocate (I_leafc_st_p_acc ) + deallocate (I_frootc_p_acc ) + deallocate (I_frootc_st_p_acc ) + deallocate (I_livestemc_p_acc ) + deallocate (I_livestemc_st_p_acc ) + deallocate (I_deadstemc_p_acc ) + deallocate (I_deadstemc_st_p_acc ) + deallocate (I_livecrootc_p_acc ) + deallocate (I_livecrootc_st_p_acc ) + deallocate (I_deadcrootc_p_acc ) + deallocate (I_deadcrootc_st_p_acc ) + deallocate (I_grainc_p_acc ) + deallocate (I_grainc_st_p_acc ) + deallocate (I_leafn_p_acc ) + deallocate (I_leafn_st_p_acc ) + deallocate (I_frootn_p_acc ) + deallocate (I_frootn_st_p_acc ) + deallocate (I_livestemn_p_acc ) + deallocate (I_livestemn_st_p_acc ) + deallocate (I_deadstemn_p_acc ) + deallocate (I_deadstemn_st_p_acc ) + deallocate (I_livecrootn_p_acc ) + deallocate (I_livecrootn_st_p_acc ) + deallocate (I_deadcrootn_p_acc ) + deallocate (I_deadcrootn_st_p_acc ) + deallocate (I_grainn_p_acc ) + deallocate (I_grainn_st_p_acc ) + + deallocate (AKX_leafc_xf_to_leafc_p_acc ) + deallocate (AKX_frootc_xf_to_frootc_p_acc ) + deallocate (AKX_livestemc_xf_to_livestemc_p_acc ) + deallocate (AKX_deadstemc_xf_to_deadstemc_p_acc ) + deallocate (AKX_livecrootc_xf_to_livecrootc_p_acc ) + deallocate (AKX_deadcrootc_xf_to_deadcrootc_p_acc ) + deallocate (AKX_grainc_xf_to_grainc_p_acc ) + deallocate (AKX_livestemc_to_deadstemc_p_acc ) + deallocate (AKX_livecrootc_to_deadcrootc_p_acc ) + + deallocate (AKX_leafc_st_to_leafc_xf_p_acc ) + deallocate (AKX_frootc_st_to_frootc_xf_p_acc ) + deallocate (AKX_livestemc_st_to_livestemc_xf_p_acc ) + deallocate (AKX_deadstemc_st_to_deadstemc_xf_p_acc ) + deallocate (AKX_livecrootc_st_to_livecrootc_xf_p_acc ) + deallocate (AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ) + deallocate (AKX_grainc_st_to_grainc_xf_p_acc ) + + deallocate (AKX_leafc_exit_p_acc ) + deallocate (AKX_frootc_exit_p_acc ) + deallocate (AKX_livestemc_exit_p_acc ) + deallocate (AKX_deadstemc_exit_p_acc ) + deallocate (AKX_livecrootc_exit_p_acc ) + deallocate (AKX_deadcrootc_exit_p_acc ) + deallocate (AKX_grainc_exit_p_acc ) + + deallocate (AKX_leafc_st_exit_p_acc ) + deallocate (AKX_frootc_st_exit_p_acc ) + deallocate (AKX_livestemc_st_exit_p_acc ) + deallocate (AKX_deadstemc_st_exit_p_acc ) + deallocate (AKX_livecrootc_st_exit_p_acc ) + deallocate (AKX_deadcrootc_st_exit_p_acc ) + deallocate (AKX_grainc_st_exit_p_acc ) + + deallocate (AKX_leafc_xf_exit_p_acc ) + deallocate (AKX_frootc_xf_exit_p_acc ) + deallocate (AKX_livestemc_xf_exit_p_acc ) + deallocate (AKX_deadstemc_xf_exit_p_acc ) + deallocate (AKX_livecrootc_xf_exit_p_acc ) + deallocate (AKX_deadcrootc_xf_exit_p_acc ) + deallocate (AKX_grainc_xf_exit_p_acc ) + + deallocate (AKX_leafn_xf_to_leafn_p_acc ) + deallocate (AKX_frootn_xf_to_frootn_p_acc ) + deallocate (AKX_livestemn_xf_to_livestemn_p_acc ) + deallocate (AKX_deadstemn_xf_to_deadstemn_p_acc ) + deallocate (AKX_livecrootn_xf_to_livecrootn_p_acc ) + deallocate (AKX_deadcrootn_xf_to_deadcrootn_p_acc ) + deallocate (AKX_grainn_xf_to_grainn_p_acc ) + deallocate (AKX_livestemn_to_deadstemn_p_acc ) + deallocate (AKX_livecrootn_to_deadcrootn_p_acc ) + + deallocate (AKX_leafn_st_to_leafn_xf_p_acc ) + deallocate (AKX_frootn_st_to_frootn_xf_p_acc ) + deallocate (AKX_livestemn_st_to_livestemn_xf_p_acc ) + deallocate (AKX_deadstemn_st_to_deadstemn_xf_p_acc ) + deallocate (AKX_livecrootn_st_to_livecrootn_xf_p_acc ) + deallocate (AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ) + deallocate (AKX_grainn_st_to_grainn_xf_p_acc ) + + deallocate (AKX_leafn_to_retransn_p_acc ) + deallocate (AKX_frootn_to_retransn_p_acc ) + deallocate (AKX_livestemn_to_retransn_p_acc ) + deallocate (AKX_livecrootn_to_retransn_p_acc ) + + deallocate (AKX_retransn_to_leafn_p_acc ) + deallocate (AKX_retransn_to_frootn_p_acc ) + deallocate (AKX_retransn_to_livestemn_p_acc ) + deallocate (AKX_retransn_to_deadstemn_p_acc ) + deallocate (AKX_retransn_to_livecrootn_p_acc ) + deallocate (AKX_retransn_to_deadcrootn_p_acc ) + deallocate (AKX_retransn_to_grainn_p_acc ) + + deallocate (AKX_retransn_to_leafn_st_p_acc ) + deallocate (AKX_retransn_to_frootn_st_p_acc ) + deallocate (AKX_retransn_to_livestemn_st_p_acc ) + deallocate (AKX_retransn_to_deadstemn_st_p_acc ) + deallocate (AKX_retransn_to_livecrootn_st_p_acc ) + deallocate (AKX_retransn_to_deadcrootn_st_p_acc ) + deallocate (AKX_retransn_to_grainn_st_p_acc ) + + deallocate (AKX_leafn_exit_p_acc ) + deallocate (AKX_frootn_exit_p_acc ) + deallocate (AKX_livestemn_exit_p_acc ) + deallocate (AKX_deadstemn_exit_p_acc ) + deallocate (AKX_livecrootn_exit_p_acc ) + deallocate (AKX_deadcrootn_exit_p_acc ) + deallocate (AKX_grainn_exit_p_acc ) + deallocate (AKX_retransn_exit_p_acc ) + + deallocate (AKX_leafn_st_exit_p_acc ) + deallocate (AKX_frootn_st_exit_p_acc ) + deallocate (AKX_livestemn_st_exit_p_acc ) + deallocate (AKX_deadstemn_st_exit_p_acc ) + deallocate (AKX_livecrootn_st_exit_p_acc ) + deallocate (AKX_deadcrootn_st_exit_p_acc ) + deallocate (AKX_grainn_st_exit_p_acc ) + + deallocate (AKX_leafn_xf_exit_p_acc ) + deallocate (AKX_frootn_xf_exit_p_acc ) + deallocate (AKX_livestemn_xf_exit_p_acc ) + deallocate (AKX_deadstemn_xf_exit_p_acc ) + deallocate (AKX_livecrootn_xf_exit_p_acc ) + deallocate (AKX_deadcrootn_xf_exit_p_acc ) + deallocate (AKX_grainn_xf_exit_p_acc ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_BGCPFTimeVariables + +#ifdef RangeCheck + SUBROUTINE check_BGCPFTimeVariables + + USE MOD_RangeCheck + USE MOD_MPAS_MPI + IMPLICIT NONE + +! bgc variables + CALL check_vector_data ('leafc_p ', leafc_p ) + CALL check_vector_data ('leafc_storage_p ', leafc_storage_p ) + CALL check_vector_data ('leafc_xfer_p ', leafc_xfer_p ) + CALL check_vector_data ('frootc_p ', frootc_p ) + CALL check_vector_data ('frootc_storage_p ', frootc_storage_p ) + CALL check_vector_data ('frootc_xfer_p ', frootc_xfer_p ) + CALL check_vector_data ('livestemc_p ', livestemc_p ) + CALL check_vector_data ('livestemc_storage_p ', livestemc_storage_p ) + CALL check_vector_data ('livestemc_xfer_p ', livestemc_xfer_p ) + CALL check_vector_data ('deadstemc_p ', deadstemc_p ) + CALL check_vector_data ('deadstemc_storage_p ', deadstemc_storage_p ) + CALL check_vector_data ('deadstemc_xfer_p ', deadstemc_xfer_p ) + CALL check_vector_data ('livecrootc_p ', livecrootc_p ) + CALL check_vector_data ('livecrootc_storage_p ', livecrootc_storage_p ) + CALL check_vector_data ('livecrootc_xfer_p ', livecrootc_xfer_p ) + CALL check_vector_data ('deadcrootc_p ', deadcrootc_p ) + CALL check_vector_data ('deadcrootc_storage_p ', deadcrootc_storage_p ) + CALL check_vector_data ('deadcrootc_xfer_p ', deadcrootc_xfer_p ) + CALL check_vector_data ('grainc_p ', grainc_p ) + CALL check_vector_data ('grainc_storage_p ', grainc_storage_p ) + CALL check_vector_data ('grainc_xfer_p ', grainc_xfer_p ) + CALL check_vector_data ('cropseedc_deficit_p ', cropseedc_deficit_p ) + CALL check_vector_data ('xsmrpool_p ', xsmrpool_p ) + CALL check_vector_data ('gresp_storage_p ', gresp_storage_p ) + CALL check_vector_data ('gresp_xfer_p ', gresp_xfer_p ) + CALL check_vector_data ('cpool_p ', cpool_p ) + CALL check_vector_data ('totvegc_p ', totvegc_p ) + CALL check_vector_data ('cropprod1c_p ', cropprod1c_p ) + + CALL check_vector_data ('leaf_prof_p ', leaf_prof_p ) + CALL check_vector_data ('froot_prof_p ', froot_prof_p ) + CALL check_vector_data ('croot_prof_p ', croot_prof_p ) + CALL check_vector_data ('stem_prof_p ', stem_prof_p ) + CALL check_vector_data ('cinput_rootfr_p ', cinput_rootfr_p ) + + CALL check_vector_data ('leafn_p ', leafn_p ) + CALL check_vector_data ('leafn_storage_p ', leafn_storage_p ) + CALL check_vector_data ('leafn_xfer_p ', leafn_xfer_p ) + CALL check_vector_data ('frootn_p ', frootn_p ) + CALL check_vector_data ('frootn_storage_p ', frootn_storage_p ) + CALL check_vector_data ('frootn_xfer_p ', frootn_xfer_p ) + CALL check_vector_data ('livestemn_p ', livestemn_p ) + CALL check_vector_data ('livestemn_storage_p ', livestemn_storage_p ) + CALL check_vector_data ('livestemn_xfer_p ', livestemn_xfer_p ) + CALL check_vector_data ('deadstemn_p ', deadstemn_p ) + CALL check_vector_data ('deadstemn_storage_p ', deadstemn_storage_p ) + CALL check_vector_data ('deadstemn_xfer_p ', deadstemn_xfer_p ) + CALL check_vector_data ('livecrootn_p ', livecrootn_p ) + CALL check_vector_data ('livecrootn_storage_p ', livecrootn_storage_p ) + CALL check_vector_data ('livecrootn_xfer_p ', livecrootn_xfer_p ) + CALL check_vector_data ('deadcrootn_p ', deadcrootn_p ) + CALL check_vector_data ('deadcrootn_storage_p ', deadcrootn_storage_p ) + CALL check_vector_data ('deadcrootn_xfer_p ', deadcrootn_xfer_p ) + CALL check_vector_data ('grainn_p ', grainn_p ) + CALL check_vector_data ('grainn_storage_p ', grainn_storage_p ) + CALL check_vector_data ('grainn_xfer_p ', grainn_xfer_p ) + CALL check_vector_data ('cropseedn_deficit_p ', cropseedn_deficit_p ) + CALL check_vector_data ('retransn_p ', retransn_p ) + CALL check_vector_data ('totvegn_p ', totvegn_p ) + + CALL check_vector_data ('harvdate_p ', harvdate_p ) + + CALL check_vector_data ('tempsum_potential_gpp_p', tempsum_potential_gpp_p) + CALL check_vector_data ('tempmax_retransn_p ', tempmax_retransn_p ) + CALL check_vector_data ('tempavg_tref_p ', tempavg_tref_p ) + CALL check_vector_data ('tempsum_npp_p ', tempsum_npp_p ) + CALL check_vector_data ('tempsum_litfall_p ', tempsum_litfall_p ) + CALL check_vector_data ('annsum_potential_gpp_p ', annsum_potential_gpp_p ) + CALL check_vector_data ('annmax_retransn_p ', annmax_retransn_p ) + CALL check_vector_data ('annavg_tref_p ', annavg_tref_p ) + CALL check_vector_data ('annsum_npp_p ', annsum_npp_p ) + CALL check_vector_data ('annsum_litfall_p ', annsum_litfall_p ) + + CALL check_vector_data ('bglfr_p ', bglfr_p ) + CALL check_vector_data ('bgtr_p ', bgtr_p ) + CALL check_vector_data ('lgsf_p ', lgsf_p ) + CALL check_vector_data ('gdd0_p ', gdd0_p ) + CALL check_vector_data ('gdd8_p ', gdd8_p ) + CALL check_vector_data ('gdd10_p ', gdd10_p ) + CALL check_vector_data ('gdd020_p ', gdd020_p ) + CALL check_vector_data ('gdd820_p ', gdd820_p ) + CALL check_vector_data ('gdd1020_p ', gdd1020_p ) + + CALL check_vector_data ('offset_flag_p ', offset_flag_p ) + CALL check_vector_data ('offset_counter_p ', offset_counter_p ) + CALL check_vector_data ('onset_flag_p ', onset_flag_p ) + CALL check_vector_data ('onset_counter_p ', onset_counter_p ) + CALL check_vector_data ('onset_gddflag_p ', onset_gddflag_p ) + CALL check_vector_data ('onset_gdd_p ', onset_gdd_p ) + CALL check_vector_data ('onset_fdd_p ', onset_fdd_p ) + CALL check_vector_data ('onset_swi_p ', onset_swi_p ) + CALL check_vector_data ('offset_fdd_p ', offset_fdd_p ) + CALL check_vector_data ('offset_swi_p ', offset_swi_p ) + CALL check_vector_data ('dormant_flag_p ', dormant_flag_p ) + CALL check_vector_data ('prev_leafc_to_litter_p ', prev_leafc_to_litter_p ) + CALL check_vector_data ('prev_frootc_to_litter_p', prev_frootc_to_litter_p) + CALL check_vector_data ('days_active_p ', days_active_p ) + + CALL check_vector_data ('burndate_p ', burndate_p ) + + CALL check_vector_data ('c_allometry_p ', c_allometry_p ) + CALL check_vector_data ('n_allometry_p ', n_allometry_p ) + CALL check_vector_data ('downreg_p ', downreg_p ) + CALL check_vector_data ('grain_flag_p ', grain_flag_p ) + + CALL check_vector_data ('ctrunc_p ', ctrunc_p ) + CALL check_vector_data ('ntrunc_p ', ntrunc_p ) + CALL check_vector_data ('npool_p ', npool_p ) + +#ifdef CROP +! crop variables + CALL check_vector_data ('hui_p ', hui_p ) + CALL check_vector_data ('gddplant_p ', gddplant_p ) + CALL check_vector_data ('aroot_p ', aroot_p ) + CALL check_vector_data ('astem_p ', astem_p ) + CALL check_vector_data ('arepr_p ', arepr_p ) + CALL check_vector_data ('aleaf_p ', aleaf_p ) + CALL check_vector_data ('astemi_p ', astemi_p ) + CALL check_vector_data ('aleafi_p ', aleafi_p ) + CALL check_vector_data ('gddmaturity_p ', gddmaturity_p ) + + CALL check_vector_data ('a5tmin_p ', a5tmin_p ) + CALL check_vector_data ('a10tmin_p ', a10tmin_p ) + CALL check_vector_data ('t10_p ', t10_p ) + CALL check_vector_data ('cumvd_p ', cumvd_p ) + CALL check_vector_data ('vf_p ', vf_p ) + CALL check_vector_data ('cphase_p ', cphase_p ) + CALL check_vector_data ('fert_counter_p ', fert_counter_p ) + CALL check_vector_data ('tref_min_p ', tref_min_p ) + CALL check_vector_data ('tref_max_p ', tref_max_p ) + CALL check_vector_data ('tref_min_inst_p ', tref_min_inst_p ) + CALL check_vector_data ('tref_max_inst_p ', tref_max_inst_p ) + CALL check_vector_data ('fertnitro_p ', fertnitro_p ) + CALL check_vector_data ('manunitro_p ', manunitro_p ) + CALL check_vector_data ('fert_p ', fert_p ) + CALL check_vector_data ('latbaset_p ', latbaset_p ) + CALL check_vector_data ('plantdate_p ', plantdate_p ) +#endif + + IF(DEF_USE_DiagMatrix)THEN +! SASU variables + CALL check_vector_data ('leafcCap_p ', leafcCap_p ) + CALL check_vector_data ('leafc_storageCap_p ', leafc_storageCap_p ) + CALL check_vector_data ('leafc_xferCap_p ', leafc_xferCap_p ) + CALL check_vector_data ('frootcCap_p ', frootcCap_p ) + CALL check_vector_data ('frootc_storageCap_p ', frootc_storageCap_p ) + CALL check_vector_data ('frootc_xferCap_p ', frootc_xferCap_p ) + CALL check_vector_data ('livestemcCap_p ', livestemcCap_p ) + CALL check_vector_data ('livestemc_storageCap_p ', livestemc_storageCap_p ) + CALL check_vector_data ('livestemc_xferCap_p ', livestemc_xferCap_p ) + CALL check_vector_data ('deadstemcCap_p ', deadstemcCap_p ) + CALL check_vector_data ('deadstemc_storageCap_p ', deadstemc_storageCap_p ) + CALL check_vector_data ('deadstemc_xferCap_p ', deadstemc_xferCap_p ) + CALL check_vector_data ('livecrootcCap_p ', livecrootcCap_p ) + CALL check_vector_data ('livecrootc_storageCap_p ', livecrootc_storageCap_p ) + CALL check_vector_data ('livecrootc_xferCap_p ', livecrootc_xferCap_p ) + CALL check_vector_data ('deadcrootcCap_p ', deadcrootcCap_p ) + CALL check_vector_data ('deadcrootc_storageCap_p ', deadcrootc_storageCap_p ) + CALL check_vector_data ('deadcrootc_xferCap_p ', deadcrootc_xferCap_p ) + + CALL check_vector_data ('leafnCap_p ', leafnCap_p ) + CALL check_vector_data ('leafn_storageCap_p ', leafn_storageCap_p ) + CALL check_vector_data ('leafn_xferCap_p ', leafn_xferCap_p ) + CALL check_vector_data ('frootnCap_p ', frootnCap_p ) + CALL check_vector_data ('frootn_storageCap_p ', frootn_storageCap_p ) + CALL check_vector_data ('frootn_xferCap_p ', frootn_xferCap_p ) + CALL check_vector_data ('livestemnCap_p ', livestemnCap_p ) + CALL check_vector_data ('livestemn_storageCap_p ', livestemn_storageCap_p ) + CALL check_vector_data ('livestemn_xferCap_p ', livestemn_xferCap_p ) + CALL check_vector_data ('deadstemnCap_p ', deadstemnCap_p ) + CALL check_vector_data ('deadstemn_storageCap_p ', deadstemn_storageCap_p ) + CALL check_vector_data ('deadstemn_xferCap_p ', deadstemn_xferCap_p ) + CALL check_vector_data ('livecrootnCap_p ', livecrootnCap_p ) + CALL check_vector_data ('livecrootn_storageCap_p ', livecrootn_storageCap_p ) + CALL check_vector_data ('livecrootn_xferCap_p ', livecrootn_xferCap_p ) + CALL check_vector_data ('deadcrootnCap_p ', deadcrootnCap_p ) + CALL check_vector_data ('deadcrootn_storageCap_p ', deadcrootn_storageCap_p ) + CALL check_vector_data ('deadcrootn_xferCap_p ', deadcrootn_xferCap_p ) + ENDIF + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + CALL check_vector_data ('leafc0_p ', leafc0_p ) + CALL check_vector_data ('leafc0_storage_p ', leafc0_storage_p ) + CALL check_vector_data ('leafc0_xfer_p ', leafc0_xfer_p ) + CALL check_vector_data ('frootc0_p ', frootc0_p ) + CALL check_vector_data ('frootc0_storage_p ', frootc0_storage_p ) + CALL check_vector_data ('frootc0_xfer_p ', frootc0_xfer_p ) + CALL check_vector_data ('livestemc0_p ', livestemc0_p ) + CALL check_vector_data ('livestemc0_storage_p ', livestemc0_storage_p ) + CALL check_vector_data ('livestemc0_xfer_p ', livestemc0_xfer_p ) + CALL check_vector_data ('deadstemc0_p ', deadstemc0_p ) + CALL check_vector_data ('deadstemc0_storage_p ', deadstemc0_storage_p ) + CALL check_vector_data ('deadstemc0_xfer_p ', deadstemc0_xfer_p ) + CALL check_vector_data ('livecrootc0_p ', livecrootc0_p ) + CALL check_vector_data ('livecrootc0_storage_p ', livecrootc0_storage_p ) + CALL check_vector_data ('livecrootc0_xfer_p ', livecrootc0_xfer_p ) + CALL check_vector_data ('deadcrootc0_p ', deadcrootc0_p ) + CALL check_vector_data ('deadcrootc0_storage_p ', deadcrootc0_storage_p ) + CALL check_vector_data ('deadcrootc0_xfer_p ', deadcrootc0_xfer_p ) + CALL check_vector_data ('grainc0_p ', grainc0_p ) + CALL check_vector_data ('grainc0_storage_p ', grainc0_storage_p ) + CALL check_vector_data ('grainc0_xfer_p ', grainc0_xfer_p ) + + CALL check_vector_data ('leafn0_p ', leafn0_p ) + CALL check_vector_data ('leafn0_storage_p ', leafn0_storage_p ) + CALL check_vector_data ('leafn0_xfer_p ', leafn0_xfer_p ) + CALL check_vector_data ('frootn0_p ', frootn0_p ) + CALL check_vector_data ('frootn0_storage_p ', frootn0_storage_p ) + CALL check_vector_data ('frootn0_xfer_p ', frootn0_xfer_p ) + CALL check_vector_data ('livestemn0_p ', livestemn0_p ) + CALL check_vector_data ('livestemn0_storage_p ', livestemn0_storage_p ) + CALL check_vector_data ('livestemn0_xfer_p ', livestemn0_xfer_p ) + CALL check_vector_data ('deadstemn0_p ', deadstemn0_p ) + CALL check_vector_data ('deadstemn0_storage_p ', deadstemn0_storage_p ) + CALL check_vector_data ('deadstemn0_xfer_p ', deadstemn0_xfer_p ) + CALL check_vector_data ('livecrootn0_p ', livecrootn0_p ) + CALL check_vector_data ('livecrootn0_storage_p ', livecrootn0_storage_p ) + CALL check_vector_data ('livecrootn0_xfer_p ', livecrootn0_xfer_p ) + CALL check_vector_data ('deadcrootn0_p ', deadcrootn0_p ) + CALL check_vector_data ('deadcrootn0_storage_p ', deadcrootn0_storage_p ) + CALL check_vector_data ('deadcrootn0_xfer_p ', deadcrootn0_xfer_p ) + CALL check_vector_data ('grainn0_p ', grainn0_p ) + CALL check_vector_data ('grainn0_storage_p ', grainn0_storage_p ) + CALL check_vector_data ('grainn0_xfer_p ', grainn0_xfer_p ) + CALL check_vector_data ('retransn0_p ', retransn0_p ) + + CALL check_vector_data ('I_leafc_p_acc ', I_leafc_p_acc ) + CALL check_vector_data ('I_leafc_st_p_acc ', I_leafc_st_p_acc ) + CALL check_vector_data ('I_frootc_p_acc ', I_frootc_p_acc ) + CALL check_vector_data ('I_frootc_st_p_acc ', I_frootc_st_p_acc ) + CALL check_vector_data ('I_livestemc_p_acc ', I_livestemc_p_acc ) + CALL check_vector_data ('I_livestemc_st_p_acc ', I_livestemc_st_p_acc ) + CALL check_vector_data ('I_deadstemc_p_acc ', I_deadstemc_p_acc ) + CALL check_vector_data ('I_deadstemc_st_p_acc ', I_deadstemc_st_p_acc ) + CALL check_vector_data ('I_livecrootc_p_acc ', I_livecrootc_p_acc ) + CALL check_vector_data ('I_livecrootc_st_p_acc ', I_livecrootc_st_p_acc ) + CALL check_vector_data ('I_deadcrootc_p_acc ', I_deadcrootc_p_acc ) + CALL check_vector_data ('I_deadcrootc_st_p_acc ', I_deadcrootc_st_p_acc ) + CALL check_vector_data ('I_grainc_p_acc ', I_grainc_p_acc ) + CALL check_vector_data ('I_grainc_st_p_acc ', I_grainc_st_p_acc ) + CALL check_vector_data ('I_leafn_p_acc ', I_leafn_p_acc ) + CALL check_vector_data ('I_leafn_st_p_acc ', I_leafn_st_p_acc ) + CALL check_vector_data ('I_frootn_p_acc ', I_frootn_p_acc ) + CALL check_vector_data ('I_frootn_st_p_acc ', I_frootn_st_p_acc ) + CALL check_vector_data ('I_livestemn_p_acc ', I_livestemn_p_acc ) + CALL check_vector_data ('I_livestemn_st_p_acc ', I_livestemn_st_p_acc ) + CALL check_vector_data ('I_deadstemn_p_acc ', I_deadstemn_p_acc ) + CALL check_vector_data ('I_deadstemn_st_p_acc ', I_deadstemn_st_p_acc ) + CALL check_vector_data ('I_livecrootn_p_acc ', I_livecrootn_p_acc ) + CALL check_vector_data ('I_livecrootn_st_p_acc ', I_livecrootn_st_p_acc ) + CALL check_vector_data ('I_deadcrootn_p_acc ', I_deadcrootn_p_acc ) + CALL check_vector_data ('I_deadcrootn_st_p_acc ', I_deadcrootn_st_p_acc ) + CALL check_vector_data ('I_grainn_p_acc ', I_grainn_p_acc ) + CALL check_vector_data ('I_grainn_st_p_acc ', I_grainn_st_p_acc ) + + CALL check_vector_data ('AKX_leafc_xf_to_leafc_p_acc ', AKX_leafc_xf_to_leafc_p_acc ) + CALL check_vector_data ('AKX_frootc_xf_to_frootc_p_acc ', AKX_frootc_xf_to_frootc_p_acc ) + CALL check_vector_data ('AKX_livestemc_xf_to_livestemc_p_acc ', AKX_livestemc_xf_to_livestemc_p_acc ) + CALL check_vector_data ('AKX_deadstemc_xf_to_deadstemc_p_acc ', AKX_deadstemc_xf_to_deadstemc_p_acc ) + CALL check_vector_data ('AKX_livecrootc_xf_to_livecrootc_p_acc ', AKX_livecrootc_xf_to_livecrootc_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_xf_to_deadcrootc_p_acc ', AKX_deadcrootc_xf_to_deadcrootc_p_acc ) + CALL check_vector_data ('AKX_grainc_xf_to_grainc_p_acc ', AKX_grainc_xf_to_grainc_p_acc ) + CALL check_vector_data ('AKX_livestemc_to_deadstemc_p_acc ', AKX_livestemc_to_deadstemc_p_acc ) + CALL check_vector_data ('AKX_livecrootc_to_deadcrootc_p_acc ', AKX_livecrootc_to_deadcrootc_p_acc ) + CALL check_vector_data ('AKX_leafc_st_to_leafc_xf_p_acc ', AKX_leafc_st_to_leafc_xf_p_acc ) + CALL check_vector_data ('AKX_frootc_st_to_frootc_xf_p_acc ', AKX_frootc_st_to_frootc_xf_p_acc ) + CALL check_vector_data ('AKX_livestemc_st_to_livestemc_xf_p_acc ', AKX_livestemc_st_to_livestemc_xf_p_acc ) + CALL check_vector_data ('AKX_deadstemc_st_to_deadstemc_xf_p_acc ', AKX_deadstemc_st_to_deadstemc_xf_p_acc ) + CALL check_vector_data ('AKX_livecrootc_st_to_livecrootc_xf_p_acc ', AKX_livecrootc_st_to_livecrootc_xf_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ', AKX_deadcrootc_st_to_deadcrootc_xf_p_acc ) + CALL check_vector_data ('AKX_grainc_st_to_grainc_xf_p_acc ', AKX_grainc_st_to_grainc_xf_p_acc ) + CALL check_vector_data ('AKX_leafc_exit_p_acc ', AKX_leafc_exit_p_acc ) + CALL check_vector_data ('AKX_frootc_exit_p_acc ', AKX_frootc_exit_p_acc ) + CALL check_vector_data ('AKX_livestemc_exit_p_acc ', AKX_livestemc_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemc_exit_p_acc ', AKX_deadstemc_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootc_exit_p_acc ', AKX_livecrootc_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_exit_p_acc ', AKX_deadcrootc_exit_p_acc ) + CALL check_vector_data ('AKX_grainc_exit_p_acc ', AKX_grainc_exit_p_acc ) + + CALL check_vector_data ('AKX_leafc_st_exit_p_acc ', AKX_leafc_st_exit_p_acc ) + CALL check_vector_data ('AKX_frootc_st_exit_p_acc ', AKX_frootc_st_exit_p_acc ) + CALL check_vector_data ('AKX_livestemc_st_exit_p_acc ', AKX_livestemc_st_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemc_st_exit_p_acc ', AKX_deadstemc_st_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootc_st_exit_p_acc ', AKX_livecrootc_st_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_st_exit_p_acc ', AKX_deadcrootc_st_exit_p_acc ) + CALL check_vector_data ('AKX_grainc_st_exit_p_acc ', AKX_grainc_st_exit_p_acc ) + + CALL check_vector_data ('AKX_leafc_xf_exit_p_acc ', AKX_leafc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_frootc_xf_exit_p_acc ', AKX_frootc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_livestemc_xf_exit_p_acc ', AKX_livestemc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemc_xf_exit_p_acc ', AKX_deadstemc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootc_xf_exit_p_acc ', AKX_livecrootc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootc_xf_exit_p_acc ', AKX_deadcrootc_xf_exit_p_acc ) + CALL check_vector_data ('AKX_grainc_xf_exit_p_acc ', AKX_grainc_xf_exit_p_acc ) + + CALL check_vector_data ('AKX_leafn_xf_to_leafn_p_acc ', AKX_leafn_xf_to_leafn_p_acc ) + CALL check_vector_data ('AKX_frootn_xf_to_frootn_p_acc ', AKX_frootn_xf_to_frootn_p_acc ) + CALL check_vector_data ('AKX_livestemn_xf_to_livestemn_p_acc ', AKX_livestemn_xf_to_livestemn_p_acc ) + CALL check_vector_data ('AKX_deadstemn_xf_to_deadstemn_p_acc ', AKX_deadstemn_xf_to_deadstemn_p_acc ) + CALL check_vector_data ('AKX_livecrootn_xf_to_livecrootn_p_acc ', AKX_livecrootn_xf_to_livecrootn_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_xf_to_deadcrootn_p_acc ', AKX_deadcrootn_xf_to_deadcrootn_p_acc ) + CALL check_vector_data ('AKX_grainn_xf_to_grainn_p_acc ', AKX_grainn_xf_to_grainn_p_acc ) + CALL check_vector_data ('AKX_livestemn_to_deadstemn_p_acc ', AKX_livestemn_to_deadstemn_p_acc ) + CALL check_vector_data ('AKX_livecrootn_to_deadcrootn_p_acc ', AKX_livecrootn_to_deadcrootn_p_acc ) + + CALL check_vector_data ('AKX_leafn_st_to_leafn_xf_p_acc ', AKX_leafn_st_to_leafn_xf_p_acc ) + CALL check_vector_data ('AKX_frootn_st_to_frootn_xf_p_acc ', AKX_frootn_st_to_frootn_xf_p_acc ) + CALL check_vector_data ('AKX_livestemn_st_to_livestemn_xf_p_acc ', AKX_livestemn_st_to_livestemn_xf_p_acc ) + CALL check_vector_data ('AKX_deadstemn_st_to_deadstemn_xf_p_acc ', AKX_deadstemn_st_to_deadstemn_xf_p_acc ) + CALL check_vector_data ('AKX_livecrootn_st_to_livecrootn_xf_p_acc ', AKX_livecrootn_st_to_livecrootn_xf_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ', AKX_deadcrootn_st_to_deadcrootn_xf_p_acc ) + CALL check_vector_data ('AKX_grainn_st_to_grainn_xf_p_acc ', AKX_grainn_st_to_grainn_xf_p_acc ) + + CALL check_vector_data ('AKX_leafn_to_retransn_p_acc ', AKX_leafn_to_retransn_p_acc ) + CALL check_vector_data ('AKX_frootn_to_retransn_p_acc ', AKX_frootn_to_retransn_p_acc ) + CALL check_vector_data ('AKX_livestemn_to_retransn_p_acc ', AKX_livestemn_to_retransn_p_acc ) + CALL check_vector_data ('AKX_livecrootn_to_retransn_p_acc ', AKX_livecrootn_to_retransn_p_acc ) + + CALL check_vector_data ('AKX_retransn_to_leafn_p_acc ', AKX_retransn_to_leafn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_frootn_p_acc ', AKX_retransn_to_frootn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_livestemn_p_acc ', AKX_retransn_to_livestemn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_deadstemn_p_acc ', AKX_retransn_to_deadstemn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_livecrootn_p_acc ', AKX_retransn_to_livecrootn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_deadcrootn_p_acc ', AKX_retransn_to_deadcrootn_p_acc ) + CALL check_vector_data ('AKX_retransn_to_grainn_p_acc ', AKX_retransn_to_grainn_p_acc ) + + CALL check_vector_data ('AKX_retransn_to_leafn_st_p_acc ', AKX_retransn_to_leafn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_frootn_st_p_acc ', AKX_retransn_to_frootn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_livestemn_st_p_acc ', AKX_retransn_to_livestemn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_deadstemn_st_p_acc ', AKX_retransn_to_deadstemn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_livecrootn_st_p_acc ', AKX_retransn_to_livecrootn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_deadcrootn_st_p_acc ', AKX_retransn_to_deadcrootn_st_p_acc ) + CALL check_vector_data ('AKX_retransn_to_grainn_st_p_acc ', AKX_retransn_to_grainn_st_p_acc ) + + CALL check_vector_data ('AKX_leafn_exit_p_acc ', AKX_leafn_exit_p_acc ) + CALL check_vector_data ('AKX_frootn_exit_p_acc ', AKX_frootn_exit_p_acc ) + CALL check_vector_data ('AKX_livestemn_exit_p_acc ', AKX_livestemn_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemn_exit_p_acc ', AKX_deadstemn_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootn_exit_p_acc ', AKX_livecrootn_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_exit_p_acc ', AKX_deadcrootn_exit_p_acc ) + CALL check_vector_data ('AKX_grainn_exit_p_acc ', AKX_grainn_exit_p_acc ) + CALL check_vector_data ('AKX_retransn_exit_p_acc ', AKX_retransn_exit_p_acc ) + + CALL check_vector_data ('AKX_leafn_st_exit_p_acc ', AKX_leafn_st_exit_p_acc ) + CALL check_vector_data ('AKX_frootn_st_exit_p_acc ', AKX_frootn_st_exit_p_acc ) + CALL check_vector_data ('AKX_livestemn_st_exit_p_acc ', AKX_livestemn_st_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemn_st_exit_p_acc ', AKX_deadstemn_st_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootn_st_exit_p_acc ', AKX_livecrootn_st_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_st_exit_p_acc ', AKX_deadcrootn_st_exit_p_acc ) + CALL check_vector_data ('AKX_grainn_st_exit_p_acc ', AKX_grainn_st_exit_p_acc ) + + CALL check_vector_data ('AKX_leafn_xf_exit_p_acc ', AKX_leafn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_frootn_xf_exit_p_acc ', AKX_frootn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_livestemn_xf_exit_p_acc ', AKX_livestemn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_deadstemn_xf_exit_p_acc ', AKX_deadstemn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_livecrootn_xf_exit_p_acc ', AKX_livecrootn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_deadcrootn_xf_exit_p_acc ', AKX_deadcrootn_xf_exit_p_acc ) + CALL check_vector_data ('AKX_grainn_xf_exit_p_acc ', AKX_grainn_xf_exit_p_acc ) + ENDIF + END SUBROUTINE check_BGCPFTimeVariables +#endif + +#endif +END MODULE MOD_BGC_Vars_PFTimeVariables + +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 new file mode 100644 index 0000000000..2a892bc798 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeInvariants.F90 @@ -0,0 +1,512 @@ +#include + +MODULE MOD_BGC_Vars_TimeInvariants + +! -------------------------------------------------------------------- + +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical constant at patch level. +! Read and write biogeochemical constant at patch level from/to restart files. + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version +! ------------------------------- +#ifdef BGC + + USE MOD_Precision + IMPLICIT NONE + SAVE +!------------------------- BGC constant -------------------------------------- + integer , allocatable :: donor_pool (:) ! soil or litter pools where each decomposition transfered C&N is from. + integer , allocatable :: receiver_pool (:) ! soil or litter pools where each decomposition transfered C&N is to + real(r8) :: am ! gap-mortality rate constant (year-1) + logical , allocatable :: floating_cn_ratio(:) ! flag, soil or litter pool has 1) true: flexible or 2) false: fixed C:N ratio. + real(r8), allocatable :: initial_cn_ratio (:) ! initial c:n ratio of each litter and soil pool + real(r8), allocatable :: rf_decomp (:,:,:) ! respiratory fraction of the ith transfer hr(i) / (hr(i) + ctransfer(i)) + real(r8), allocatable :: pathfrac_decomp (:,:,:) ! pathway fraction of each transfer from the same donor pool & + ! (hr(i)+ctransfer(i))/sum(hr(donor_pool(:)==donor_pool(i))+ctransfer(donor_pool(:)==donor_pool(i))) + + integer :: i_met_lit ! index of metabolic litter pool + integer :: i_cel_lit ! index of cellulose litter pool + integer :: i_lig_lit ! index of lignin litter pool + integer :: i_cwd ! index of coarse woody debris pool + integer :: i_soil1 ! index of active soil organic matter pool + integer :: i_soil2 ! index of slow soil organic matter pool + integer :: i_soil3 ! index of passive soil organic matter pool + integer :: i_atm ! index of atmosphere pool + + logical , allocatable :: is_cwd (:) ! (1:ndecomp_pools) ! True => is a coarse woody debris pool + logical , allocatable :: is_litter (:) ! (1:ndecomp_pools) ! True => is a litter pool + logical , allocatable :: is_soil (:) ! (1:ndecomp_pools) ! True => is a soil pool + + real(r8), allocatable :: gdp_lf (:) ! gdp data + real(r8), allocatable :: abm_lf (:) ! prescribed crop fire time + real(r8), allocatable :: peatf_lf (:) ! peatland fraction data + real(r8), allocatable :: cmb_cmplt_fact(:) ! combustion completion factor + integer , allocatable :: rice2pdt (:) ! rice2 planting date + + real(r8) :: nitrif_n2o_loss_frac ! fraction of N lost as N2O in nitrification (unitless) + real(r8) :: dnp ! denitrification proportion (unitless) + real(r8) :: bdnr ! bulk denitrification rate (1/day) + real(r8) :: compet_plant_no3 ! relative compettiveness of plants for NO3 (unitless) + real(r8) :: compet_plant_nh4 ! relative compettiveness of plants for NH4 (unitless) + real(r8) :: compet_decomp_no3 ! relative competitiveness of immobilizers for NO3 (unitless) + real(r8) :: compet_decomp_nh4 ! relative competitiveness of immobilizers for NH4 (unitless) + real(r8) :: compet_denit ! relative competitiveness of denitrifiers for NO3 (unitless) + real(r8) :: compet_nit ! relative competitiveness of nitrifiers for NH4 (unitless) + real(r8) :: surface_tension_water ! surface tension of water (J m-2) + real(r8) :: rij_kro_a ! parameters for calculation of anoxic fraction of soil + real(r8) :: rij_kro_alpha ! parameters for calculation of anoxic fraction of soil + real(r8) :: rij_kro_beta ! parameters for calculation of anoxic fraction of soil + real(r8) :: rij_kro_gamma ! parameters for calculation of anoxic fraction of soil + real(r8) :: rij_kro_delta ! parameters for calculation of anoxic fraction of soil + real(r8) :: nfix_timeconst ! timescale for smoothing npp in N fixation term + real(r8) :: organic_max ! organic matter content (kg m-3) where soil is assumed to act like peat + real(r8) :: d_con_g21 ! O2 diffusivity constants in gas (cm2 s-1) + real(r8) :: d_con_g22 ! O2 diffusivity constants in gas (cm2 s-1) + real(r8) :: d_con_w21 ! O2 diffusivity constants in water (cm2 s-1) + real(r8) :: d_con_w22 ! O2 diffusivity constants in water (cm2 s-1) + real(r8) :: d_con_w23 ! O2 diffusivity constants in water (cm2 s-1) + real(r8) :: denit_resp_coef ! coefficient for maximum N denitrification rate based on respiration + real(r8) :: denit_resp_exp ! exponent for maximum N denitrification rate based on respiration + real(r8) :: denit_nitrate_coef ! coefficient for maximum N denitrification rate based on nitrate concentration + real(r8) :: denit_nitrate_exp ! exponent for maximum N denitrification rate based on nitrate concentration + real(r8) :: k_nitr_max ! maximum N nitrification rate (day-1) + real(r8) :: Q10 ! respiration rate increments when temperature rising 10 degree C + real(r8) :: froz_q10 ! respiration rate increments when temperature rising 10 degree C for frozen soil + real(r8) :: tau_l1 ! baseline turnover rate of metabolic litter from Century (year-1) + real(r8) :: tau_l2_l3 ! baseline turnover rate of cellulose litter and lignin litter from Century (year-1) + real(r8) :: tau_s1 ! baseline turnover rate of active soil organic matter from Century (year-1) + real(r8) :: tau_s2 ! baseline turnover rate of slow soil organic matter from Century (year-1) + real(r8) :: tau_s3 ! baseline turnover rate of passive soil organic matter from Century (year-1) + real(r8) :: tau_cwd ! baseline turnover rate of CWD (year-1) + real(r8) :: lwtop ! live wood turnover proportion + + real(r8) :: som_adv_flux ! the advection term in soil organic matter mixing + real(r8) :: som_diffus ! the diffusion term in soil organic matter mixing + real(r8) :: cryoturb_diffusion_k ! the cryoturbation diffusive constant cryoturbation to the active layer thickness (m2 s-1) + real(r8) :: max_altdepth_cryoturbation ! maximum active layer thickness for cryoturbation to occur (m) + real(r8) :: max_depth_cryoturb ! the maximum depth of cryoturbation (m) + + real(r8) :: br ! basal maintenance respiration rate for aboveground biomass (gC gN-1 s-1) + real(r8) :: br_root ! basal maintenance respiration rate for belowground biomass (gC gN-1 s-1) + real(r8) :: fstor2tran ! fraction of storage to transfer pool at each onset event + real(r8) :: ndays_on ! number of days to complete leaf onset + real(r8) :: ndays_off ! number of days to complete leaf offset + real(r8) :: crit_dayl ! critical day length for senescence (s) + real(r8) :: crit_onset_fdd ! critical number of freezing days to begin gdd accumulation + real(r8) :: crit_onset_swi ! critical number of days exceeding soil water potential threshold to initiate onset + real(r8) :: crit_offset_fdd ! critical number of freezing days to initiate offset + real(r8) :: crit_offset_swi ! critical number of days below soil water potential threshold to initiate offset + real(r8) :: soilpsi_on ! critical soil water potential threshold for onset + real(r8) :: soilpsi_off ! critical soil water potential threshold for offset + + real(r8) :: occur_hi_gdp_tree ! fire occurance for high GDP areas that are tree dominated (fraction) + real(r8) :: lfuel ! lower threshold of fuel mass (gC/m2) for ignition, Li et al.(2014) + real(r8) :: ufuel ! upper threshold of fuel mass (gC/m2) for ignition, Li et al.(2014) + real(r8) :: cropfire_a1 ! a1 parameter for cropland fire in (Li et. al., 2014) (1/hr) + real(r8) :: borealat ! Latitude bound for boreal peat fires + real(r8) :: troplat ! Latitude bound for tropical + real(r8) :: non_boreal_peatfire_c ! c parameter for non-boreal peatland fire in Li et. al. (2013) (1/hr) + real(r8) :: boreal_peatfire_c ! c parameter for boreal peatland fire in Li et. al. (2013) (/hr) + real(r8) :: rh_low ! parameter for lower relative humidity on fire (%) + real(r8) :: rh_hgh ! parameter for higher relative humidity on fire (%) + real(r8) :: bt_min ! minimum water stress factor + real(r8) :: bt_max ! maximum water stress factor + real(r8) :: pot_hmn_ign_counts_alpha ! Potential human ignition counts (alpha in Li et. al. 2012) (1/person/month) + real(r8) :: g0_fire ! constant for fire spread estimates + + real(r8) :: sf ! soluble fraction of mineral N (unitless) + real(r8) :: sf_no3 ! soluble fraction of NO3 (unitless) + +!----------------------------------- END BGC constants ----------------- + + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_BGCTimeInvariants + PUBLIC :: deallocate_BGCTimeInvariants + PUBLIC :: READ_BGCTimeInvariants + PUBLIC :: WRITE_BGCTimeInvariants + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_BGCTimeInvariants () + ! -------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global, only: nl_soil, ndecomp_transitions, ndecomp_pools, spval_i4, spval + USE MOD_MPAS_MPI + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + IF (.true.) THEN + + IF (numpatch > 0) THEN + ! bgc variables + allocate (donor_pool (ndecomp_transitions)) ; donor_pool (:) = spval_i4 + allocate (receiver_pool (ndecomp_transitions)) ; receiver_pool (:) = spval_i4 + allocate (floating_cn_ratio (ndecomp_pools)) ; floating_cn_ratio (:) = .false. + allocate (initial_cn_ratio (ndecomp_pools)) ; initial_cn_ratio (:) = spval + allocate (rf_decomp (nl_soil,ndecomp_transitions,numpatch)) ; rf_decomp (:,:,:) = spval + allocate (pathfrac_decomp (nl_soil,ndecomp_transitions,numpatch)) ; pathfrac_decomp(:,:,:) = spval + allocate (is_cwd (ndecomp_pools)) ; is_cwd (:) = .false. ! True => is a coarse woody debris pool + allocate (is_litter (ndecomp_pools)) ; is_litter (:) = .false. ! True => is a litter pool + allocate (is_soil (ndecomp_pools)) ; is_soil (:) = .false. ! True => is a soil pool + allocate (gdp_lf (numpatch)) ; gdp_lf (:) = spval + allocate (abm_lf (numpatch)) ; abm_lf (:) = spval + allocate (peatf_lf (numpatch)) ; peatf_lf (:) = spval + allocate (cmb_cmplt_fact (2)) ; cmb_cmplt_fact (:) = spval + allocate (rice2pdt (numpatch)) ; rice2pdt (:) = spval_i4 + + ! END bgc variables + ENDIF + ENDIF + + END SUBROUTINE allocate_BGCTimeInvariants + + !--------------------------------------- + SUBROUTINE READ_BGCTimeInvariants (file_restart) + + !======================================================================= + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !======================================================================= + + USE MOD_Namelist + USE MOD_MPAS_MPI + USE MOD_NetCDFVector + USE MOD_NetCDFSerial +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + +! bgc constants + CALL ncio_read_bcast_serial (file_restart, 'donor_pool ', donor_pool ) + CALL ncio_read_bcast_serial (file_restart, 'receiver_pool ', receiver_pool ) + CALL ncio_read_bcast_serial (file_restart, 'floating_cn_ratio', floating_cn_ratio) + CALL ncio_read_bcast_serial (file_restart, 'initial_cn_ratio' , initial_cn_ratio) + CALL ncio_read_vector (file_restart, 'rf_decomp ', nl_soil,ndecomp_transitions,landpatch, rf_decomp ) + CALL ncio_read_vector (file_restart, 'pathfrac_decomp ', nl_soil,ndecomp_transitions,landpatch,pathfrac_decomp ) + + CALL ncio_read_bcast_serial (file_restart, 'i_met_lit ', i_met_lit ) + CALL ncio_read_bcast_serial (file_restart, 'i_cel_lit ', i_cel_lit ) + CALL ncio_read_bcast_serial (file_restart, 'i_lig_lit ', i_lig_lit ) + CALL ncio_read_bcast_serial (file_restart, 'i_cwd ', i_cwd ) + CALL ncio_read_bcast_serial (file_restart, 'i_soil1 ', i_soil1 ) + CALL ncio_read_bcast_serial (file_restart, 'i_soil2 ', i_soil2 ) + CALL ncio_read_bcast_serial (file_restart, 'i_soil3 ', i_soil3 ) + CALL ncio_read_bcast_serial (file_restart, 'i_atm ', i_atm ) + CALL ncio_read_bcast_serial (file_restart, 'is_cwd ', is_cwd ) + CALL ncio_read_bcast_serial (file_restart, 'is_litter ', is_litter ) + CALL ncio_read_bcast_serial (file_restart, 'is_soil ', is_soil ) + + ! CALL ncio_read_vector (file_restart, 'gdp_lf ', landpatch, gdp_lf ) + ! CALL ncio_read_vector (file_restart, 'abm_lf ', landpatch, abm_lf ) + ! CALL ncio_read_vector (file_restart, 'peatf_lf ', landpatch, peatf_lf ) + CALL ncio_read_bcast_serial (file_restart, 'cmb_cmplt_fact ', cmb_cmplt_fact ) + CALL ncio_read_vector (file_restart, 'rice2pdt ', landpatch, rice2pdt ) + + CALL ncio_read_bcast_serial (file_restart, 'nitrif_n2o_loss_frac', nitrif_n2o_loss_frac) + CALL ncio_read_bcast_serial (file_restart, 'dnp ', dnp )! + CALL ncio_read_bcast_serial (file_restart, 'bdnr ', bdnr )! + CALL ncio_read_bcast_serial (file_restart, 'compet_plant_no3 ', compet_plant_no3 )! + CALL ncio_read_bcast_serial (file_restart, 'compet_plant_nh4 ', compet_plant_nh4 )! + CALL ncio_read_bcast_serial (file_restart, 'compet_decomp_no3 ', compet_decomp_no3 )! + CALL ncio_read_bcast_serial (file_restart, 'compet_decomp_nh4 ', compet_decomp_nh4 )! + CALL ncio_read_bcast_serial (file_restart, 'compet_denit ', compet_denit )! + CALL ncio_read_bcast_serial (file_restart, 'compet_nit ', compet_nit )! + CALL ncio_read_bcast_serial (file_restart, 'surface_tension_water',surface_tension_water) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_a ', rij_kro_a ) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_alpha ', rij_kro_alpha ) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_beta ', rij_kro_beta ) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_gamma ', rij_kro_gamma ) + CALL ncio_read_bcast_serial (file_restart, 'rij_kro_delta ', rij_kro_delta ) + CALL ncio_read_bcast_serial (file_restart, 'nfix_timeconst ', nfix_timeconst ) + CALL ncio_read_bcast_serial (file_restart, 'organic_max ', organic_max ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_g21 ', d_con_g21 ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_g22 ', d_con_g22 ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_w21 ', d_con_w21 ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_w22 ', d_con_w22 ) + CALL ncio_read_bcast_serial (file_restart, 'd_con_w23 ', d_con_w23 ) + CALL ncio_read_bcast_serial (file_restart, 'denit_resp_coef ', denit_resp_coef ) + CALL ncio_read_bcast_serial (file_restart, 'denit_resp_exp ', denit_resp_exp ) + CALL ncio_read_bcast_serial (file_restart, 'denit_nitrate_coef ', denit_nitrate_coef ) + CALL ncio_read_bcast_serial (file_restart, 'denit_nitrate_exp ', denit_nitrate_exp )! + CALL ncio_read_bcast_serial (file_restart, 'k_nitr_max ', k_nitr_max )! + CALL ncio_read_bcast_serial (file_restart, 'Q10 ', Q10 )! + CALL ncio_read_bcast_serial (file_restart, 'froz_q10 ', froz_q10 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_l1 ', tau_l1 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_l2_l3 ', tau_l2_l3 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_s1 ', tau_s1 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_s2 ', tau_s2 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_s3 ', tau_s3 )! + CALL ncio_read_bcast_serial (file_restart, 'tau_cwd ', tau_cwd ) + CALL ncio_read_bcast_serial (file_restart, 'lwtop ', lwtop ) + + CALL ncio_read_bcast_serial (file_restart, 'som_adv_flux ', som_adv_flux ) + CALL ncio_read_bcast_serial (file_restart, 'som_diffus ', som_diffus ) + CALL ncio_read_bcast_serial (file_restart, 'cryoturb_diffusion_k', cryoturb_diffusion_k) + CALL ncio_read_bcast_serial (file_restart, 'max_altdepth_cryoturbation', max_altdepth_cryoturbation) + CALL ncio_read_bcast_serial (file_restart, 'max_depth_cryoturb ', max_depth_cryoturb ) + + CALL ncio_read_bcast_serial (file_restart, 'am ', am ) + CALL ncio_read_bcast_serial (file_restart, 'br ', br ) + CALL ncio_read_bcast_serial (file_restart, 'br_root ', br_root ) + CALL ncio_read_bcast_serial (file_restart, 'fstor2tran ', fstor2tran ) + CALL ncio_read_bcast_serial (file_restart, 'ndays_on ', ndays_on ) + CALL ncio_read_bcast_serial (file_restart, 'ndays_off ', ndays_off ) + CALL ncio_read_bcast_serial (file_restart, 'crit_dayl ', crit_dayl ) + CALL ncio_read_bcast_serial (file_restart, 'crit_onset_fdd ', crit_onset_fdd ) + CALL ncio_read_bcast_serial (file_restart, 'crit_onset_swi ', crit_onset_swi ) + CALL ncio_read_bcast_serial (file_restart, 'crit_offset_fdd ', crit_offset_fdd ) + CALL ncio_read_bcast_serial (file_restart, 'crit_offset_swi ', crit_offset_swi ) + CALL ncio_read_bcast_serial (file_restart, 'soilpsi_on ', soilpsi_on ) + CALL ncio_read_bcast_serial (file_restart, 'soilpsi_off ', soilpsi_off ) + + CALL ncio_read_bcast_serial (file_restart, 'occur_hi_gdp_tree ', occur_hi_gdp_tree ) + CALL ncio_read_bcast_serial (file_restart, 'lfuel ', lfuel ) + CALL ncio_read_bcast_serial (file_restart, 'ufuel ', ufuel ) + CALL ncio_read_bcast_serial (file_restart, 'cropfire_a1 ', cropfire_a1 ) + CALL ncio_read_bcast_serial (file_restart, 'borealat ', borealat ) + CALL ncio_read_bcast_serial (file_restart, 'troplat ', troplat ) + CALL ncio_read_bcast_serial (file_restart, 'non_boreal_peatfire_c', non_boreal_peatfire_c) + CALL ncio_read_bcast_serial (file_restart, 'boreal_peatfire_c ', boreal_peatfire_c ) + CALL ncio_read_bcast_serial (file_restart, 'rh_low ', rh_low ) + CALL ncio_read_bcast_serial (file_restart, 'rh_hgh ', rh_hgh ) + CALL ncio_read_bcast_serial (file_restart, 'bt_min ', bt_min ) + CALL ncio_read_bcast_serial (file_restart, 'bt_max ', bt_max ) + CALL ncio_read_bcast_serial (file_restart, 'pot_hmn_ign_counts_alpha', pot_hmn_ign_counts_alpha) + CALL ncio_read_bcast_serial (file_restart, 'g0_fire', g0_fire) + + CALL ncio_read_bcast_serial (file_restart, 'sf', sf) + CALL ncio_read_bcast_serial (file_restart, 'sf_no3', sf_no3) + +#ifdef RangeCheck + CALL check_BGCTimeInvariants () +#endif + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) +#endif + + END SUBROUTINE READ_BGCTimeInvariants + + !--------------------------------------- + SUBROUTINE WRITE_BGCTimeInvariants (file_restart) + + !======================================================================= + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !======================================================================= + + USE MOD_Namelist, only: DEF_REST_CompressLevel + USE MOD_MPAS_MPI + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local Variables + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landpatch) + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'ndecomp_transitions',ndecomp_transitions) + + CALL ncio_write_vector (file_restart, 'rf_decomp ', 'soil' , nl_soil , & + 'ndecomp_transitions', ndecomp_transitions,'patch', landpatch, rf_decomp , compress) + CALL ncio_write_vector (file_restart, 'pathfrac_decomp', 'soil' , nl_soil , & + 'ndecomp_transitions', ndecomp_transitions,'patch', landpatch, pathfrac_decomp, compress) + ! CALL ncio_write_vector (file_restart, 'gdp_lf ', 'patch', landpatch, gdp_lf , compress) + ! CALL ncio_write_vector (file_restart, 'abm_lf ', 'patch', landpatch, abm_lf , compress) + ! CALL ncio_write_vector (file_restart, 'peatf_lf ', 'patch', landpatch, peatf_lf , compress) + CALL ncio_write_vector (file_restart, 'rice2pdt ', 'patch', landpatch, rice2pdt , compress) + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) +#endif + + IF (mpas_is_root) THEN + +#if (!defined(VectorInOneFileS) && !defined(VectorInOneFileP)) + CALL ncio_create_file (file_restart) +#endif + CALL ncio_define_dimension(file_restart, 'ndecomp_transitions',ndecomp_transitions) + CALL ncio_define_dimension(file_restart, 'ndecomp_pools' ,ndecomp_pools) + CALL ncio_define_dimension(file_restart, 'nlitter_fire' ,2 ) + + ! bgc constants + CALL ncio_write_serial (file_restart, 'donor_pool ' , donor_pool , 'ndecomp_transitions') + CALL ncio_write_serial (file_restart, 'receiver_pool ' , receiver_pool , 'ndecomp_transitions') + CALL ncio_write_serial (file_restart, 'floating_cn_ratio', floating_cn_ratio, 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'initial_cn_ratio' , initial_cn_ratio , 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'is_cwd ' , is_cwd , 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'is_litter ' , is_litter , 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'is_soil ' , is_soil , 'ndecomp_pools') + CALL ncio_write_serial (file_restart, 'cmb_cmplt_fact ' , cmb_cmplt_fact , 'nlitter_fire' ) + + CALL ncio_write_serial (file_restart, 'i_met_lit ', i_met_lit ) + CALL ncio_write_serial (file_restart, 'i_cel_lit ', i_cel_lit ) + CALL ncio_write_serial (file_restart, 'i_lig_lit ', i_lig_lit ) + CALL ncio_write_serial (file_restart, 'i_cwd ', i_cwd ) + CALL ncio_write_serial (file_restart, 'i_soil1 ', i_soil1 ) + CALL ncio_write_serial (file_restart, 'i_soil2 ', i_soil2 ) + CALL ncio_write_serial (file_restart, 'i_soil3 ', i_soil3 ) + CALL ncio_write_serial (file_restart, 'i_atm ', i_atm ) + + + CALL ncio_write_serial (file_restart, 'nitrif_n2o_loss_frac', nitrif_n2o_loss_frac) + CALL ncio_write_serial (file_restart, 'dnp ', dnp )! + CALL ncio_write_serial (file_restart, 'bdnr ', bdnr )! + CALL ncio_write_serial (file_restart, 'compet_plant_no3 ', compet_plant_no3 )! + CALL ncio_write_serial (file_restart, 'compet_plant_nh4 ', compet_plant_nh4 )! + CALL ncio_write_serial (file_restart, 'compet_decomp_no3 ', compet_decomp_no3 )! + CALL ncio_write_serial (file_restart, 'compet_decomp_nh4 ', compet_decomp_nh4 )! + CALL ncio_write_serial (file_restart, 'compet_denit ', compet_denit )! + CALL ncio_write_serial (file_restart, 'compet_nit ', compet_nit )! + CALL ncio_write_serial (file_restart, 'surface_tension_water',surface_tension_water) + CALL ncio_write_serial (file_restart, 'rij_kro_a ', rij_kro_a ) + CALL ncio_write_serial (file_restart, 'rij_kro_alpha ', rij_kro_alpha ) + CALL ncio_write_serial (file_restart, 'rij_kro_beta ', rij_kro_beta ) + CALL ncio_write_serial (file_restart, 'rij_kro_gamma ', rij_kro_gamma ) + CALL ncio_write_serial (file_restart, 'rij_kro_delta ', rij_kro_delta ) + CALL ncio_write_serial (file_restart, 'nfix_timeconst ', nfix_timeconst ) + CALL ncio_write_serial (file_restart, 'organic_max ', organic_max ) + CALL ncio_write_serial (file_restart, 'd_con_g21 ', d_con_g21 ) + CALL ncio_write_serial (file_restart, 'd_con_g22 ', d_con_g22 ) + CALL ncio_write_serial (file_restart, 'd_con_w21 ', d_con_w21 ) + CALL ncio_write_serial (file_restart, 'd_con_w22 ', d_con_w22 ) + CALL ncio_write_serial (file_restart, 'd_con_w23 ', d_con_w23 ) + CALL ncio_write_serial (file_restart, 'denit_resp_coef ', denit_resp_coef ) + CALL ncio_write_serial (file_restart, 'denit_resp_exp ', denit_resp_exp ) + CALL ncio_write_serial (file_restart, 'denit_nitrate_coef ', denit_nitrate_coef ) + CALL ncio_write_serial (file_restart, 'denit_nitrate_exp ', denit_nitrate_exp )! + CALL ncio_write_serial (file_restart, 'k_nitr_max ', k_nitr_max )! + CALL ncio_write_serial (file_restart, 'Q10 ', Q10 )! + CALL ncio_write_serial (file_restart, 'froz_q10 ', froz_q10 )! + CALL ncio_write_serial (file_restart, 'tau_l1 ', tau_l1 )! + CALL ncio_write_serial (file_restart, 'tau_l2_l3 ', tau_l2_l3 )! + CALL ncio_write_serial (file_restart, 'tau_s1 ', tau_s1 )! + CALL ncio_write_serial (file_restart, 'tau_s2 ', tau_s2 )! + CALL ncio_write_serial (file_restart, 'tau_s3 ', tau_s3 )! + CALL ncio_write_serial (file_restart, 'tau_cwd ', tau_cwd ) + CALL ncio_write_serial (file_restart, 'lwtop ', lwtop ) + + CALL ncio_write_serial (file_restart, 'som_adv_flux ', som_adv_flux ) + CALL ncio_write_serial (file_restart, 'som_diffus ', som_diffus ) + CALL ncio_write_serial (file_restart, 'cryoturb_diffusion_k', cryoturb_diffusion_k) + CALL ncio_write_serial (file_restart, 'max_altdepth_cryoturbation', max_altdepth_cryoturbation) + CALL ncio_write_serial (file_restart, 'max_depth_cryoturb ', max_depth_cryoturb ) + + CALL ncio_write_serial (file_restart, 'am ', am ) + CALL ncio_write_serial (file_restart, 'br ', br ) + CALL ncio_write_serial (file_restart, 'br_root ', br_root ) + CALL ncio_write_serial (file_restart, 'fstor2tran ', fstor2tran ) + CALL ncio_write_serial (file_restart, 'ndays_on ', ndays_on ) + CALL ncio_write_serial (file_restart, 'ndays_off ', ndays_off ) + CALL ncio_write_serial (file_restart, 'crit_dayl ', crit_dayl ) + CALL ncio_write_serial (file_restart, 'crit_onset_fdd ', crit_onset_fdd ) + CALL ncio_write_serial (file_restart, 'crit_onset_swi ', crit_onset_swi ) + CALL ncio_write_serial (file_restart, 'crit_offset_fdd ', crit_offset_fdd ) + CALL ncio_write_serial (file_restart, 'crit_offset_swi ', crit_offset_swi ) + CALL ncio_write_serial (file_restart, 'soilpsi_on ', soilpsi_on ) + CALL ncio_write_serial (file_restart, 'soilpsi_off ', soilpsi_off ) + + CALL ncio_write_serial (file_restart, 'occur_hi_gdp_tree ', occur_hi_gdp_tree ) + CALL ncio_write_serial (file_restart, 'lfuel ', lfuel ) + CALL ncio_write_serial (file_restart, 'ufuel ', ufuel ) + CALL ncio_write_serial (file_restart, 'cropfire_a1 ', cropfire_a1 ) + CALL ncio_write_serial (file_restart, 'borealat ', borealat ) + CALL ncio_write_serial (file_restart, 'troplat ', troplat ) + CALL ncio_write_serial (file_restart, 'non_boreal_peatfire_c', non_boreal_peatfire_c) + CALL ncio_write_serial (file_restart, 'boreal_peatfire_c ', boreal_peatfire_c ) + CALL ncio_write_serial (file_restart, 'rh_low ', rh_low ) + CALL ncio_write_serial (file_restart, 'rh_hgh ', rh_hgh ) + CALL ncio_write_serial (file_restart, 'bt_min ', bt_min ) + CALL ncio_write_serial (file_restart, 'bt_max ', bt_max ) + CALL ncio_write_serial (file_restart, 'pot_hmn_ign_counts_alpha', pot_hmn_ign_counts_alpha) + CALL ncio_write_serial (file_restart, 'g0_fire', g0_fire) + + CALL ncio_write_serial (file_restart, 'sf', sf) + CALL ncio_write_serial (file_restart, 'sf_no3', sf_no3) + + ENDIF + + END SUBROUTINE WRITE_BGCTimeInvariants + + SUBROUTINE deallocate_BGCTimeInvariants () + + USE MOD_MPAS_MPI + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + ! -------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------- + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + ! bgc variables + deallocate (donor_pool ) + deallocate (receiver_pool ) + deallocate (floating_cn_ratio) + deallocate (initial_cn_ratio ) + deallocate (rf_decomp ) + deallocate (pathfrac_decomp) + deallocate (is_cwd ) + deallocate (is_litter ) + deallocate (is_soil ) + deallocate (gdp_lf ) + deallocate (abm_lf ) + deallocate (peatf_lf ) + deallocate (cmb_cmplt_fact ) + deallocate (rice2pdt ) + + ENDIF + ENDIF + + END SUBROUTINE deallocate_BGCTimeInvariants + +#ifdef RangeCheck + !--------------------------------------- + SUBROUTINE check_BGCTimeInvariants () + + USE MOD_MPAS_MPI + USE MOD_RangeCheck + + IMPLICIT NONE + + CALL check_vector_data ('rf_decomp ', rf_decomp ) + CALL check_vector_data ('pathfrac_decomp', pathfrac_decomp) + CALL check_vector_data ('gdp_lf ', gdp_lf ) + CALL check_vector_data ('abm_lf ', abm_lf ) + CALL check_vector_data ('peatf_lf ', peatf_lf ) + CALL check_vector_data ('rice2pdt ', rice2pdt ) + + END SUBROUTINE check_BGCTimeInvariants +#endif + +#endif +END MODULE MOD_BGC_Vars_TimeInvariants diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 new file mode 100644 index 0000000000..c39e98b7a5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Vars_TimeVariables.F90 @@ -0,0 +1,1543 @@ +#include + +MODULE MOD_BGC_Vars_TimeVariables +#ifdef BGC +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! Define, allocate, and deallocate biogeochemical state variables at patch level. +! Read and write biogeochemical state variables at patch level from/to restart files. + +! !ORIGINAL: +! Xingjie Lu, 2022, created the original version + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix + USE MOD_TimeManager + IMPLICIT NONE + SAVE +!------------------------- BGC variables ------------------------------- + real(r8), allocatable :: decomp_cpools_vr (:,:,:) ! vertical resolved: soil decomposition (litter, cwd, soil organic matter) carbon pools (gC m-3) + real(r8), allocatable :: decomp_cpools (:,:) ! soil decomposition (litter, cwd, soil) carbon pools (gC m-2) + real(r8), allocatable :: decomp_cpools_vr_Cap (:,:,:) ! vertical resolved: soil decomposition (litter, cwd, soil organic matter) carbon Capacity (gC m-3) + real(r8), allocatable :: decomp_k (:,:,:) ! soil decomposition rate (s-1) + real(r8), allocatable :: ctrunc_vr (:,:) ! currently not used + real(r8), allocatable :: ctrunc_veg (:) ! currently not used + real(r8), allocatable :: ctrunc_soil (:) ! currently not used + + real(r8), allocatable :: t_scalar (:,:) ! vertical resolved: soil decomposition temperature scalars + real(r8), allocatable :: w_scalar (:,:) ! vertical resolved: soil decomposition water scalars + real(r8), allocatable :: o_scalar (:,:) ! vertical resolved: soil decomposition oxygen scalars + real(r8), allocatable :: depth_scalar (:,:) ! vertical resolved: soil decomposition depth scalars + +!Soil CN diffusion and advection + real(r8), allocatable :: som_adv_coef (:,:) ! vertical resolved: soil organic matter advective flux (m2 s-1) + real(r8), allocatable :: som_diffus_coef (:,:) ! vertical resolved: soil organic matter diffusion flux (m2 s-1) + +!Active Layer + real(r8), allocatable :: altmax (:) ! maximum annual depth of thaw (m) + real(r8), allocatable :: altmax_lastyear (:) ! previous year maximum annual depth of thaw (m) + integer , allocatable :: altmax_lastyear_indx (:) ! previous year maximum annual soil layer of thaw + + real(r8), allocatable :: totlitc (:) ! carbon balance diagnostics: total column litter carbon (gC m-2) + real(r8), allocatable :: totvegc (:) ! carbon balance diagnostics: total column vegetation carbon (gC m-2) + real(r8), allocatable :: totsomc (:) ! carbon balance diagnostics: total column soil organic matter carbon (gC m-2) + real(r8), allocatable :: totcwdc (:) ! carbon balance diagnostics: total column coarse woody debris carbon (gC m-2) + real(r8), allocatable :: totcolc (:) ! carbon balance diagnostics: total column carbon (veg, soil, litter, et al) (gC m-2) + real(r8), allocatable :: col_begcb (:) ! carbon balance diagnostics: column carbon, begin of time step (gC m-2) + real(r8), allocatable :: col_endcb (:) ! carbon balance diagnostics: column carbon, END of time step (gC m-2) + real(r8), allocatable :: col_vegbegcb (:) ! carbon balance diagnostics: column vegetation carbon, begin of time step (gC m-2) + real(r8), allocatable :: col_vegendcb (:) ! carbon balance diagnostics: column vegetation carbon, end of time step (gC m-2) + real(r8), allocatable :: col_soilbegcb (:) ! carbon balance diagnostics: column soil carbon, begin of time step (gC m-2) + real(r8), allocatable :: col_soilendcb (:) ! carbon balance diagnostics: column soil carbon, end of time step (gC m-2) + + real(r8), allocatable :: totlitn (:) ! nitrogen balance diagnostics: total column litter nitrogen (gN m-2) + real(r8), allocatable :: totvegn (:) ! nitrogen balance diagnostics: total column vegetation nitrogen (gN m-2) + real(r8), allocatable :: totsomn (:) ! nitrogen balance diagnostics: total column soil organic matter nitrogen (gN m-2) + real(r8), allocatable :: totcwdn (:) ! nitrogen balance diagnostics: total column coarse woody debris nitrogen (gN m-2) + real(r8), allocatable :: totcoln (:) ! nitrogen balance diagnostics: total column nitrogen (veg, soil, litter, et al) (gN m-2) + real(r8), allocatable :: col_begnb (:) ! nitrogen balance diagnostics: column nitrogen, begin of time step (gN m-2) + real(r8), allocatable :: col_endnb (:) ! nitrogen balance diagnostics: column nitrogen, end of time step (gN m-2) + real(r8), allocatable :: col_vegbegnb (:) ! nitrogen balance diagnostics: column vegetation nitrogen, begin of time step (gN m-2) + real(r8), allocatable :: col_vegendnb (:) ! nitrogen balance diagnostics: column vegetation nitrogen, end of time step (gN m-2) + real(r8), allocatable :: col_soilbegnb (:) ! nitrogen balance diagnostics: column soil organic nitrogen, begin of time step (gN m-2) + real(r8), allocatable :: col_soilendnb (:) ! nitrogen balance diagnostics: column soil organic nitrogen, end of time step (gN m-2) + real(r8), allocatable :: col_sminnbegnb (:) ! nitrogen balance diagnostics: column soil mineral nitrogen, begin of time step (gN m-2) + real(r8), allocatable :: col_sminnendnb (:) ! nitrogen balance diagnostics: column soil mineral nitrogen, end of time step (gN m-2) + + real(r8), allocatable :: leafc (:) ! leaf display C (gC m-2) + real(r8), allocatable :: leafc_storage (:) ! leaf storage C (gC m-2) + real(r8), allocatable :: leafc_xfer (:) ! leaf transfer C (gC m-2) + real(r8), allocatable :: frootc (:) ! fine root display C (gC m-2) + real(r8), allocatable :: frootc_storage (:) ! fine root storage C (gC m-2) + real(r8), allocatable :: frootc_xfer (:) ! fine root transfer C (gC m-2) + real(r8), allocatable :: livestemc (:) ! live stem display C (gC m-2) + real(r8), allocatable :: livestemc_storage (:) ! live stem storage C (gC m-2) + real(r8), allocatable :: livestemc_xfer (:) ! live stem transfer C (gC m-2) + real(r8), allocatable :: deadstemc (:) ! dead stem display C (gC m-2) + real(r8), allocatable :: deadstemc_storage (:) ! dead stem storage C (gC m-2) + real(r8), allocatable :: deadstemc_xfer (:) ! dead stem transfer C (gC m-2) + real(r8), allocatable :: livecrootc (:) ! live coarse root display C (gC m-2) + real(r8), allocatable :: livecrootc_storage (:) ! live coarse root storage C (gC m-2) + real(r8), allocatable :: livecrootc_xfer (:) ! live coarse root transfer C (gC m-2) + real(r8), allocatable :: deadcrootc (:) ! dead coarse root display C (gC m-2) + real(r8), allocatable :: deadcrootc_storage (:) ! dead coarse root storage C (gC m-2) + real(r8), allocatable :: deadcrootc_xfer (:) ! dead coarse root transfer C (gC m-2) + real(r8), allocatable :: grainc (:) ! grain display C (gC m-2) + real(r8), allocatable :: grainc_storage (:) ! grain storage C (gC m-2) + real(r8), allocatable :: grainc_xfer (:) ! grain transfer C (gC m-2) + real(r8), allocatable :: xsmrpool (:) ! maintenance respiration storage C (gC m-2) + real(r8), allocatable :: downreg (:) ! fractional reduction in GPP due to N limitation + real(r8), allocatable :: cropprod1c (:) ! product C (gC m-2) + real(r8), allocatable :: cropseedc_deficit (:) ! crop seed deficit C (gC m-2) + + real(r8), allocatable :: leafn (:) ! leaf display N (gN m-2) + real(r8), allocatable :: leafn_storage (:) ! leaf storage N (gN m-2) + real(r8), allocatable :: leafn_xfer (:) ! leaf transfer N (gN m-2) + real(r8), allocatable :: frootn (:) ! fine root display N (gN m-2)d + real(r8), allocatable :: frootn_storage (:) ! fine root storage N (gN m-2)d + real(r8), allocatable :: frootn_xfer (:) ! fine root transfer N (gN m-2)d + real(r8), allocatable :: livestemn (:) ! live stem display N (gN m-2)d + real(r8), allocatable :: livestemn_storage (:) ! live stem storage N (gN m-2)d + real(r8), allocatable :: livestemn_xfer (:) ! live stem transfer N (gN m-2)d + real(r8), allocatable :: deadstemn (:) ! dead stem display N (gN m-2)d + real(r8), allocatable :: deadstemn_storage (:) ! dead stem storage N (gN m-2)d + real(r8), allocatable :: deadstemn_xfer (:) ! dead stem transfer N (gN m-2)d + real(r8), allocatable :: livecrootn (:) ! live coarse root display N (gN m-2) + real(r8), allocatable :: livecrootn_storage (:) ! live coarse root storage N (gN m-2) + real(r8), allocatable :: livecrootn_xfer (:) ! live coarse root transfer N (gN m-2) + real(r8), allocatable :: deadcrootn (:) ! dead coarse root display N (gN m-2) + real(r8), allocatable :: deadcrootn_storage (:) ! dead coarse root storage N (gN m-2) + real(r8), allocatable :: deadcrootn_xfer (:) ! dead coarse root transfer N (gN m-2) + real(r8), allocatable :: grainn (:) ! grain display N (gN m-2) + real(r8), allocatable :: grainn_storage (:) ! grain storage N (gN m-2) + real(r8), allocatable :: grainn_xfer (:) ! grain transfer N (gN m-2) + real(r8), allocatable :: retransn (:) ! retranslocated N (gN m-2) + + real(r8), allocatable :: leafcCap (:) ! leaf display C capacity (gC m-2) + real(r8), allocatable :: leafc_storageCap (:) ! leaf storage C capacity (gC m-2) + real(r8), allocatable :: leafc_xferCap (:) ! leaf transfer C capacity (gC m-2) + real(r8), allocatable :: frootcCap (:) ! fine root display C capacity (gC m-2) + real(r8), allocatable :: frootc_storageCap (:) ! fine root storage C capacity (gC m-2) + real(r8), allocatable :: frootc_xferCap (:) ! fine root transfer C capacity (gC m-2) + real(r8), allocatable :: livestemcCap (:) ! live stem display C capacity (gC m-2) + real(r8), allocatable :: livestemc_storageCap (:) ! live stem storage C capacity (gC m-2) + real(r8), allocatable :: livestemc_xferCap (:) ! live stem transfer C capacity (gC m-2) + real(r8), allocatable :: deadstemcCap (:) ! dead stem display C capacity (gC m-2) + real(r8), allocatable :: deadstemc_storageCap (:) ! dead stem storage C capacity (gC m-2) + real(r8), allocatable :: deadstemc_xferCap (:) ! dead stem transfer C capacity (gC m-2) + real(r8), allocatable :: livecrootcCap (:) ! live coarse root display C capacity (gC m-2) + real(r8), allocatable :: livecrootc_storageCap (:) ! live coarse root storage C capacity (gC m-2) + real(r8), allocatable :: livecrootc_xferCap (:) ! live coarse root transfer C capacity (gC m-2) + real(r8), allocatable :: deadcrootcCap (:) ! dead coarse root display C capacity (gC m-2) + real(r8), allocatable :: deadcrootc_storageCap (:) ! dead coarse root storage C capacity (gC m-2) + real(r8), allocatable :: deadcrootc_xferCap (:) ! dead coarse root transfer C capacity (gC m-2) + + real(r8), allocatable :: leafnCap (:) ! leaf display N capacity (gN m-2) + real(r8), allocatable :: leafn_storageCap (:) ! leaf storage N capacity (gN m-2) + real(r8), allocatable :: leafn_xferCap (:) ! leaf transfer N capacity (gN m-2) + real(r8), allocatable :: frootnCap (:) ! fine root display N capacity (gN m-2) + real(r8), allocatable :: frootn_storageCap (:) ! fine root storage N capacity (gN m-2) + real(r8), allocatable :: frootn_xferCap (:) ! fine root transfer N capacity (gN m-2) + real(r8), allocatable :: livestemnCap (:) ! live stem display N capacity (gN m-2) + real(r8), allocatable :: livestemn_storageCap (:) ! live stem storage N capacity (gN m-2) + real(r8), allocatable :: livestemn_xferCap (:) ! live stem transfer N capacity (gN m-2) + real(r8), allocatable :: deadstemnCap (:) ! dead stem display N capacity (gN m-2) + real(r8), allocatable :: deadstemn_storageCap (:) ! dead stem storage N capacity (gN m-2) + real(r8), allocatable :: deadstemn_xferCap (:) ! dead stem transfer N capacity (gN m-2) + real(r8), allocatable :: livecrootnCap (:) ! live coarse root display N capacity (gN m-2) + real(r8), allocatable :: livecrootn_storageCap (:) ! live coarse root storage N capacity (gN m-2) + real(r8), allocatable :: livecrootn_xferCap (:) ! live coarse root transfer N capacity (gN m-2) + real(r8), allocatable :: deadcrootnCap (:) ! dead coarse root display N capacity (gN m-2) + real(r8), allocatable :: deadcrootn_storageCap (:) ! dead coarse root storage N capacity (gN m-2) + real(r8), allocatable :: deadcrootn_xferCap (:) ! dead coarse root transfer N capacity (gN m-2) + + real(r8), allocatable :: decomp_npools_vr (:,:,:) ! vertical resolved: soil decomposition (litter, cwd, soil) nitrogen (gN m-3) + real(r8), allocatable :: decomp_npools (:,:) ! soil decomposition (litter, cwd, soil) nitrogen (gN m-2) + real(r8), allocatable :: decomp_npools_vr_Cap (:,:,:) ! vertical resolved: soil decomposition (litter, cwd, soil organic matter) carbon Capacity (gC m-3) + real(r8), allocatable :: totsoiln_vr (:,:) ! vertical resolved: total soil nitrogen (%: gN/gSoil*100) + real(r8), allocatable :: ntrunc_vr (:,:) ! currently not used + real(r8), allocatable :: ntrunc_veg (:) ! currently not used + real(r8), allocatable :: ntrunc_soil (:) ! currently not used + + real(r8), allocatable :: sminn_vr (:,:) ! vertical resolved: soil mineral nitrogen (gN m-3) + real(r8), allocatable :: smin_no3_vr (:,:) ! vertical resolved: soil mineral NO3 (gN m-3) + real(r8), allocatable :: smin_nh4_vr (:,:) ! vertical resolved: soil mineral NH4 (gN m-3) + real(r8), allocatable :: sminn (:) ! soil mineral nitrogen (gN m-2) + real(r8), allocatable :: ndep (:) ! atmospheric nitrogen deposition (gN m-2) + + real(r8), allocatable :: to2_decomp_depth_unsat (:,:) ! vertical resolved: O2 soil consumption from heterotrophic respiration and autotrophic respiration (mol m-3 s-1) + real(r8), allocatable :: tconc_o2_unsat (:,:) ! vertical resolved: O2 soil consumption (mol m-3 s-1) + + real(r8), allocatable :: ndep_prof (:,:) ! vertical resolved: atmospheric N deposition input to soil (m-1) + real(r8), allocatable :: nfixation_prof (:,:) ! vertical resolved: N fixation input to soil (m-1) + + real(r8), allocatable :: cn_decomp_pools (:,:,:) ! vertical resolved: c:n ratios of each decomposition pools + real(r8), allocatable :: fpi_vr (:,:) ! vertical resolved: actual immobilization N :potential immobilization N + real(r8), allocatable :: fpi (:) ! actual immobilization N : potential immobilization N + real(r8), allocatable :: fpg (:) ! actual plant uptake N : plant potential need N + + real(r8), allocatable :: cropf (:) ! + real(r8), allocatable :: lfwt (:) ! + real(r8), allocatable :: fuelc (:) ! + real(r8), allocatable :: fuelc_crop (:) ! + real(r8), allocatable :: fsr (:) ! + real(r8), allocatable :: fd (:) ! + real(r8), allocatable :: rootc (:) ! + real(r8), allocatable :: lgdp (:) ! + real(r8), allocatable :: lgdp1 (:) ! + real(r8), allocatable :: lpop (:) ! + real(r8), allocatable :: wtlf (:) ! + real(r8), allocatable :: trotr1 (:) ! + real(r8), allocatable :: trotr2 (:) ! + real(r8), allocatable :: hdm_lf (:) ! + real(r8), allocatable :: lnfm (:) ! + real(r8), allocatable :: baf_crop (:) ! + real(r8), allocatable :: baf_peatf (:) ! + real(r8), allocatable :: farea_burned (:) ! total fractional area burned (s-1) + real(r8), allocatable :: nfire (:) ! fire counts (count km-2 s-1) + real(r8), allocatable :: fsat (:) ! + real(r8), allocatable :: prec10 (:) ! 10-day running mean of total precipitation (mm -1) + real(r8), allocatable :: prec60 (:) ! 60-day running mean of total precipitation (mm -1) + real(r8), allocatable :: prec365 (:) ! 365-day running mean of tota l precipitation (mm -1) + real(r8), allocatable :: prec_today (:) ! today's daily precipitation (mm -1) + real(r8), allocatable :: prec_daily (:,:) ! daily total precipitation (mm -1) + real(r8), allocatable :: wf2 (:) ! soil moisture (K) + real(r8), allocatable :: tsoi17 (:) ! soil temperature (cm3 cm-3) + real(r8), allocatable :: rh30 (:) ! 30-day running mean of relative humidity (%) + real(r8), allocatable :: accumnstep (:) ! timestep accumulator + + real(r8), allocatable :: dayl (:) ! day length (s) + real(r8), allocatable :: prev_dayl (:) ! day length from previous day (s) + +!-------------BGC/SASU variables--------------------------- + real(r8), allocatable :: decomp0_cpools_vr (:,:,:) ! SASU spinup diagnostics vertical-resolved: soil decomposition (litter, cwd, soil organic matter) carbon pools (gC m-3) + real(r8), allocatable :: I_met_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to metabolic litter C (gC m-3) + real(r8), allocatable :: I_cel_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to cellulosic litter C (gC m-3) + real(r8), allocatable :: I_lig_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to lignin litter C (gC m-3) + real(r8), allocatable :: I_cwd_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to coarse woody debris C (gC m-3) + real(r8), allocatable :: AKX_met_to_soil1_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from metabolic litter C to active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_cel_to_soil1_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from cellulosic litter C to active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_lig_to_soil2_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from lignin litter C to slow soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil1_to_soil2_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from active soil organic matter C to slow soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_cwd_to_cel_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from coarse woody debris C to cellulosic litter C (gC m-3) + real(r8), allocatable :: AKX_cwd_to_lig_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from coarse woody debris C to lignin litter C (gC m-3) + real(r8), allocatable :: AKX_soil1_to_soil3_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from active soil organic matter C to passive soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil2_to_soil1_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from slow soil organic matter C to active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil2_to_soil3_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from slow soil organic matter C to passive soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil3_to_soil1_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from passive soil organic matter C to active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_met_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from metabolic litter C (gC m-3) + real(r8), allocatable :: AKX_cel_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from cellulosic litter C (gC m-3) + real(r8), allocatable :: AKX_lig_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from lignin litter C (gC m-3) + real(r8), allocatable :: AKX_cwd_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from coarse woody debris C (gC m-3) + real(r8), allocatable :: AKX_soil1_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from active soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil2_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from slow soil organic matter C (gC m-3) + real(r8), allocatable :: AKX_soil3_exit_c_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from passive soil organic matter C (gC m-3) + + real(r8), allocatable :: decomp0_npools_vr (:,:,:) ! SASU spinup diagnostics vertical-resolved: soil decomposition (litter, cwd, soil organic matter) carbon pools (gN m-3) + real(r8), allocatable :: I_met_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to metabolic litter N (gN m-3) + real(r8), allocatable :: I_cel_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to cellulosic litter N (gN m-3) + real(r8), allocatable :: I_lig_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to lignin litter N (gN m-3) + real(r8), allocatable :: I_cwd_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated input to coarse woody debris N (gN m-3) + real(r8), allocatable :: AKX_met_to_soil1_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from metabolic litter N to active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_cel_to_soil1_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from cellulosic litter N to active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_lig_to_soil2_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from lignin litter N to slow soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil1_to_soil2_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from active soil organic matter N to slow soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_cwd_to_cel_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from coarse woody debris N to cellulosic litter N (gN m-3) + real(r8), allocatable :: AKX_cwd_to_lig_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from coarse woody debris N to lignin litter N (gN m-3) + real(r8), allocatable :: AKX_soil1_to_soil3_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from active soil organic matter N to passive soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil2_to_soil1_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from slow soil organic matter N to active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil2_to_soil3_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from slow soil organic matter N to passive soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil3_to_soil1_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux from passive soil organic matter N to active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_met_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from metabolic litter N (gN m-3) + real(r8), allocatable :: AKX_cel_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from cellulosic litter N (gN m-3) + real(r8), allocatable :: AKX_lig_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from lignin litter N (gN m-3) + real(r8), allocatable :: AKX_cwd_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from coarse woody debris N (gN m-3) + real(r8), allocatable :: AKX_soil1_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from active soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil2_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from slow soil organic matter N (gN m-3) + real(r8), allocatable :: AKX_soil3_exit_n_vr_acc (:,:) ! SASU spinup diagnostics vertical-resolved: accumulated flux exiting from passive soil organic matter N (gN m-3) + + real(r8), allocatable :: diagVX_c_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated carbon EXIT flux due to the vertical mixing in soil and litter pools (gC m-3) + real(r8), allocatable :: upperVX_c_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated carbon upward flux due to the vertical mixing in soil and litter pools (gC m-3) + real(r8), allocatable :: lowerVX_c_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated carbon downward flux due to the vertical mixing in soil and litter pools (gC m-3) + real(r8), allocatable :: diagVX_n_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated nitrogen EXIT flux due to the vertical mixing in soil and litter pools (gN m-3) + real(r8), allocatable :: upperVX_n_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated nitrogen upward flux due to the vertical mixing in soil and litter pools (gN m-3) + real(r8), allocatable :: lowerVX_n_vr_acc (:,:,:) ! SASU spinup diagnostics vertical-resolved: accumulated nitrogen downward flux due to the vertical mixing in soil and litter pools (gN m-3) + logical , allocatable :: skip_balance_check (:) ! When we estimate the steady state and update the actcual pool with steady state in SASU, the CN balance check is expected to fail. & + ! Skip the balance check at END of the year when SASU is on +#ifdef CROP + real(r8), allocatable :: cphase (:) ! crop phasecrop phase + real(r8), allocatable :: vf (:) ! vernalization response + real(r8), allocatable :: gddplant (:) ! gdd since planting (ddays) + real(r8), allocatable :: gddmaturity (:) ! gdd needed to harvest (ddays) + real(r8), allocatable :: hui (:) ! heat unit index + real(r8), allocatable :: huiswheat (:) ! heat unit index (rainfed spring wheat) + real(r8), allocatable :: pdcorn (:) ! planting date of corn + real(r8), allocatable :: pdswheat (:) ! planting date of spring wheat + real(r8), allocatable :: pdwwheat (:) ! planting date of winter wheat + real(r8), allocatable :: pdsoybean (:) ! planting date of soybean + real(r8), allocatable :: pdcotton (:) ! planting date of cotton + real(r8), allocatable :: pdrice1 (:) ! planting date of rice1 + real(r8), allocatable :: pdrice2 (:) ! planting date of rice2 + real(r8), allocatable :: pdsugarcane (:) ! planting date of sugarcane + real(r8), allocatable :: plantdate (:) ! planting date + real(r8), allocatable :: manunitro (:) ! nitrogen fertilizer for corn (gN m-2) + real(r8), allocatable :: fertnitro_corn (:) ! nitrogen fertilizer for corn (gN m-2) + real(r8), allocatable :: fertnitro_swheat (:) ! nitrogen fertilizer for spring wheat (gN m-2) + real(r8), allocatable :: fertnitro_wwheat (:) ! nitrogen fertilizer for winter wheat (gN m-2) + real(r8), allocatable :: fertnitro_soybean (:) ! nitrogen fertilizer for soybean (gN m-2) + real(r8), allocatable :: fertnitro_cotton (:) ! nitrogen fertilizer for cotton (gN m-2) + real(r8), allocatable :: fertnitro_rice1 (:) ! nitrogen fertilizer for rice1 (gN m-2) + real(r8), allocatable :: fertnitro_rice2 (:) ! nitrogen fertilizer for rice2 (gN m-2) + real(r8), allocatable :: fertnitro_sugarcane (:) ! nitrogen fertilizer for sugarcane (gN m-2) +#endif + real(r8), allocatable :: lag_npp (:) !!! lagged net primary production (gC m-2) +!------------------------------------------------------ + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_BGCTimeVariables + PUBLIC :: deallocate_BGCTimeVariables + PUBLIC :: READ_BGCTimeVariables + PUBLIC :: WRITE_BGCTimeVariables +#ifdef RangeCheck + PUBLIC :: check_BGCTimeVariables +#endif + +! PRIVATE MEMBER FUNCTIONS: + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_BGCTimeVariables +! -------------------------------------------------------------------- +! Allocates memory for CoLM 1d [numpatch] variables +! ------------------------------------------------------ + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_MPAS_MPI + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + ! bgc variables + allocate (decomp_cpools_vr (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_cpools_vr (:,:,:) = spval + allocate (decomp_cpools (ndecomp_pools,numpatch)) ; decomp_cpools (:,:) = spval + allocate (decomp_cpools_vr_Cap (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_cpools_vr_Cap(:,:,:) = spval + allocate (ctrunc_vr (nl_soil,numpatch)) ; ctrunc_vr (:,:) = spval + allocate (ctrunc_veg (numpatch)) ; ctrunc_veg (:) = spval + allocate (ctrunc_soil (numpatch)) ; ctrunc_soil (:) = spval + allocate (decomp_k (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_k (:,:,:) = spval + + allocate (t_scalar (nl_soil,numpatch)) ; t_scalar (:,:) = spval + allocate (w_scalar (nl_soil,numpatch)) ; w_scalar (:,:) = spval + allocate (o_scalar (nl_soil,numpatch)) ; o_scalar (:,:) = spval + allocate (depth_scalar (nl_soil,numpatch)) ; depth_scalar (:,:) = spval + + allocate (som_adv_coef (nl_soil_full,numpatch)) ; som_adv_coef (:,:) = spval + allocate (som_diffus_coef (nl_soil_full,numpatch)) ; som_diffus_coef (:,:) = spval + + allocate (altmax (numpatch)) ; altmax (:) = spval + allocate (altmax_lastyear (numpatch)) ; altmax_lastyear (:) = spval + allocate (altmax_lastyear_indx (numpatch)) ; altmax_lastyear_indx (:) = spval_i4 + + allocate (totlitc (numpatch)) ; totlitc (:) = spval + allocate (totvegc (numpatch)) ; totvegc (:) = spval + allocate (totsomc (numpatch)) ; totsomc (:) = spval + allocate (totcwdc (numpatch)) ; totcwdc (:) = spval + allocate (totcolc (numpatch)) ; totcolc (:) = spval + allocate (col_begcb (numpatch)) ; col_begcb (:) = spval + allocate (col_endcb (numpatch)) ; col_endcb (:) = spval + allocate (col_vegbegcb (numpatch)) ; col_vegbegcb (:) = spval + allocate (col_vegendcb (numpatch)) ; col_vegendcb (:) = spval + allocate (col_soilbegcb (numpatch)) ; col_soilbegcb (:) = spval + allocate (col_soilendcb (numpatch)) ; col_soilendcb (:) = spval + + allocate (totlitn (numpatch)) ; totlitn (:) = spval + allocate (totvegn (numpatch)) ; totvegn (:) = spval + allocate (totsomn (numpatch)) ; totsomn (:) = spval + allocate (totcwdn (numpatch)) ; totcwdn (:) = spval + allocate (totcoln (numpatch)) ; totcoln (:) = spval + allocate (col_begnb (numpatch)) ; col_begnb (:) = spval + allocate (col_endnb (numpatch)) ; col_endnb (:) = spval + allocate (col_vegbegnb (numpatch)) ; col_vegbegnb (:) = spval + allocate (col_vegendnb (numpatch)) ; col_vegendnb (:) = spval + allocate (col_soilbegnb (numpatch)) ; col_soilbegnb (:) = spval + allocate (col_soilendnb (numpatch)) ; col_soilendnb (:) = spval + allocate (col_sminnbegnb (numpatch)) ; col_sminnbegnb (:) = spval + allocate (col_sminnendnb (numpatch)) ; col_sminnendnb (:) = spval + + allocate (leafc (numpatch)) ; leafc (:) = spval + allocate (leafc_storage (numpatch)) ; leafc_storage (:) = spval + allocate (leafc_xfer (numpatch)) ; leafc_xfer (:) = spval + allocate (frootc (numpatch)) ; frootc (:) = spval + allocate (frootc_storage (numpatch)) ; frootc_storage (:) = spval + allocate (frootc_xfer (numpatch)) ; frootc_xfer (:) = spval + allocate (livestemc (numpatch)) ; livestemc (:) = spval + allocate (livestemc_storage (numpatch)) ; livestemc_storage (:) = spval + allocate (livestemc_xfer (numpatch)) ; livestemc_xfer (:) = spval + allocate (deadstemc (numpatch)) ; deadstemc (:) = spval + allocate (deadstemc_storage (numpatch)) ; deadstemc_storage (:) = spval + allocate (deadstemc_xfer (numpatch)) ; deadstemc_xfer (:) = spval + allocate (livecrootc (numpatch)) ; livecrootc (:) = spval + allocate (livecrootc_storage (numpatch)) ; livecrootc_storage (:) = spval + allocate (livecrootc_xfer (numpatch)) ; livecrootc_xfer (:) = spval + allocate (deadcrootc (numpatch)) ; deadcrootc (:) = spval + allocate (deadcrootc_storage (numpatch)) ; deadcrootc_storage (:) = spval + allocate (deadcrootc_xfer (numpatch)) ; deadcrootc_xfer (:) = spval + allocate (grainc (numpatch)) ; grainc (:) = spval + allocate (grainc_storage (numpatch)) ; grainc_storage (:) = spval + allocate (grainc_xfer (numpatch)) ; grainc_xfer (:) = spval + allocate (xsmrpool (numpatch)) ; xsmrpool (:) = spval + allocate (downreg (numpatch)) ; downreg (:) = spval + allocate (cropprod1c (numpatch)) ; cropprod1c (:) = spval + allocate (cropseedc_deficit (numpatch)) ; cropseedc_deficit (:) = spval + + allocate (leafn (numpatch)) ; leafn (:) = spval + allocate (leafn_storage (numpatch)) ; leafn_storage (:) = spval + allocate (leafn_xfer (numpatch)) ; leafn_xfer (:) = spval + allocate (frootn (numpatch)) ; frootn (:) = spval + allocate (frootn_storage (numpatch)) ; frootn_storage (:) = spval + allocate (frootn_xfer (numpatch)) ; frootn_xfer (:) = spval + allocate (livestemn (numpatch)) ; livestemn (:) = spval + allocate (livestemn_storage (numpatch)) ; livestemn_storage (:) = spval + allocate (livestemn_xfer (numpatch)) ; livestemn_xfer (:) = spval + allocate (deadstemn (numpatch)) ; deadstemn (:) = spval + allocate (deadstemn_storage (numpatch)) ; deadstemn_storage (:) = spval + allocate (deadstemn_xfer (numpatch)) ; deadstemn_xfer (:) = spval + allocate (livecrootn (numpatch)) ; livecrootn (:) = spval + allocate (livecrootn_storage (numpatch)) ; livecrootn_storage (:) = spval + allocate (livecrootn_xfer (numpatch)) ; livecrootn_xfer (:) = spval + allocate (deadcrootn (numpatch)) ; deadcrootn (:) = spval + allocate (deadcrootn_storage (numpatch)) ; deadcrootn_storage (:) = spval + allocate (deadcrootn_xfer (numpatch)) ; deadcrootn_xfer (:) = spval + allocate (grainn (numpatch)) ; grainn (:) = spval + allocate (grainn_storage (numpatch)) ; grainn_storage (:) = spval + allocate (grainn_xfer (numpatch)) ; grainn_xfer (:) = spval + allocate (retransn (numpatch)) ; retransn (:) = spval + + allocate (leafcCap (numpatch)) ; leafcCap (:) = spval + allocate (leafc_storageCap (numpatch)) ; leafc_storageCap (:) = spval + allocate (leafc_xferCap (numpatch)) ; leafc_xferCap (:) = spval + allocate (frootcCap (numpatch)) ; frootcCap (:) = spval + allocate (frootc_storageCap (numpatch)) ; frootc_storageCap (:) = spval + allocate (frootc_xferCap (numpatch)) ; frootc_xferCap (:) = spval + allocate (livestemcCap (numpatch)) ; livestemcCap (:) = spval + allocate (livestemc_storageCap (numpatch)) ; livestemc_storageCap (:) = spval + allocate (livestemc_xferCap (numpatch)) ; livestemc_xferCap (:) = spval + allocate (deadstemcCap (numpatch)) ; deadstemcCap (:) = spval + allocate (deadstemc_storageCap (numpatch)) ; deadstemc_storageCap (:) = spval + allocate (deadstemc_xferCap (numpatch)) ; deadstemc_xferCap (:) = spval + allocate (livecrootcCap (numpatch)) ; livecrootcCap (:) = spval + allocate (livecrootc_storageCap (numpatch)) ; livecrootc_storageCap (:) = spval + allocate (livecrootc_xferCap (numpatch)) ; livecrootc_xferCap (:) = spval + allocate (deadcrootcCap (numpatch)) ; deadcrootcCap (:) = spval + allocate (deadcrootc_storageCap (numpatch)) ; deadcrootc_storageCap (:) = spval + allocate (deadcrootc_xferCap (numpatch)) ; deadcrootc_xferCap (:) = spval + + allocate (leafnCap (numpatch)) ; leafnCap (:) = spval + allocate (leafn_storageCap (numpatch)) ; leafn_storageCap (:) = spval + allocate (leafn_xferCap (numpatch)) ; leafn_xferCap (:) = spval + allocate (frootnCap (numpatch)) ; frootnCap (:) = spval + allocate (frootn_storageCap (numpatch)) ; frootn_storageCap (:) = spval + allocate (frootn_xferCap (numpatch)) ; frootn_xferCap (:) = spval + allocate (livestemnCap (numpatch)) ; livestemnCap (:) = spval + allocate (livestemn_storageCap (numpatch)) ; livestemn_storageCap (:) = spval + allocate (livestemn_xferCap (numpatch)) ; livestemn_xferCap (:) = spval + allocate (deadstemnCap (numpatch)) ; deadstemnCap (:) = spval + allocate (deadstemn_storageCap (numpatch)) ; deadstemn_storageCap (:) = spval + allocate (deadstemn_xferCap (numpatch)) ; deadstemn_xferCap (:) = spval + allocate (livecrootnCap (numpatch)) ; livecrootnCap (:) = spval + allocate (livecrootn_storageCap (numpatch)) ; livecrootn_storageCap (:) = spval + allocate (livecrootn_xferCap (numpatch)) ; livecrootn_xferCap (:) = spval + allocate (deadcrootnCap (numpatch)) ; deadcrootnCap (:) = spval + allocate (deadcrootn_storageCap (numpatch)) ; deadcrootn_storageCap (:) = spval + allocate (deadcrootn_xferCap (numpatch)) ; deadcrootn_xferCap (:) = spval + + allocate (decomp_npools_vr (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_npools_vr (:,:,:) = spval + allocate (decomp_npools (ndecomp_pools,numpatch)) ; decomp_npools (:,:) = spval + allocate (decomp_npools_vr_Cap (nl_soil_full,ndecomp_pools,numpatch)) ; decomp_npools_vr_Cap(:,:,:) = spval + allocate (totsoiln_vr (nl_soil,numpatch)) ; totsoiln_vr (:,:) = spval + allocate (ntrunc_vr (nl_soil,numpatch)) ; ntrunc_vr (:,:) = spval + allocate (ntrunc_veg (numpatch)) ; ntrunc_veg (:) = spval + allocate (ntrunc_soil (numpatch)) ; ntrunc_soil (:) = spval + allocate (sminn_vr (nl_soil,numpatch)) ; sminn_vr (:,:) = spval + allocate (smin_no3_vr (nl_soil,numpatch)) ; smin_no3_vr (:,:) = spval + allocate (smin_nh4_vr (nl_soil,numpatch)) ; smin_nh4_vr (:,:) = spval + allocate (sminn (numpatch)) ; sminn (:) = spval + allocate (ndep (numpatch)) ; ndep (:) = spval + + allocate (to2_decomp_depth_unsat (nl_soil,numpatch)) ; to2_decomp_depth_unsat (:,:) = spval + allocate (tconc_o2_unsat (nl_soil,numpatch)) ; tconc_o2_unsat (:,:) = spval + + allocate (ndep_prof (nl_soil,numpatch)) ; ndep_prof (:,:) = spval + allocate (nfixation_prof (nl_soil,numpatch)) ; nfixation_prof (:,:) = spval + + allocate (cn_decomp_pools (nl_soil,ndecomp_pools,numpatch)) ; cn_decomp_pools (:,:,:) = spval + allocate (fpi_vr (nl_soil,numpatch)) ; fpi_vr (:,:) = spval + allocate (fpi (numpatch)) ; fpi (:) = spval + allocate (fpg (numpatch)) ; fpg (:) = spval + + allocate (cropf (numpatch)) ; cropf (:) = spval + allocate (lfwt (numpatch)) ; lfwt (:) = spval + allocate (fuelc (numpatch)) ; fuelc (:) = spval + allocate (fuelc_crop (numpatch)) ; fuelc_crop (:) = spval + allocate (fsr (numpatch)) ; fsr (:) = spval + allocate (fd (numpatch)) ; fd (:) = spval + allocate (rootc (numpatch)) ; rootc (:) = spval + allocate (lgdp (numpatch)) ; lgdp (:) = spval + allocate (lgdp1 (numpatch)) ; lgdp1 (:) = spval + allocate (lpop (numpatch)) ; lpop (:) = spval + allocate (wtlf (numpatch)) ; wtlf (:) = spval + allocate (trotr1 (numpatch)) ; trotr1 (:) = spval + allocate (trotr2 (numpatch)) ; trotr2 (:) = spval + allocate (hdm_lf (numpatch)) ; hdm_lf (:) = spval + allocate (lnfm (numpatch)) ; lnfm (:) = spval + allocate (baf_crop (numpatch)) ; baf_crop (:) = spval + allocate (baf_peatf (numpatch)) ; baf_peatf (:) = spval + allocate (farea_burned (numpatch)) ; farea_burned (:) = spval + allocate (nfire (numpatch)) ; nfire (:) = spval + allocate (fsat (numpatch)) ; fsat (:) = spval + allocate (prec10 (numpatch)) ; prec10 (:) = spval + allocate (prec60 (numpatch)) ; prec60 (:) = spval + allocate (prec365 (numpatch)) ; prec365 (:) = spval + allocate (prec_today (numpatch)) ; prec_today (:) = spval + allocate (prec_daily (365,numpatch)) ; prec_daily (:,:) = spval! daily total precipitation [mm/day] + allocate (wf2 (numpatch)) ; wf2 (:) = spval + allocate (tsoi17 (numpatch)) ; tsoi17 (:) = spval + allocate (rh30 (numpatch)) ; rh30 (:) = spval + allocate (accumnstep (numpatch)) ; accumnstep (:) = spval + ; + allocate (dayl (numpatch)) ; dayl (:) = spval + allocate (prev_dayl (numpatch)) ; prev_dayl (:) = spval + + !---------------------------SASU variables-------------------------------------- + allocate (decomp0_cpools_vr (nl_soil,ndecomp_pools,numpatch)) ; decomp0_cpools_vr (:,:,:) = spval + allocate (I_met_c_vr_acc (nl_soil,numpatch)) ; I_met_c_vr_acc (:,:) = spval + allocate (I_cel_c_vr_acc (nl_soil,numpatch)) ; I_cel_c_vr_acc (:,:) = spval + allocate (I_lig_c_vr_acc (nl_soil,numpatch)) ; I_lig_c_vr_acc (:,:) = spval + allocate (I_cwd_c_vr_acc (nl_soil,numpatch)) ; I_cwd_c_vr_acc (:,:) = spval + allocate (AKX_met_to_soil1_c_vr_acc (nl_soil,numpatch)) ; AKX_met_to_soil1_c_vr_acc (:,:) = spval + allocate (AKX_cel_to_soil1_c_vr_acc (nl_soil,numpatch)) ; AKX_cel_to_soil1_c_vr_acc (:,:) = spval + allocate (AKX_lig_to_soil2_c_vr_acc (nl_soil,numpatch)) ; AKX_lig_to_soil2_c_vr_acc (:,:) = spval + allocate (AKX_soil1_to_soil2_c_vr_acc (nl_soil,numpatch)) ; AKX_soil1_to_soil2_c_vr_acc (:,:) = spval + allocate (AKX_cwd_to_cel_c_vr_acc (nl_soil,numpatch)) ; AKX_cwd_to_cel_c_vr_acc (:,:) = spval + allocate (AKX_cwd_to_lig_c_vr_acc (nl_soil,numpatch)) ; AKX_cwd_to_lig_c_vr_acc (:,:) = spval + allocate (AKX_soil1_to_soil3_c_vr_acc (nl_soil,numpatch)) ; AKX_soil1_to_soil3_c_vr_acc (:,:) = spval + allocate (AKX_soil2_to_soil1_c_vr_acc (nl_soil,numpatch)) ; AKX_soil2_to_soil1_c_vr_acc (:,:) = spval + allocate (AKX_soil2_to_soil3_c_vr_acc (nl_soil,numpatch)) ; AKX_soil2_to_soil3_c_vr_acc (:,:) = spval + allocate (AKX_soil3_to_soil1_c_vr_acc (nl_soil,numpatch)) ; AKX_soil3_to_soil1_c_vr_acc (:,:) = spval + allocate (AKX_met_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_met_exit_c_vr_acc (:,:) = spval + allocate (AKX_cel_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_cel_exit_c_vr_acc (:,:) = spval + allocate (AKX_lig_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_lig_exit_c_vr_acc (:,:) = spval + allocate (AKX_cwd_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_cwd_exit_c_vr_acc (:,:) = spval + allocate (AKX_soil1_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_soil1_exit_c_vr_acc (:,:) = spval + allocate (AKX_soil2_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_soil2_exit_c_vr_acc (:,:) = spval + allocate (AKX_soil3_exit_c_vr_acc (nl_soil,numpatch)) ; AKX_soil3_exit_c_vr_acc (:,:) = spval + + allocate (decomp0_npools_vr (nl_soil,ndecomp_pools,numpatch)) ; decomp0_npools_vr (:,:,:) = spval + allocate (I_met_n_vr_acc (nl_soil,numpatch)) ; I_met_n_vr_acc (:,:) = spval + allocate (I_cel_n_vr_acc (nl_soil,numpatch)) ; I_cel_n_vr_acc (:,:) = spval + allocate (I_lig_n_vr_acc (nl_soil,numpatch)) ; I_lig_n_vr_acc (:,:) = spval + allocate (I_cwd_n_vr_acc (nl_soil,numpatch)) ; I_cwd_n_vr_acc (:,:) = spval + allocate (AKX_met_to_soil1_n_vr_acc (nl_soil,numpatch)) ; AKX_met_to_soil1_n_vr_acc (:,:) = spval + allocate (AKX_cel_to_soil1_n_vr_acc (nl_soil,numpatch)) ; AKX_cel_to_soil1_n_vr_acc (:,:) = spval + allocate (AKX_lig_to_soil2_n_vr_acc (nl_soil,numpatch)) ; AKX_lig_to_soil2_n_vr_acc (:,:) = spval + allocate (AKX_soil1_to_soil2_n_vr_acc (nl_soil,numpatch)) ; AKX_soil1_to_soil2_n_vr_acc (:,:) = spval + allocate (AKX_cwd_to_cel_n_vr_acc (nl_soil,numpatch)) ; AKX_cwd_to_cel_n_vr_acc (:,:) = spval + allocate (AKX_cwd_to_lig_n_vr_acc (nl_soil,numpatch)) ; AKX_cwd_to_lig_n_vr_acc (:,:) = spval + allocate (AKX_soil1_to_soil3_n_vr_acc (nl_soil,numpatch)) ; AKX_soil1_to_soil3_n_vr_acc (:,:) = spval + allocate (AKX_soil2_to_soil1_n_vr_acc (nl_soil,numpatch)) ; AKX_soil2_to_soil1_n_vr_acc (:,:) = spval + allocate (AKX_soil2_to_soil3_n_vr_acc (nl_soil,numpatch)) ; AKX_soil2_to_soil3_n_vr_acc (:,:) = spval + allocate (AKX_soil3_to_soil1_n_vr_acc (nl_soil,numpatch)) ; AKX_soil3_to_soil1_n_vr_acc (:,:) = spval + allocate (AKX_met_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_met_exit_n_vr_acc (:,:) = spval + allocate (AKX_cel_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_cel_exit_n_vr_acc (:,:) = spval + allocate (AKX_lig_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_lig_exit_n_vr_acc (:,:) = spval + allocate (AKX_cwd_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_cwd_exit_n_vr_acc (:,:) = spval + allocate (AKX_soil1_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_soil1_exit_n_vr_acc (:,:) = spval + allocate (AKX_soil2_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_soil2_exit_n_vr_acc (:,:) = spval + allocate (AKX_soil3_exit_n_vr_acc (nl_soil,numpatch)) ; AKX_soil3_exit_n_vr_acc (:,:) = spval + + allocate (diagVX_c_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; diagVX_c_vr_acc (:,:,:) = spval + allocate (upperVX_c_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; upperVX_c_vr_acc (:,:,:) = spval + allocate (lowerVX_c_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; lowerVX_c_vr_acc (:,:,:) = spval + allocate (diagVX_n_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; diagVX_n_vr_acc (:,:,:) = spval + allocate (upperVX_n_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; upperVX_n_vr_acc (:,:,:) = spval + allocate (lowerVX_n_vr_acc (nl_soil,ndecomp_pools,numpatch)) ; lowerVX_n_vr_acc (:,:,:) = spval + + !--------------------------------------------------------------------------- + allocate (skip_balance_check (numpatch)) ; skip_balance_check (:) = .false. + +#ifdef CROP + allocate (cphase (numpatch)) ; cphase (:) = spval ! 30-day running mean of relative humidity + allocate (vf (numpatch)) ; vf (:) = spval + allocate (gddmaturity (numpatch)) ; gddmaturity (:) = spval + allocate (gddplant (numpatch)) ; gddplant (:) = spval + allocate (hui (numpatch)) ; hui (:) = spval + allocate (huiswheat (numpatch)) ; huiswheat (:) = spval + allocate (pdcorn (numpatch)) ; pdcorn (:) = spval + allocate (pdswheat (numpatch)) ; pdswheat (:) = spval + allocate (pdwwheat (numpatch)) ; pdwwheat (:) = spval + allocate (pdsoybean (numpatch)) ; pdsoybean (:) = spval + allocate (pdcotton (numpatch)) ; pdcotton (:) = spval + allocate (pdrice1 (numpatch)) ; pdrice1 (:) = spval + allocate (pdrice2 (numpatch)) ; pdrice2 (:) = spval + allocate (plantdate (numpatch)) ; plantdate (:) = spval + allocate (pdsugarcane (numpatch)) ; pdsugarcane (:) = spval + allocate (manunitro (numpatch)) ; manunitro (:) = spval + allocate (fertnitro_corn (numpatch)) ; fertnitro_corn (:) = spval + allocate (fertnitro_swheat (numpatch)) ; fertnitro_swheat (:) = spval + allocate (fertnitro_wwheat (numpatch)) ; fertnitro_wwheat (:) = spval + allocate (fertnitro_soybean (numpatch)) ; fertnitro_soybean (:) = spval + allocate (fertnitro_cotton (numpatch)) ; fertnitro_cotton (:) = spval + allocate (fertnitro_rice1 (numpatch)) ; fertnitro_rice1 (:) = spval + allocate (fertnitro_rice2 (numpatch)) ; fertnitro_rice2 (:) = spval + allocate (fertnitro_sugarcane (numpatch)) ; fertnitro_sugarcane (:) = spval +#endif + allocate (lag_npp (numpatch)) ; lag_npp (:) = spval + ENDIF + ENDIF + + + END SUBROUTINE allocate_BGCTimeVariables + + + SUBROUTINE deallocate_BGCTimeVariables () + + USE MOD_MPAS_MPI + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + +! -------------------------------------------------- +! Deallocates memory for CoLM 1d [numpatch] variables +! -------------------------------------------------- + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + ! bgc variables + deallocate (decomp_cpools_vr ) + deallocate (decomp_cpools ) + deallocate (decomp_cpools_vr_Cap ) + deallocate (ctrunc_vr ) + deallocate (ctrunc_veg ) + deallocate (ctrunc_soil ) + deallocate (decomp_k ) + + deallocate (t_scalar ) + deallocate (w_scalar ) + deallocate (o_scalar ) + deallocate (depth_scalar ) + + deallocate (som_adv_coef ) + deallocate (som_diffus_coef ) + + deallocate (altmax ) + deallocate (altmax_lastyear ) + deallocate (altmax_lastyear_indx ) + + deallocate (totlitc ) + deallocate (totvegc ) + deallocate (totsomc ) + deallocate (totcwdc ) + deallocate (totcolc ) + deallocate (col_begcb ) + deallocate (col_endcb ) + deallocate (col_vegbegcb ) + deallocate (col_vegendcb ) + deallocate (col_soilbegcb ) + deallocate (col_soilendcb ) + + deallocate (totlitn ) + deallocate (totvegn ) + deallocate (totsomn ) + deallocate (totcwdn ) + deallocate (totcoln ) + deallocate (col_begnb ) + deallocate (col_endnb ) + deallocate (col_vegbegnb ) + deallocate (col_vegendnb ) + deallocate (col_soilbegnb ) + deallocate (col_soilendnb ) + deallocate (col_sminnbegnb ) + deallocate (col_sminnendnb ) + + deallocate (leafc ) + deallocate (leafc_storage ) + deallocate (leafc_xfer ) + deallocate (frootc ) + deallocate (frootc_storage ) + deallocate (frootc_xfer ) + deallocate (livestemc ) + deallocate (livestemc_storage ) + deallocate (livestemc_xfer ) + deallocate (deadstemc ) + deallocate (deadstemc_storage ) + deallocate (deadstemc_xfer ) + deallocate (livecrootc ) + deallocate (livecrootc_storage ) + deallocate (livecrootc_xfer ) + deallocate (deadcrootc ) + deallocate (deadcrootc_storage ) + deallocate (deadcrootc_xfer ) + deallocate (grainc ) + deallocate (grainc_storage ) + deallocate (grainc_xfer ) + deallocate (xsmrpool ) + deallocate (downreg ) + deallocate (cropprod1c ) + deallocate (cropseedc_deficit ) + + deallocate (leafn ) + deallocate (leafn_storage ) + deallocate (leafn_xfer ) + deallocate (frootn ) + deallocate (frootn_storage ) + deallocate (frootn_xfer ) + deallocate (livestemn ) + deallocate (livestemn_storage ) + deallocate (livestemn_xfer ) + deallocate (deadstemn ) + deallocate (deadstemn_storage ) + deallocate (deadstemn_xfer ) + deallocate (livecrootn ) + deallocate (livecrootn_storage ) + deallocate (livecrootn_xfer ) + deallocate (deadcrootn ) + deallocate (deadcrootn_storage ) + deallocate (deadcrootn_xfer ) + deallocate (grainn ) + deallocate (grainn_storage ) + deallocate (grainn_xfer ) + deallocate (retransn ) + + deallocate (leafcCap ) + deallocate (leafc_storageCap ) + deallocate (leafc_xferCap ) + deallocate (frootcCap ) + deallocate (frootc_storageCap ) + deallocate (frootc_xferCap ) + deallocate (livestemcCap ) + deallocate (livestemc_storageCap ) + deallocate (livestemc_xferCap ) + deallocate (deadstemcCap ) + deallocate (deadstemc_storageCap ) + deallocate (deadstemc_xferCap ) + deallocate (livecrootcCap ) + deallocate (livecrootc_storageCap ) + deallocate (livecrootc_xferCap ) + deallocate (deadcrootcCap ) + deallocate (deadcrootc_storageCap ) + deallocate (deadcrootc_xferCap ) + + deallocate (leafnCap ) + deallocate (leafn_storageCap ) + deallocate (leafn_xferCap ) + deallocate (frootnCap ) + deallocate (frootn_storageCap ) + deallocate (frootn_xferCap ) + deallocate (livestemnCap ) + deallocate (livestemn_storageCap ) + deallocate (livestemn_xferCap ) + deallocate (deadstemnCap ) + deallocate (deadstemn_storageCap ) + deallocate (deadstemn_xferCap ) + deallocate (livecrootnCap ) + deallocate (livecrootn_storageCap ) + deallocate (livecrootn_xferCap ) + deallocate (deadcrootnCap ) + deallocate (deadcrootn_storageCap ) + deallocate (deadcrootn_xferCap ) + + deallocate (decomp_npools_vr ) + deallocate (decomp_npools ) + deallocate (decomp_npools_vr_Cap ) + deallocate (totsoiln_vr ) + deallocate (ntrunc_vr ) + deallocate (ntrunc_veg ) + deallocate (ntrunc_soil ) + deallocate (sminn_vr ) + deallocate (smin_no3_vr ) + deallocate (smin_nh4_vr ) + deallocate (sminn ) + deallocate (ndep ) + + deallocate (to2_decomp_depth_unsat ) + deallocate (tconc_o2_unsat ) + + deallocate (ndep_prof ) + deallocate (nfixation_prof ) + + deallocate (cn_decomp_pools ) + deallocate (fpi_vr ) + deallocate (fpi ) + deallocate (fpg ) + + deallocate (cropf ) + deallocate (lfwt ) + deallocate (fuelc ) + deallocate (fuelc_crop ) + deallocate (fsr ) + deallocate (fd ) + deallocate (rootc ) + deallocate (lgdp ) + deallocate (lgdp1 ) + deallocate (lpop ) + deallocate (wtlf ) + deallocate (trotr1 ) + deallocate (trotr2 ) + deallocate (hdm_lf ) + deallocate (lnfm ) + deallocate (baf_crop ) + deallocate (baf_peatf ) + deallocate (farea_burned ) + deallocate (nfire ) + deallocate (fsat ) + deallocate (prec10 ) + deallocate (prec60 ) + deallocate (prec365 ) + deallocate (prec_today ) + deallocate (prec_daily ) + deallocate (wf2 ) + deallocate (tsoi17 ) + deallocate (rh30 ) + deallocate (accumnstep ) + + deallocate (dayl ) + deallocate (prev_dayl ) + + !---------------------------SASU variables-------------------------------------- + deallocate (decomp0_cpools_vr ) + deallocate (I_met_c_vr_acc ) + deallocate (I_cel_c_vr_acc ) + deallocate (I_lig_c_vr_acc ) + deallocate (I_cwd_c_vr_acc ) + deallocate (AKX_met_to_soil1_c_vr_acc ) + deallocate (AKX_cel_to_soil1_c_vr_acc ) + deallocate (AKX_lig_to_soil2_c_vr_acc ) + deallocate (AKX_soil1_to_soil2_c_vr_acc ) + deallocate (AKX_cwd_to_cel_c_vr_acc ) + deallocate (AKX_cwd_to_lig_c_vr_acc ) + deallocate (AKX_soil1_to_soil3_c_vr_acc ) + deallocate (AKX_soil2_to_soil1_c_vr_acc ) + deallocate (AKX_soil2_to_soil3_c_vr_acc ) + deallocate (AKX_soil3_to_soil1_c_vr_acc ) + deallocate (AKX_met_exit_c_vr_acc ) + deallocate (AKX_cel_exit_c_vr_acc ) + deallocate (AKX_lig_exit_c_vr_acc ) + deallocate (AKX_cwd_exit_c_vr_acc ) + deallocate (AKX_soil1_exit_c_vr_acc ) + deallocate (AKX_soil2_exit_c_vr_acc ) + deallocate (AKX_soil3_exit_c_vr_acc ) + + deallocate (decomp0_npools_vr ) + deallocate (I_met_n_vr_acc ) + deallocate (I_cel_n_vr_acc ) + deallocate (I_lig_n_vr_acc ) + deallocate (I_cwd_n_vr_acc ) + deallocate (AKX_met_to_soil1_n_vr_acc ) + deallocate (AKX_cel_to_soil1_n_vr_acc ) + deallocate (AKX_lig_to_soil2_n_vr_acc ) + deallocate (AKX_soil1_to_soil2_n_vr_acc ) + deallocate (AKX_cwd_to_cel_n_vr_acc ) + deallocate (AKX_cwd_to_lig_n_vr_acc ) + deallocate (AKX_soil1_to_soil3_n_vr_acc ) + deallocate (AKX_soil2_to_soil1_n_vr_acc ) + deallocate (AKX_soil2_to_soil3_n_vr_acc ) + deallocate (AKX_soil3_to_soil1_n_vr_acc ) + deallocate (AKX_met_exit_n_vr_acc ) + deallocate (AKX_cel_exit_n_vr_acc ) + deallocate (AKX_lig_exit_n_vr_acc ) + deallocate (AKX_cwd_exit_n_vr_acc ) + deallocate (AKX_soil1_exit_n_vr_acc ) + deallocate (AKX_soil2_exit_n_vr_acc ) + deallocate (AKX_soil3_exit_n_vr_acc ) + + deallocate (diagVX_c_vr_acc ) + deallocate (upperVX_c_vr_acc ) + deallocate (lowerVX_c_vr_acc ) + deallocate (diagVX_n_vr_acc ) + deallocate (upperVX_n_vr_acc ) + deallocate (lowerVX_n_vr_acc ) + + !--------------------------------------------------------------------------- + deallocate (skip_balance_check ) +#ifdef CROP + deallocate (cphase ) + deallocate (vf ) + deallocate (gddplant ) + deallocate (gddmaturity) + deallocate (hui ) + deallocate (huiswheat ) + deallocate (pdcorn ) + deallocate (pdswheat ) + deallocate (pdwwheat ) + deallocate (pdsoybean ) + deallocate (pdcotton ) + deallocate (pdrice1 ) + deallocate (pdrice2 ) + deallocate (plantdate ) + deallocate (pdsugarcane) + deallocate (manunitro ) + deallocate (fertnitro_corn ) + deallocate (fertnitro_swheat ) + deallocate (fertnitro_wwheat ) + deallocate (fertnitro_soybean ) + deallocate (fertnitro_cotton ) + deallocate (fertnitro_rice1 ) + deallocate (fertnitro_rice2 ) + deallocate (fertnitro_sugarcane) +#endif + deallocate (lag_npp ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_BGCTimeVariables + + + !--------------------------------------- + SUBROUTINE WRITE_BGCTimeVariables (file_restart) + +!======================================================================= +! Original version: Yongjiu Dai, September 15, 1999, 03/2014 +!======================================================================= + + USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_NITRIF + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local variables + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil_full', nl_soil_full) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'ndecomp_pools', ndecomp_pools) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'doy' , 365) + + ! bgc variables + CALL ncio_write_vector (file_restart, 'totlitc ', 'patch', landpatch, totlitc ) + CALL ncio_write_vector (file_restart, 'totvegc ', 'patch', landpatch, totvegc ) + CALL ncio_write_vector (file_restart, 'totsomc ', 'patch', landpatch, totsomc ) + CALL ncio_write_vector (file_restart, 'totcwdc ', 'patch', landpatch, totcwdc ) + CALL ncio_write_vector (file_restart, 'totcolc ', 'patch', landpatch, totcolc ) + CALL ncio_write_vector (file_restart, 'totlitn ', 'patch', landpatch, totlitn ) + CALL ncio_write_vector (file_restart, 'totvegn ', 'patch', landpatch, totvegn ) + CALL ncio_write_vector (file_restart, 'totsomn ', 'patch', landpatch, totsomn ) + CALL ncio_write_vector (file_restart, 'totcwdn ', 'patch', landpatch, totcwdn ) + CALL ncio_write_vector (file_restart, 'totcoln ', 'patch', landpatch, totcoln ) + + CALL ncio_write_vector (file_restart, 'sminn ', 'patch', landpatch, sminn ) + CALL ncio_write_vector (file_restart, 'ndep ', 'patch', landpatch, ndep ) + + CALL ncio_write_vector (file_restart, 'decomp_cpools_vr ', 'soil_full', nl_soil_full, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp_cpools_vr) + IF(DEF_USE_DiagMatrix)THEN + CALL ncio_write_vector (file_restart, 'decomp_cpools_vr_Cap ', 'soil_full', nl_soil_full, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp_cpools_vr_Cap) + ENDIF + CALL ncio_write_vector (file_restart, 'ctrunc_vr ', 'soil' , nl_soil, 'patch', landpatch, ctrunc_vr) + CALL ncio_write_vector (file_restart, 'ctrunc_veg ', 'patch', landpatch, ctrunc_veg ) + CALL ncio_write_vector (file_restart, 'ctrunc_soil ', 'patch', landpatch, ctrunc_soil ) + + CALL ncio_write_vector (file_restart, 'altmax ', 'patch', landpatch, altmax ) + CALL ncio_write_vector (file_restart, 'altmax_lastyear ', 'patch', landpatch, altmax_lastyear ) + CALL ncio_write_vector (file_restart, 'altmax_lastyear_indx ', 'patch', landpatch, altmax_lastyear_indx ) + + CALL ncio_write_vector (file_restart, 'decomp_npools_vr ', 'soil_full', nl_soil_full, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp_npools_vr) + CALL ncio_write_vector (file_restart, 'totsoiln_vr ', 'soil' , nl_soil, 'patch', landpatch, totsoiln_vr ) + IF(DEF_USE_DiagMatrix)THEN + CALL ncio_write_vector (file_restart, 'decomp_npools_vr_Cap ', 'soil_full', nl_soil_full, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp_npools_vr_Cap) + ENDIF + CALL ncio_write_vector (file_restart, 'ntrunc_vr ', 'soil' , nl_soil, 'patch', landpatch, ntrunc_vr ) + CALL ncio_write_vector (file_restart, 'ntrunc_veg ', 'patch', landpatch, ntrunc_veg ) + CALL ncio_write_vector (file_restart, 'ntrunc_soil ', 'patch', landpatch, ntrunc_soil ) + CALL ncio_write_vector (file_restart, 'sminn_vr ', 'soil' , nl_soil, 'patch', landpatch, sminn_vr ) + CALL ncio_write_vector (file_restart, 'smin_no3_vr ', 'soil' , nl_soil, 'patch', landpatch, smin_no3_vr ) + CALL ncio_write_vector (file_restart, 'smin_nh4_vr ', 'soil' , nl_soil, 'patch', landpatch, smin_nh4_vr ) + CALL ncio_write_vector (file_restart, 'lag_npp ', 'patch', landpatch, lag_npp ) + + IF(DEF_USE_NITRIF)THEN + CALL ncio_write_vector (file_restart, 'tCONC_O2_UNSAT ', 'soil' , nl_soil, 'patch', landpatch, tconc_o2_unsat) + CALL ncio_write_vector (file_restart, 'tO2_DECOMP_DEPTH_UNSAT','soil' , nl_soil, 'patch', landpatch, to2_decomp_depth_unsat) + ENDIF + + CALL ncio_write_vector (file_restart, 'prec10 ', 'patch', landpatch, prec10 ) + CALL ncio_write_vector (file_restart, 'prec60 ', 'patch', landpatch, prec60 ) + CALL ncio_write_vector (file_restart, 'prec365 ', 'patch', landpatch, prec365 ) + CALL ncio_write_vector (file_restart, 'prec_today ', 'patch', landpatch, prec_today ) + CALL ncio_write_vector (file_restart, 'prec_daily ', 'doy' , 365, 'patch', landpatch, prec_daily ) + CALL ncio_write_vector (file_restart, 'tsoi17 ', 'patch', landpatch, tsoi17 ) + CALL ncio_write_vector (file_restart, 'rh30 ', 'patch', landpatch, rh30 ) + CALL ncio_write_vector (file_restart, 'accumnstep ', 'patch', landpatch, accumnstep ) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + !---------------SASU variables----------------------- + CALL ncio_write_vector (file_restart, 'decomp0_cpools_vr ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp0_cpools_vr ) + CALL ncio_write_vector (file_restart, 'I_met_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_met_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_cel_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_cel_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_lig_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_lig_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_cwd_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_cwd_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_met_to_soil1_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_met_to_soil1_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cel_to_soil1_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cel_to_soil1_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_lig_to_soil2_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_lig_to_soil2_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_to_soil2_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_to_soil2_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_to_cel_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_to_cel_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_to_lig_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_to_lig_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_to_soil3_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_to_soil3_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_to_soil1_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_to_soil1_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_to_soil3_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_to_soil3_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil3_to_soil1_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil3_to_soil1_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_met_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_met_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cel_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cel_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_lig_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_lig_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_exit_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil3_exit_c_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil3_exit_c_vr_acc ) + + CALL ncio_write_vector (file_restart, 'decomp0_npools_vr ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, decomp0_npools_vr ) + CALL ncio_write_vector (file_restart, 'I_met_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_met_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_cel_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_cel_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_lig_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_lig_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'I_cwd_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, I_cwd_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_met_to_soil1_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_met_to_soil1_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cel_to_soil1_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cel_to_soil1_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_lig_to_soil2_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_lig_to_soil2_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_to_soil2_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_to_soil2_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_to_cel_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_to_cel_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_to_lig_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_to_lig_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_to_soil3_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_to_soil3_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_to_soil1_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_to_soil1_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_to_soil3_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_to_soil3_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil3_to_soil1_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil3_to_soil1_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_met_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_met_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cel_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cel_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_lig_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_lig_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_cwd_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_cwd_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil1_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil1_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil2_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil2_exit_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'AKX_soil3_exit_n_vr_acc ', 'soil' , nl_soil, 'patch', landpatch, AKX_soil3_exit_n_vr_acc ) + + CALL ncio_write_vector (file_restart, 'diagVX_c_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, diagVX_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'upperVX_c_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, upperVX_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'lowerVX_c_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, lowerVX_c_vr_acc ) + CALL ncio_write_vector (file_restart, 'diagVX_n_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, diagVX_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'upperVX_n_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, upperVX_n_vr_acc ) + CALL ncio_write_vector (file_restart, 'lowerVX_n_vr_acc ', 'soil' , nl_soil, 'ndecomp_pools', ndecomp_pools, & + 'patch', landpatch, lowerVX_n_vr_acc ) + + !---------------------------------------------------- + ENDIF + CALL ncio_write_vector (file_restart, 'skip_balance_check ', 'patch', landpatch, skip_balance_check ) + +#ifdef CROP + CALL ncio_write_vector (file_restart, 'cphase ' , 'patch', landpatch, cphase ) + CALL ncio_write_vector (file_restart, 'pdcorn ' , 'patch', landpatch, pdcorn , compress) + CALL ncio_write_vector (file_restart, 'pdswheat ' , 'patch', landpatch, pdswheat , compress) + CALL ncio_write_vector (file_restart, 'pdwwheat ' , 'patch', landpatch, pdwwheat , compress) + CALL ncio_write_vector (file_restart, 'pdsoybean ' , 'patch', landpatch, pdsoybean , compress) + CALL ncio_write_vector (file_restart, 'pdcotton ' , 'patch', landpatch, pdcotton , compress) + CALL ncio_write_vector (file_restart, 'pdrice1 ' , 'patch', landpatch, pdrice1 , compress) + CALL ncio_write_vector (file_restart, 'pdrice2 ' , 'patch', landpatch, pdrice2 , compress) + CALL ncio_write_vector (file_restart, 'pdsugarcane' , 'patch', landpatch, pdsugarcane, compress) + CALL ncio_write_vector (file_restart, 'fertnitro_corn ' , 'patch', landpatch, fertnitro_corn , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_swheat ' , 'patch', landpatch, fertnitro_swheat , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_wwheat ' , 'patch', landpatch, fertnitro_wwheat , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_soybean ' , 'patch', landpatch, fertnitro_soybean , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_cotton ' , 'patch', landpatch, fertnitro_cotton , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_rice1 ' , 'patch', landpatch, fertnitro_rice1 , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_rice2 ' , 'patch', landpatch, fertnitro_rice2 , compress) + CALL ncio_write_vector (file_restart, 'fertnitro_sugarcane' , 'patch', landpatch, fertnitro_sugarcane, compress) +#endif + + END SUBROUTINE WRITE_BGCTimeVariables + + !--------------------------------------- + SUBROUTINE READ_BGCTimeVariables (file_restart) + +!======================================================================= +! Original version: Yongjiu Dai, September 15, 1999, 03/2014 +!======================================================================= + + USE MOD_Namelist + USE MOD_MPAS_MPI + USE MOD_NetCDFVector +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + +! bgc variables + CALL ncio_read_vector (file_restart, 'totlitc ', landpatch, totlitc ) + CALL ncio_read_vector (file_restart, 'totvegc ', landpatch, totvegc ) + CALL ncio_read_vector (file_restart, 'totsomc ', landpatch, totsomc ) + CALL ncio_read_vector (file_restart, 'totcwdc ', landpatch, totcwdc ) + CALL ncio_read_vector (file_restart, 'totcolc ', landpatch, totcolc ) + CALL ncio_read_vector (file_restart, 'totlitn ', landpatch, totlitn ) + CALL ncio_read_vector (file_restart, 'totvegn ', landpatch, totvegn ) + CALL ncio_read_vector (file_restart, 'totsomn ', landpatch, totsomn ) + CALL ncio_read_vector (file_restart, 'totcwdn ', landpatch, totcwdn ) + CALL ncio_read_vector (file_restart, 'totcoln ', landpatch, totcoln ) + + CALL ncio_read_vector (file_restart, 'sminn ', landpatch, sminn ) + CALL ncio_read_vector (file_restart, 'ndep ', landpatch, ndep ) + + CALL ncio_read_vector (file_restart, 'decomp_cpools_vr ', nl_soil_full, ndecomp_pools, landpatch, decomp_cpools_vr) + IF(DEF_USE_DiagMatrix)THEN + CALL ncio_read_vector (file_restart, 'decomp_cpools_vr_Cap ', nl_soil_full, ndecomp_pools, landpatch, decomp_cpools_vr_Cap, defval = 1._r8) + ENDIF + CALL ncio_read_vector (file_restart, 'ctrunc_vr ', nl_soil, landpatch, ctrunc_vr ) + CALL ncio_read_vector (file_restart, 'ctrunc_veg ', landpatch, ctrunc_veg ) + CALL ncio_read_vector (file_restart, 'ctrunc_soil ', landpatch, ctrunc_soil ) + + CALL ncio_read_vector (file_restart, 'altmax ', landpatch, altmax ) + CALL ncio_read_vector (file_restart, 'altmax_lastyear ', landpatch, altmax_lastyear ) + CALL ncio_read_vector (file_restart, 'altmax_lastyear_indx ', landpatch, altmax_lastyear_indx ) + + CALL ncio_read_vector (file_restart, 'decomp_npools_vr ', nl_soil_full, ndecomp_pools, landpatch, decomp_npools_vr) + CALL ncio_read_vector (file_restart, 'totsoiln_vr ', nl_soil, landpatch, totsoiln_vr, defval = 1._r8) + IF(DEF_USE_DiagMatrix)THEN + CALL ncio_read_vector (file_restart, 'decomp_npools_vr_Cap ',nl_soil_full, ndecomp_pools, landpatch, decomp_npools_vr_Cap, defval = 1._r8) + ENDIF + CALL ncio_read_vector (file_restart, 'ntrunc_vr ', nl_soil, landpatch, ntrunc_vr ) + CALL ncio_read_vector (file_restart, 'ntrunc_veg ', landpatch, ntrunc_veg ) + CALL ncio_read_vector (file_restart, 'ntrunc_soil ', landpatch, ntrunc_soil ) + CALL ncio_read_vector (file_restart, 'sminn_vr ', nl_soil, landpatch, sminn_vr ) + CALL ncio_read_vector (file_restart, 'smin_no3_vr ', nl_soil, landpatch, smin_no3_vr) + CALL ncio_read_vector (file_restart, 'smin_nh4_vr ', nl_soil, landpatch, smin_nh4_vr) + CALL ncio_read_vector (file_restart, 'lag_npp ', landpatch, lag_npp, defval =spval ) + + IF(DEF_USE_NITRIF)THEN + CALL ncio_read_vector (file_restart, 'tCONC_O2_UNSAT ', nl_soil, landpatch, tconc_o2_unsat ) + CALL ncio_read_vector (file_restart, 'tO2_DECOMP_DEPTH_UNSAT', nl_soil, landpatch, to2_decomp_depth_unsat ) + ENDIF + + CALL ncio_read_vector (file_restart, 'prec10 ', landpatch, prec10 ) + CALL ncio_read_vector (file_restart, 'prec60 ', landpatch, prec60 ) + CALL ncio_read_vector (file_restart, 'prec365 ', landpatch, prec365 ) + CALL ncio_read_vector (file_restart, 'prec_today ', landpatch, prec_today ) + CALL ncio_read_vector (file_restart, 'prec_daily ', 365, landpatch, prec_daily) + CALL ncio_read_vector (file_restart, 'tsoi17 ', landpatch, tsoi17 ) + CALL ncio_read_vector (file_restart, 'rh30 ', landpatch, rh30 ) + CALL ncio_read_vector (file_restart, 'accumnstep ', landpatch, accumnstep ) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + !---------------SASU variables----------------------- + CALL ncio_read_vector (file_restart, 'decomp0_cpools_vr ', nl_soil, ndecomp_pools, landpatch, decomp0_cpools_vr, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'I_met_c_vr_acc ', nl_soil, landpatch, I_met_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_cel_c_vr_acc ', nl_soil, landpatch, I_cel_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_lig_c_vr_acc ', nl_soil, landpatch, I_lig_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_cwd_c_vr_acc ', nl_soil, landpatch, I_cwd_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_met_to_soil1_c_vr_acc ', nl_soil, landpatch, AKX_met_to_soil1_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cel_to_soil1_c_vr_acc ', nl_soil, landpatch, AKX_cel_to_soil1_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_lig_to_soil2_c_vr_acc ', nl_soil, landpatch, AKX_lig_to_soil2_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_to_soil2_c_vr_acc ', nl_soil, landpatch, AKX_soil1_to_soil2_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_to_cel_c_vr_acc ', nl_soil, landpatch, AKX_cwd_to_cel_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_to_lig_c_vr_acc ', nl_soil, landpatch, AKX_cwd_to_lig_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_to_soil3_c_vr_acc ', nl_soil, landpatch, AKX_soil1_to_soil3_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_to_soil1_c_vr_acc ', nl_soil, landpatch, AKX_soil2_to_soil1_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_to_soil3_c_vr_acc ', nl_soil, landpatch, AKX_soil2_to_soil3_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil3_to_soil1_c_vr_acc ', nl_soil, landpatch, AKX_soil3_to_soil1_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_met_exit_c_vr_acc ', nl_soil, landpatch, AKX_met_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cel_exit_c_vr_acc ', nl_soil, landpatch, AKX_cel_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_lig_exit_c_vr_acc ', nl_soil, landpatch, AKX_lig_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_exit_c_vr_acc ', nl_soil, landpatch, AKX_cwd_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_exit_c_vr_acc ', nl_soil, landpatch, AKX_soil1_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_exit_c_vr_acc ', nl_soil, landpatch, AKX_soil2_exit_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil3_exit_c_vr_acc ', nl_soil, landpatch, AKX_soil3_exit_c_vr_acc, defval = 0._r8 ) + + CALL ncio_read_vector (file_restart, 'decomp0_npools_vr ', nl_soil, ndecomp_pools, landpatch, decomp0_npools_vr, defval = 1._r8) + CALL ncio_read_vector (file_restart, 'I_met_n_vr_acc ', nl_soil, landpatch, I_met_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_cel_n_vr_acc ', nl_soil, landpatch, I_cel_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_lig_n_vr_acc ', nl_soil, landpatch, I_lig_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'I_cwd_n_vr_acc ', nl_soil, landpatch, I_cwd_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_met_to_soil1_n_vr_acc ', nl_soil, landpatch, AKX_met_to_soil1_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cel_to_soil1_n_vr_acc ', nl_soil, landpatch, AKX_cel_to_soil1_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_lig_to_soil2_n_vr_acc ', nl_soil, landpatch, AKX_lig_to_soil2_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_to_soil2_n_vr_acc ', nl_soil, landpatch, AKX_soil1_to_soil2_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_to_cel_n_vr_acc ', nl_soil, landpatch, AKX_cwd_to_cel_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_to_lig_n_vr_acc ', nl_soil, landpatch, AKX_cwd_to_lig_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_to_soil3_n_vr_acc ', nl_soil, landpatch, AKX_soil1_to_soil3_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_to_soil1_n_vr_acc ', nl_soil, landpatch, AKX_soil2_to_soil1_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_to_soil3_n_vr_acc ', nl_soil, landpatch, AKX_soil2_to_soil3_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil3_to_soil1_n_vr_acc ', nl_soil, landpatch, AKX_soil3_to_soil1_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_met_exit_n_vr_acc ', nl_soil, landpatch, AKX_met_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cel_exit_n_vr_acc ', nl_soil, landpatch, AKX_cel_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_lig_exit_n_vr_acc ', nl_soil, landpatch, AKX_lig_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_cwd_exit_n_vr_acc ', nl_soil, landpatch, AKX_cwd_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil1_exit_n_vr_acc ', nl_soil, landpatch, AKX_soil1_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil2_exit_n_vr_acc ', nl_soil, landpatch, AKX_soil2_exit_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'AKX_soil3_exit_n_vr_acc ', nl_soil, landpatch, AKX_soil3_exit_n_vr_acc, defval = 0._r8 ) + + CALL ncio_read_vector (file_restart, 'diagVX_c_vr_acc ', nl_soil, ndecomp_pools, landpatch, diagVX_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'upperVX_c_vr_acc ', nl_soil, ndecomp_pools, landpatch, upperVX_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'lowerVX_c_vr_acc ', nl_soil, ndecomp_pools, landpatch, lowerVX_c_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'diagVX_n_vr_acc ', nl_soil, ndecomp_pools, landpatch, diagVX_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'upperVX_n_vr_acc ', nl_soil, ndecomp_pools, landpatch, upperVX_n_vr_acc, defval = 0._r8 ) + CALL ncio_read_vector (file_restart, 'lowerVX_n_vr_acc ', nl_soil, ndecomp_pools, landpatch, lowerVX_n_vr_acc, defval = 0._r8 ) + ENDIF + + !---------------------------------------------------- + CALL ncio_read_vector (file_restart, 'skip_balance_check ', landpatch, skip_balance_check ) +#ifdef CROP + CALL ncio_read_vector (file_restart, 'cphase ' , landpatch, cphase ) + CALL ncio_read_vector (file_restart, 'pdcorn ' , landpatch, pdcorn ) + CALL ncio_read_vector (file_restart, 'pdswheat ' , landpatch, pdswheat ) + CALL ncio_read_vector (file_restart, 'pdwwheat ' , landpatch, pdwwheat ) + CALL ncio_read_vector (file_restart, 'pdsoybean ' , landpatch, pdsoybean ) + CALL ncio_read_vector (file_restart, 'pdcotton ' , landpatch, pdcotton ) + CALL ncio_read_vector (file_restart, 'pdrice1 ' , landpatch, pdrice1 ) + CALL ncio_read_vector (file_restart, 'pdrice2 ' , landpatch, pdrice2 ) + CALL ncio_read_vector (file_restart, 'pdsugarcane' , landpatch, pdsugarcane) + CALL ncio_read_vector (file_restart, 'fertnitro_corn ' , landpatch, fertnitro_corn ) + CALL ncio_read_vector (file_restart, 'fertnitro_swheat ' , landpatch, fertnitro_swheat ) + CALL ncio_read_vector (file_restart, 'fertnitro_wwheat ' , landpatch, fertnitro_wwheat ) + CALL ncio_read_vector (file_restart, 'fertnitro_soybean ' , landpatch, fertnitro_soybean ) + CALL ncio_read_vector (file_restart, 'fertnitro_cotton ' , landpatch, fertnitro_cotton ) + CALL ncio_read_vector (file_restart, 'fertnitro_rice1 ' , landpatch, fertnitro_rice1 ) + CALL ncio_read_vector (file_restart, 'fertnitro_rice2 ' , landpatch, fertnitro_rice2 ) + CALL ncio_read_vector (file_restart, 'fertnitro_sugarcane' , landpatch, fertnitro_sugarcane) +#endif + +#ifdef RangeCheck + CALL check_BGCTimeVariables +#endif + + END SUBROUTINE READ_BGCTimeVariables + + !--------------------------------------- +#ifdef RangeCheck + SUBROUTINE check_BGCTimeVariables () + + USE MOD_MPAS_MPI + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_USE_NITRIF, DEF_USE_SASU, DEF_USE_DiagMatrix + + IMPLICIT NONE + +! bgc variables + CALL check_vector_data ('decomp_cpools_vr ', decomp_cpools_vr ) + CALL check_vector_data ('decomp_cpools ', decomp_cpools ) + IF(DEF_USE_DiagMatrix)THEN + CALL check_vector_data ('decomp_cpools_vr_Cap',decomp_cpools_vr_Cap) + ENDIF + CALL check_vector_data ('decomp_k ', decomp_k ) + CALL check_vector_data ('ctrunc_vr ', ctrunc_vr ) + CALL check_vector_data ('ctrunc_veg ', ctrunc_veg ) + CALL check_vector_data ('ctrunc_soil ', ctrunc_soil ) + + CALL check_vector_data ('t_scalar ', t_scalar ) + CALL check_vector_data ('w_scalar ', w_scalar ) + CALL check_vector_data ('o_scalar ', o_scalar ) + CALL check_vector_data ('depth_scalar ', depth_scalar ) + + ! Soil CN diffusion and advection + CALL check_vector_data ('som_adv_coef ', som_adv_coef ) + CALL check_vector_data ('som_diffus_coef ', som_diffus_coef ) + + ! Active Layer + CALL check_vector_data ('altmax ', altmax ) + CALL check_vector_data ('altmax_lastyear ', altmax_lastyear ) + !CALL check_vector_data ('altmax_lastyear_indx ', altmax_lastyear_indx ) + + CALL check_vector_data ('totlitc ', totlitc ) + CALL check_vector_data ('totvegc ', totvegc ) + CALL check_vector_data ('totsomc ', totsomc ) + CALL check_vector_data ('totcwdc ', totcwdc ) + CALL check_vector_data ('totcolc ', totcolc ) + CALL check_vector_data ('col_begcb ', col_begcb ) + CALL check_vector_data ('col_endcb ', col_endcb ) + CALL check_vector_data ('col_vegbegcb ', col_vegbegcb ) + CALL check_vector_data ('col_vegendcb ', col_vegendcb ) + CALL check_vector_data ('col_soilbegcb ', col_soilbegcb ) + CALL check_vector_data ('col_soilendcb ', col_soilendcb ) + + CALL check_vector_data ('totlitn ', totlitn ) + CALL check_vector_data ('totvegn ', totvegn ) + CALL check_vector_data ('totsomn ', totsomn ) + CALL check_vector_data ('totcwdn ', totcwdn ) + CALL check_vector_data ('totcoln ', totcoln ) + CALL check_vector_data ('col_begnb ', col_begnb ) + CALL check_vector_data ('col_endnb ', col_endnb ) + CALL check_vector_data ('col_vegbegnb ', col_vegbegnb ) + CALL check_vector_data ('col_vegendnb ', col_vegendnb ) + CALL check_vector_data ('col_soilbegnb ', col_soilbegnb ) + CALL check_vector_data ('col_soilendnb ', col_soilendnb ) + CALL check_vector_data ('col_sminnbegnb ', col_sminnbegnb ) + CALL check_vector_data ('col_sminnendnb ', col_sminnendnb ) + + CALL check_vector_data ('leafc ', leafc ) + CALL check_vector_data ('leafc_storage ', leafc_storage ) + CALL check_vector_data ('leafc_xfer ', leafc_xfer ) + CALL check_vector_data ('frootc ', frootc ) + CALL check_vector_data ('frootc_storage ', frootc_storage ) + CALL check_vector_data ('frootc_xfer ', frootc_xfer ) + CALL check_vector_data ('livestemc ', livestemc ) + CALL check_vector_data ('livestemc_storage ', livestemc_storage ) + CALL check_vector_data ('livestemc_xfer ', livestemc_xfer ) + CALL check_vector_data ('deadstemc ', deadstemc ) + CALL check_vector_data ('deadstemc_storage ', deadstemc_storage ) + CALL check_vector_data ('deadstemc_xfer ', deadstemc_xfer ) + CALL check_vector_data ('livecrootc ', livecrootc ) + CALL check_vector_data ('livecrootc_storage ', livecrootc_storage ) + CALL check_vector_data ('livecrootc_xfer ', livecrootc_xfer ) + CALL check_vector_data ('deadcrootc ', deadcrootc ) + CALL check_vector_data ('deadcrootc_storage ', deadcrootc_storage ) + CALL check_vector_data ('deadcrootc_xfer ', deadcrootc_xfer ) + CALL check_vector_data ('grainc ', grainc ) + CALL check_vector_data ('grainc_storage ', grainc_storage ) + CALL check_vector_data ('grainc_xfer ', grainc_xfer ) + CALL check_vector_data ('xsmrpool ', xsmrpool ) + CALL check_vector_data ('downreg ', downreg ) + CALL check_vector_data ('cropprod1c ', cropprod1c ) + CALL check_vector_data ('cropseedc_deficit ', cropseedc_deficit ) + + CALL check_vector_data ('leafn ', leafn ) + CALL check_vector_data ('leafn_storage ', leafn_storage ) + CALL check_vector_data ('leafn_xfer ', leafn_xfer ) + CALL check_vector_data ('frootn ', frootn ) + CALL check_vector_data ('frootn_storage ', frootn_storage ) + CALL check_vector_data ('frootn_xfer ', frootn_xfer ) + CALL check_vector_data ('livestemn ', livestemn ) + CALL check_vector_data ('livestemn_storage ', livestemn_storage ) + CALL check_vector_data ('livestemn_xfer ', livestemn_xfer ) + CALL check_vector_data ('deadstemn ', deadstemn ) + CALL check_vector_data ('deadstemn_storage ', deadstemn_storage ) + CALL check_vector_data ('deadstemn_xfer ', deadstemn_xfer ) + CALL check_vector_data ('livecrootn ', livecrootn ) + CALL check_vector_data ('livecrootn_storage ', livecrootn_storage ) + CALL check_vector_data ('livecrootn_xfer ', livecrootn_xfer ) + CALL check_vector_data ('deadcrootn ', deadcrootn ) + CALL check_vector_data ('deadcrootn_storage ', deadcrootn_storage ) + CALL check_vector_data ('deadcrootn_xfer ', deadcrootn_xfer ) + CALL check_vector_data ('grainn ', grainn ) + CALL check_vector_data ('grainn_storage ', grainn_storage ) + CALL check_vector_data ('grainn_xfer ', grainn_xfer ) + CALL check_vector_data ('retransn ', retransn ) + + IF(DEF_USE_DiagMatrix)THEN + CALL check_vector_data ('leafcCap ', leafcCap ) + CALL check_vector_data ('leafc_storageCap ', leafc_storageCap ) + CALL check_vector_data ('leafc_xferCap ', leafc_xferCap ) + CALL check_vector_data ('frootcCap ', frootcCap ) + CALL check_vector_data ('frootc_storageCap ', frootc_storageCap ) + CALL check_vector_data ('frootc_xferCap ', frootc_xferCap ) + CALL check_vector_data ('livestemcCap ', livestemcCap ) + CALL check_vector_data ('livestemc_storageCap ', livestemc_storageCap ) + CALL check_vector_data ('livestemc_xferCap ', livestemc_xferCap ) + CALL check_vector_data ('deadstemcCap ', deadstemcCap ) + CALL check_vector_data ('deadstemc_storageCap ', deadstemc_storageCap ) + CALL check_vector_data ('deadstemc_xferCap ', deadstemc_xferCap ) + CALL check_vector_data ('livecrootcCap ', livecrootcCap ) + CALL check_vector_data ('livecrootc_storageCap ', livecrootc_storageCap ) + CALL check_vector_data ('livecrootc_xferCap ', livecrootc_xferCap ) + CALL check_vector_data ('deadcrootcCap ', deadcrootcCap ) + CALL check_vector_data ('deadcrootc_storageCap ', deadcrootc_storageCap ) + CALL check_vector_data ('deadcrootc_xferCap ', deadcrootc_xferCap ) + + CALL check_vector_data ('leafnCap ', leafnCap ) + CALL check_vector_data ('leafn_storageCap ', leafn_storageCap ) + CALL check_vector_data ('leafn_xferCap ', leafn_xferCap ) + CALL check_vector_data ('frootnCap ', frootnCap ) + CALL check_vector_data ('frootn_storageCap ', frootn_storageCap ) + CALL check_vector_data ('frootn_xferCap ', frootn_xferCap ) + CALL check_vector_data ('livestemnCap ', livestemnCap ) + CALL check_vector_data ('livestemn_storageCap ', livestemn_storageCap ) + CALL check_vector_data ('livestemn_xferCap ', livestemn_xferCap ) + CALL check_vector_data ('deadstemnCap ', deadstemnCap ) + CALL check_vector_data ('deadstemn_storageCap ', deadstemn_storageCap ) + CALL check_vector_data ('deadstemn_xferCap ', deadstemn_xferCap ) + CALL check_vector_data ('livecrootnCap ', livecrootnCap ) + CALL check_vector_data ('livecrootn_storageCap ', livecrootn_storageCap ) + CALL check_vector_data ('livecrootn_xferCap ', livecrootn_xferCap ) + CALL check_vector_data ('deadcrootnCap ', deadcrootnCap ) + CALL check_vector_data ('deadcrootn_storageCap ', deadcrootn_storageCap ) + CALL check_vector_data ('deadcrootn_xferCap ', deadcrootn_xferCap ) + + ENDIF + + CALL check_vector_data ('decomp_npools_vr ', decomp_npools_vr ) + CALL check_vector_data ('decomp_npools ', decomp_npools ) + CALL check_vector_data ('totsoiln_vr ', totsoiln_vr ) + IF(DEF_USE_DiagMatrix)THEN + CALL check_vector_data ('decomp_npools_vr_Cap ',decomp_npools_vr_Cap ) + ENDIF + CALL check_vector_data ('ntrunc_vr ', ntrunc_vr ) + CALL check_vector_data ('ntrunc_veg ', ntrunc_veg ) + CALL check_vector_data ('ntrunc_soil ', ntrunc_soil ) + + CALL check_vector_data ('sminn_vr ', sminn_vr ) + CALL check_vector_data ('smin_no3_vr ', smin_no3_vr ) + CALL check_vector_data ('smin_nh4_vr ', smin_nh4_vr ) + + IF(DEF_USE_NITRIF)THEN + CALL check_vector_data ('tCONC_O2_UNSAT ', tconc_o2_unsat ) + CALL check_vector_data ('tO2_DECOMP_DEPTH_UNSAT ', to2_decomp_depth_unsat) + ENDIF + + CALL check_vector_data ('sminn ', sminn ) + CALL check_vector_data ('ndep ', ndep ) + + CALL check_vector_data ('ndep_prof ', ndep_prof ) + CALL check_vector_data ('nfixation_prof ', nfixation_prof ) + + CALL check_vector_data ('cn_decomp_pools ', cn_decomp_pools ) + CALL check_vector_data ('fpi_vr ', fpi_vr ) + CALL check_vector_data ('fpi ', fpi ) + CALL check_vector_data ('fpg ', fpg ) + + CALL check_vector_data ('cropf ', cropf ) + CALL check_vector_data ('lfwt ', lfwt ) + CALL check_vector_data ('fuelc ', fuelc ) + CALL check_vector_data ('fuelc_crop ', fuelc_crop ) + CALL check_vector_data ('fsr ', fsr ) + CALL check_vector_data ('fd ', fd ) + CALL check_vector_data ('rootc ', rootc ) + CALL check_vector_data ('lgdp ', lgdp ) + CALL check_vector_data ('lgdp1 ', lgdp1 ) + CALL check_vector_data ('lpop ', lpop ) + CALL check_vector_data ('wtlf ', wtlf ) + CALL check_vector_data ('trotr1 ', trotr1 ) + CALL check_vector_data ('trotr2 ', trotr2 ) + CALL check_vector_data ('hdm_lf ', hdm_lf ) + CALL check_vector_data ('lnfm ', lnfm ) + CALL check_vector_data ('baf_crop ', baf_crop ) + CALL check_vector_data ('baf_peatf ', baf_peatf ) + CALL check_vector_data ('farea_burned ', farea_burned ) + CALL check_vector_data ('nfire ', nfire ) + CALL check_vector_data ('fsat ', fsat ) + CALL check_vector_data ('prec10 ', prec10 ) + CALL check_vector_data ('prec60 ', prec60 ) + CALL check_vector_data ('prec365 ', prec365 ) + CALL check_vector_data ('prec_today ', prec_today ) + CALL check_vector_data ('prec_daily ', prec_daily ) + CALL check_vector_data ('wf2 ', wf2 ) + CALL check_vector_data ('tsoi17 ', tsoi17 ) + CALL check_vector_data ('rh30 ', rh30 ) + CALL check_vector_data ('accumnstep ', accumnstep ) + + CALL check_vector_data ('dayl ', dayl ) + CALL check_vector_data ('prev_dayl ', prev_dayl ) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + !--------------SASU variables--------------------------- + CALL check_vector_data ('decomp0_cpools_vr ', decomp0_cpools_vr ) + CALL check_vector_data ('I_met_c_vr_acc ', I_met_c_vr_acc ) + CALL check_vector_data ('I_cel_c_vr_acc ', I_cel_c_vr_acc ) + CALL check_vector_data ('I_lig_c_vr_acc ', I_lig_c_vr_acc ) + CALL check_vector_data ('I_cwd_c_vr_acc ', I_cwd_c_vr_acc ) + CALL check_vector_data ('AKX_met_to_soil1_c_vr_acc ', AKX_met_to_soil1_c_vr_acc ) + CALL check_vector_data ('AKX_cel_to_soil1_c_vr_acc ', AKX_cel_to_soil1_c_vr_acc ) + CALL check_vector_data ('AKX_lig_to_soil2_c_vr_acc ', AKX_lig_to_soil2_c_vr_acc ) + CALL check_vector_data ('AKX_soil1_to_soil2_c_vr_acc ', AKX_soil1_to_soil2_c_vr_acc ) + CALL check_vector_data ('AKX_cwd_to_cel_c_vr_acc ', AKX_cwd_to_cel_c_vr_acc ) + CALL check_vector_data ('AKX_cwd_to_lig_c_vr_acc ', AKX_cwd_to_lig_c_vr_acc ) + CALL check_vector_data ('AKX_soil1_to_soil3_c_vr_acc ', AKX_soil1_to_soil3_c_vr_acc ) + CALL check_vector_data ('AKX_soil2_to_soil1_c_vr_acc ', AKX_soil2_to_soil1_c_vr_acc ) + CALL check_vector_data ('AKX_soil2_to_soil3_c_vr_acc ', AKX_soil2_to_soil3_c_vr_acc ) + CALL check_vector_data ('AKX_soil3_to_soil1_c_vr_acc ', AKX_soil3_to_soil1_c_vr_acc ) + CALL check_vector_data ('AKX_met_exit_c_vr_acc ', AKX_met_exit_c_vr_acc ) + CALL check_vector_data ('AKX_cel_exit_c_vr_acc ', AKX_cel_exit_c_vr_acc ) + CALL check_vector_data ('AKX_lig_exit_c_vr_acc ', AKX_lig_exit_c_vr_acc ) + CALL check_vector_data ('AKX_cwd_exit_c_vr_acc ', AKX_cwd_exit_c_vr_acc ) + CALL check_vector_data ('AKX_soil1_exit_c_vr_acc ', AKX_soil1_exit_c_vr_acc ) + CALL check_vector_data ('AKX_soil2_exit_c_vr_acc ', AKX_soil2_exit_c_vr_acc ) + CALL check_vector_data ('AKX_soil3_exit_c_vr_acc ', AKX_soil3_exit_c_vr_acc ) + + CALL check_vector_data ('decomp0_npools_vr ', decomp0_npools_vr ) + CALL check_vector_data ('I_met_n_vr_acc ', I_met_n_vr_acc ) + CALL check_vector_data ('I_cel_n_vr_acc ', I_cel_n_vr_acc ) + CALL check_vector_data ('I_lig_n_vr_acc ', I_lig_n_vr_acc ) + CALL check_vector_data ('I_cwd_n_vr_acc ', I_cwd_n_vr_acc ) + CALL check_vector_data ('AKX_met_to_soil1_n_vr_acc ', AKX_met_to_soil1_n_vr_acc ) + CALL check_vector_data ('AKX_cel_to_soil1_n_vr_acc ', AKX_cel_to_soil1_n_vr_acc ) + CALL check_vector_data ('AKX_lig_to_soil2_n_vr_acc ', AKX_lig_to_soil2_n_vr_acc ) + CALL check_vector_data ('AKX_soil1_to_soil2_n_vr_acc ', AKX_soil1_to_soil2_n_vr_acc ) + CALL check_vector_data ('AKX_cwd_to_cel_n_vr_acc ', AKX_cwd_to_cel_n_vr_acc ) + CALL check_vector_data ('AKX_cwd_to_lig_n_vr_acc ', AKX_cwd_to_lig_n_vr_acc ) + CALL check_vector_data ('AKX_soil1_to_soil3_n_vr_acc ', AKX_soil1_to_soil3_n_vr_acc ) + CALL check_vector_data ('AKX_soil2_to_soil1_n_vr_acc ', AKX_soil2_to_soil1_n_vr_acc ) + CALL check_vector_data ('AKX_soil2_to_soil3_n_vr_acc ', AKX_soil2_to_soil3_n_vr_acc ) + CALL check_vector_data ('AKX_soil3_to_soil1_n_vr_acc ', AKX_soil3_to_soil1_n_vr_acc ) + CALL check_vector_data ('AKX_met_exit_n_vr_acc ', AKX_met_exit_n_vr_acc ) + CALL check_vector_data ('AKX_cel_exit_n_vr_acc ', AKX_cel_exit_n_vr_acc ) + CALL check_vector_data ('AKX_lig_exit_n_vr_acc ', AKX_lig_exit_n_vr_acc ) + CALL check_vector_data ('AKX_cwd_exit_n_vr_acc ', AKX_cwd_exit_n_vr_acc ) + CALL check_vector_data ('AKX_soil1_exit_n_vr_acc ', AKX_soil1_exit_n_vr_acc ) + CALL check_vector_data ('AKX_soil2_exit_n_vr_acc ', AKX_soil2_exit_n_vr_acc ) + CALL check_vector_data ('AKX_soil3_exit_n_vr_acc ', AKX_soil3_exit_n_vr_acc ) + + CALL check_vector_data ('diagVX_c_vr_acc ', diagVX_c_vr_acc ) + CALL check_vector_data ('upperVX_c_vr_acc ', upperVX_c_vr_acc ) + CALL check_vector_data ('lowerVX_c_vr_acc ', lowerVX_c_vr_acc ) + CALL check_vector_data ('diagVX_n_vr_acc ', diagVX_n_vr_acc ) + CALL check_vector_data ('upperVX_n_vr_acc ', upperVX_n_vr_acc ) + CALL check_vector_data ('lowerVX_n_vr_acc ', lowerVX_n_vr_acc ) + ! CALL check_vector_data ('skip_balance_check ', skip_balance_check ) + !------------------------------------------------------ + ENDIF +#ifdef CROP + CALL check_vector_data ('cphase ' , cphase ) + CALL check_vector_data ('vf ' , vf ) + CALL check_vector_data ('hui ' , hui ) + CALL check_vector_data ('huiswheat ' , huiswheat ) + CALL check_vector_data ('gddplant ' , gddplant ) + CALL check_vector_data ('gddmaturity' , gddmaturity) + CALL check_vector_data ('pdcorn ' , pdcorn ) + CALL check_vector_data ('pdswheat ' , pdswheat ) + CALL check_vector_data ('pdwwheat ' , pdwwheat ) + CALL check_vector_data ('pdsoybean ' , pdsoybean ) + CALL check_vector_data ('pdcotton ' , pdcotton ) + CALL check_vector_data ('pdrice1 ' , pdrice1 ) + CALL check_vector_data ('pdrice2 ' , pdrice2 ) + CALL check_vector_data ('plantdate ' , plantdate ) + CALL check_vector_data ('pdsugarcane' , pdsugarcane) + CALL check_vector_data ('manunitro ' , manunitro ) + CALL check_vector_data ('fertnitro_corn ' , fertnitro_corn ) + CALL check_vector_data ('fertnitro_swheat ' , fertnitro_swheat ) + CALL check_vector_data ('fertnitro_wwheat ' , fertnitro_wwheat ) + CALL check_vector_data ('fertnitro_soybean ' , fertnitro_soybean ) + CALL check_vector_data ('fertnitro_cotton ' , fertnitro_cotton ) + CALL check_vector_data ('fertnitro_rice1 ' , fertnitro_rice1 ) + CALL check_vector_data ('fertnitro_rice2 ' , fertnitro_rice2 ) + CALL check_vector_data ('fertnitro_sugarcane' , fertnitro_sugarcane) +#endif + CALL check_vector_data ('lag_npp ' , lag_npp ) + + END SUBROUTINE check_BGCTimeVariables +#endif + +#endif +END MODULE MOD_BGC_Vars_TimeVariables +! ------ EOP -------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireBase.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireBase.F90 new file mode 100644 index 0000000000..cc4be943a1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireBase.F90 @@ -0,0 +1,421 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNFireBase + +!--------------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE calculate fire-induced vegetation and litter CN transfers flux, the calculation is based on the fire-induced +! CN loss rates (f). The CN loss rates (f) is calculated from bgc_veg_CNFireLi2016Mod.F90. +! +! !REFERENCES: +! Li, F., Levis, S., and Ward, D. S. 2013a. Quantifying the role of fire in the Earth system - Part 1: Improved global fire +! modeling in the Community Earth System Model (CESM1). Biogeosciences 10:2293-2314. +! Li, F., and Lawrence, D. 2017. Role of fire in the global land water budget during the 20th century through changing +! ecosystems. J. Clim. 30: 1894-1908. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + + USE MOD_Precision + USE MOD_Const_PFT, only: & + cc_leaf , cc_lstem , cc_dstem , cc_other, fm_leaf, fm_lstem, fm_lroot, fm_root, fm_droot, fm_other, & + fr_fcel , fr_flig , fr_flab , lf_fcel , lf_flig, lf_flab + USE MOD_Vars_TimeInvariants, only: & + cmb_cmplt_fact, patchlatr, borealat, is_cwd, is_litter + + USE MOD_BGC_Vars_TimeVariables, only: & + ! decomposition pools & fluxes variables (inout) + decomp_cpools_vr, decomp_npools_vr, cropf, farea_burned, baf_crop, baf_peatf, totsomc + + USE MOD_BGC_Vars_1DFluxes, only: & + m_decomp_cpools_to_fire_vr, m_decomp_npools_to_fire_vr, & + fire_mortality_to_met_c, fire_mortality_to_cel_c, fire_mortality_to_lig_c, fire_mortality_to_cwdc, & + fire_mortality_to_met_n, fire_mortality_to_cel_n, fire_mortality_to_lig_n, fire_mortality_to_cwdn, & + somc_fire + + USE MOD_BGC_Vars_PFTimeVariables, only: & + leafc_p , leafc_storage_p , leafc_xfer_p , frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p, livecrootc_storage_p, livecrootc_xfer_p, deadcrootc_p, deadcrootc_storage_p, deadcrootc_xfer_p, & + leafn_p , leafn_storage_p , leafn_xfer_p , frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p, livecrootn_storage_p, livecrootn_xfer_p, deadcrootn_p, deadcrootn_storage_p, deadcrootn_xfer_p, & + livecrootn_p, livecrootn_storage_p, livecrootn_xfer_p, deadcrootn_p, deadcrootn_storage_p, deadcrootn_xfer_p, & + gresp_xfer_p, gresp_storage_p , retransn_p , & + leaf_prof_p , froot_prof_p , croot_prof_p , stem_prof_p + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + m_leafc_to_fire_p , m_leafc_storage_to_fire_p , m_leafc_xfer_to_fire_p , & + m_frootc_to_fire_p , m_frootc_storage_to_fire_p , m_frootc_xfer_to_fire_p , & + m_livestemc_to_fire_p , m_livestemc_storage_to_fire_p , m_livestemc_xfer_to_fire_p , & + m_deadstemc_to_fire_p , m_deadstemc_storage_to_fire_p , m_deadstemc_xfer_to_fire_p , & + m_livecrootc_to_fire_p , m_livecrootc_storage_to_fire_p , m_livecrootc_xfer_to_fire_p, & + m_deadcrootc_to_fire_p , m_deadcrootc_storage_to_fire_p , m_deadcrootc_xfer_to_fire_p, & + m_livestemc_to_deadstemc_fire_p, m_livecrootc_to_deadcrootc_fire_p, & + m_gresp_xfer_to_fire_p , m_gresp_storage_to_fire_p , m_retransn_to_fire_p , & + m_leafn_to_fire_p , m_leafn_storage_to_fire_p , m_leafn_xfer_to_fire_p , & + m_frootn_to_fire_p , m_frootn_storage_to_fire_p , m_frootn_xfer_to_fire_p , & + m_livestemn_to_fire_p , m_livestemn_storage_to_fire_p , m_livestemn_xfer_to_fire_p , & + m_deadstemn_to_fire_p , m_deadstemn_storage_to_fire_p , m_deadstemn_xfer_to_fire_p , & + m_livecrootn_to_fire_p , m_livecrootn_storage_to_fire_p , m_livecrootn_xfer_to_fire_p, & + m_deadcrootn_to_fire_p , m_deadcrootn_storage_to_fire_p , m_deadcrootn_xfer_to_fire_p, & + m_livestemn_to_deadstemn_fire_p, m_livecrootn_to_deadcrootn_fire_p, & + + m_leafc_to_litter_fire_p , m_leafc_storage_to_litter_fire_p , m_leafc_xfer_to_litter_fire_p , & + m_frootc_to_litter_fire_p , m_frootc_storage_to_litter_fire_p , m_frootc_xfer_to_litter_fire_p , & + m_livestemc_to_litter_fire_p , m_livestemc_storage_to_litter_fire_p , m_livestemc_xfer_to_litter_fire_p , & + m_deadstemc_to_litter_fire_p , m_deadstemc_storage_to_litter_fire_p , m_deadstemc_xfer_to_litter_fire_p , & + m_livecrootc_to_litter_fire_p, m_livecrootc_storage_to_litter_fire_p, m_livecrootc_xfer_to_litter_fire_p, & + m_deadcrootc_to_litter_fire_p, m_deadcrootc_storage_to_litter_fire_p, m_deadcrootc_xfer_to_litter_fire_p, & + m_gresp_xfer_to_litter_fire_p, m_gresp_storage_to_litter_fire_p , m_retransn_to_litter_fire_p , & + m_leafn_to_litter_fire_p , m_leafn_storage_to_litter_fire_p , m_leafn_xfer_to_litter_fire_p , & + m_frootn_to_litter_fire_p , m_frootn_storage_to_litter_fire_p , m_frootn_xfer_to_litter_fire_p , & + m_livestemn_to_litter_fire_p , m_livestemn_storage_to_litter_fire_p , m_livestemn_xfer_to_litter_fire_p , & + m_deadstemn_to_litter_fire_p , m_deadstemn_storage_to_litter_fire_p , m_deadstemn_xfer_to_litter_fire_p , & + m_livecrootn_to_litter_fire_p, m_livecrootn_storage_to_litter_fire_p, m_livecrootn_xfer_to_litter_fire_p, & + m_deadcrootn_to_litter_fire_p, m_deadcrootn_storage_to_litter_fire_p, m_deadcrootn_xfer_to_litter_fire_p + + USE MOD_Vars_PFTimeInvariants, only: pftfrac + + IMPLICIT NONE + + PUBLIC CNFireFluxes + +CONTAINS + + SUBROUTINE CNFireFluxes(i,ps,pe,dlat,nl_soil,ndecomp_pools) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: dlat ! latitude (degree) + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ndecomp_pools! number of total soil & litter pools in the decomposition + + ! !LOCAL VARIABLES: + integer :: j,l ! indices + real(r8):: f + real(r8):: mort + integer :: ivt, m + + integer, parameter :: lit_fp = 1 ! Pool for liter + integer, parameter :: cwd_fp = 2 ! Pool for CWD Course woody debris + + + DO m = ps, pe + IF(cropf(i) < 1.0_r8)THEN + ! For non-crop (bare-soil and natural vegetation) + f = (farea_burned(i)-baf_crop(i))/(1.0_r8-cropf(i)) + ELSE + ! For crops + IF(cropf(i) > 0._r8)THEN + f = baf_crop(i) /cropf(i) + ELSE + f = 0._r8 + ENDIF + ENDIF + + ! apply this rate to the patch state variables to get flux rates + ! biomass burning + ! carbon fluxes + mort = 1._r8 + m_leafc_to_fire_p(m) = leafc_p(m) * f * cc_leaf(ivt) + m_leafc_storage_to_fire_p(m) = leafc_storage_p(m) * f * cc_other(ivt) + m_leafc_xfer_to_fire_p(m) = leafc_xfer_p(m) * f * cc_other(ivt) + m_livestemc_to_fire_p(m) = livestemc_p(m) * f * cc_lstem(ivt) + m_livestemc_storage_to_fire_p(m) = livestemc_storage_p(m) * f * cc_other(ivt) + m_livestemc_xfer_to_fire_p(m) = livestemc_xfer_p(m) * f * cc_other(ivt) + m_deadstemc_to_fire_p(m) = deadstemc_p(m) * f * cc_dstem(ivt) + m_deadstemc_storage_to_fire_p(m) = deadstemc_storage_p(m) * f * cc_other(ivt) + m_deadstemc_xfer_to_fire_p(m) = deadstemc_xfer_p(m) * f * cc_other(ivt) + m_frootc_to_fire_p(m) = frootc_p(m) * f * 0._r8 + m_frootc_storage_to_fire_p(m) = frootc_storage_p(m) * f * cc_other(ivt) + m_frootc_xfer_to_fire_p(m) = frootc_xfer_p(m) * f * cc_other(ivt) + m_livecrootc_to_fire_p(m) = livecrootc_p(m) * f * 0._r8 + m_livecrootc_storage_to_fire_p(m) = livecrootc_storage_p(m) * f * cc_other(ivt) + m_livecrootc_xfer_to_fire_p(m) = livecrootc_xfer_p(m) * f * cc_other(ivt) + m_deadcrootc_to_fire_p(m) = deadcrootc_p(m) * f * 0._r8 + m_deadcrootc_storage_to_fire_p(m) = deadcrootc_storage_p(m) * f* cc_other(ivt) + m_deadcrootc_xfer_to_fire_p(m) = deadcrootc_xfer_p(m) * f * cc_other(ivt) + m_gresp_storage_to_fire_p(m) = gresp_storage_p(m) * f * cc_other(ivt) + m_gresp_xfer_to_fire_p(m) = gresp_xfer_p(m) * f * cc_other(ivt) + + + ! nitrogen fluxes + m_leafn_to_fire_p(m) = leafn_p(m) * f * cc_leaf(ivt) + m_leafn_storage_to_fire_p(m) = leafn_storage_p(m) * f * cc_other(ivt) + m_leafn_xfer_to_fire_p(m) = leafn_xfer_p(m) * f * cc_other(ivt) + m_livestemn_to_fire_p(m) = livestemn_p(m) * f * cc_lstem(ivt) + m_livestemn_storage_to_fire_p(m) = livestemn_storage_p(m) * f * cc_other(ivt) + m_livestemn_xfer_to_fire_p(m) = livestemn_xfer_p(m) * f * cc_other(ivt) + m_deadstemn_to_fire_p(m) = deadstemn_p(m) * f * cc_dstem(ivt) + m_deadstemn_storage_to_fire_p(m) = deadstemn_storage_p(m) * f * cc_other(ivt) + m_deadstemn_xfer_to_fire_p(m) = deadstemn_xfer_p(m) * f * cc_other(ivt) + m_frootn_to_fire_p(m) = frootn_p(m) * f * 0._r8 + m_frootn_storage_to_fire_p(m) = frootn_storage_p(m) * f * cc_other(ivt) + m_frootn_xfer_to_fire_p(m) = frootn_xfer_p(m) * f * cc_other(ivt) + m_livecrootn_to_fire_p(m) = livecrootn_p(m) * f * 0._r8 + m_livecrootn_storage_to_fire_p(m) = livecrootn_storage_p(m) * f * cc_other(ivt) + m_livecrootn_xfer_to_fire_p(m) = livecrootn_xfer_p(m) * f * cc_other(ivt) + m_deadcrootn_to_fire_p(m) = deadcrootn_p(m) * f * 0._r8 + m_deadcrootn_xfer_to_fire_p(m) = deadcrootn_xfer_p(m) * f * cc_other(ivt) + m_deadcrootn_storage_to_fire_p(m) = deadcrootn_storage_p(m) * f * cc_other(ivt) + m_retransn_to_fire_p(m) = retransn_p(m) * f * cc_other(ivt) + + ! mortality due to fire + ! carbon pools + m_leafc_to_litter_fire_p(m) = leafc_p(m) * f * & + (1._r8 - cc_leaf(ivt)) * & + fm_leaf(ivt) + m_leafc_storage_to_litter_fire_p(m) = leafc_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_leafc_xfer_to_litter_fire_p(m) = leafc_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemc_to_litter_fire_p(m) = livestemc_p(m) * f * & + (1._r8 - cc_lstem(ivt)) * & + fm_droot(ivt) + m_livestemc_storage_to_litter_fire_p(m) = livestemc_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemc_xfer_to_litter_fire_p(m) = livestemc_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemc_to_deadstemc_fire_p(m) = livestemc_p(m) * f * & + (1._r8 - cc_lstem(ivt)) * & + (fm_lstem(ivt)-fm_droot(ivt)) + m_deadstemc_to_litter_fire_p(m) = deadstemc_p(m) * f * m * & + (1._r8 - cc_dstem(ivt)) * & + fm_droot(ivt) + m_deadstemc_storage_to_litter_fire_p(m) = deadstemc_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_deadstemc_xfer_to_litter_fire_p(m) = deadstemc_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_frootc_to_litter_fire_p(m) = frootc_p(m) * f * & + fm_root(ivt) + m_frootc_storage_to_litter_fire_p(m) = frootc_storage_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_frootc_xfer_to_litter_fire_p(m) = frootc_xfer_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_livecrootc_to_litter_fire_p(m) = livecrootc_p(m) * f * & + fm_droot(ivt) + m_livecrootc_storage_to_litter_fire_p(m) = livecrootc_storage_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_livecrootc_xfer_to_litter_fire_p(m) = livecrootc_xfer_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_livecrootc_to_deadcrootc_fire_p(m) = livecrootc_p(m) * f * & + (fm_lroot(ivt)-fm_droot(ivt)) + m_deadcrootc_to_litter_fire_p(m) = deadcrootc_p(m) * f * m * & + fm_droot(ivt) + m_deadcrootc_storage_to_litter_fire_p(m) = deadcrootc_storage_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_deadcrootc_xfer_to_litter_fire_p(m) = deadcrootc_xfer_p(m) * f * & + (1._r8- cc_other(ivt)) * & + fm_other(ivt) + m_gresp_storage_to_litter_fire_p(m) = gresp_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_gresp_xfer_to_litter_fire_p(m) = gresp_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + + + ! nitrogen pools + m_leafn_to_litter_fire_p(m) = leafn_p(m) * f * & + (1._r8 - cc_leaf(ivt)) * & + fm_leaf(ivt) + m_leafn_storage_to_litter_fire_p(m) = leafn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_leafn_xfer_to_litter_fire_p(m) = leafn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemn_to_litter_fire_p(m) = livestemn_p(m) * f * & + (1._r8 - cc_lstem(ivt)) * & + fm_droot(ivt) + m_livestemn_storage_to_litter_fire_p(m) = livestemn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemn_xfer_to_litter_fire_p(m) = livestemn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livestemn_to_deadstemn_fire_p(m) = livestemn_p(m) * f * & + (1._r8 - cc_lstem(ivt)) * & + (fm_lstem(ivt)-fm_droot(ivt)) + m_deadstemn_to_litter_fire_p(m) = deadstemn_p(m) * f * m * & + (1._r8 - cc_dstem(ivt)) * & + fm_droot(ivt) + m_deadstemn_storage_to_litter_fire_p(m) = deadstemn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_deadstemn_xfer_to_litter_fire_p(m) = deadstemn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_frootn_to_litter_fire_p(m) = frootn_p(m) * f * & + fm_root(ivt) + m_frootn_storage_to_litter_fire_p(m) = frootn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_frootn_xfer_to_litter_fire_p(m) = frootn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livecrootn_to_litter_fire_p(m) = livecrootn_p(m) * f * & + fm_droot(ivt) + m_livecrootn_storage_to_litter_fire_p(m) = livecrootn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livecrootn_xfer_to_litter_fire_p(m) = livecrootn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_livecrootn_to_deadcrootn_fire_p(m) = livecrootn_p(m) * f * & + (fm_lroot(ivt)-fm_droot(ivt)) + m_deadcrootn_to_litter_fire_p(m) = deadcrootn_p(m) * f * & + fm_droot(ivt) + m_deadcrootn_storage_to_litter_fire_p(m) = deadcrootn_storage_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_deadcrootn_xfer_to_litter_fire_p(m) = deadcrootn_xfer_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + m_retransn_to_litter_fire_p(m) = retransn_p(m) * f * & + (1._r8 - cc_other(ivt)) * & + fm_other(ivt) + + ENDDO ! END of patches loop + + ! fire-induced transfer of carbon and nitrogen pools to litter and cwd + + DO j = 1,nl_soil + fire_mortality_to_cwdc (j,i) = 0._r8 + fire_mortality_to_cwdn (j,i) = 0._r8 + fire_mortality_to_met_c(j,i) = 0._r8 + DO m = ps, pe + fire_mortality_to_cwdc(j,i) = fire_mortality_to_cwdc(j,i) + & + m_deadstemc_to_litter_fire_p(m) * stem_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdc(j,i) = fire_mortality_to_cwdc(j,i) + & + m_deadcrootc_to_litter_fire_p(m) * croot_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdn(j,i) = fire_mortality_to_cwdn(j,i) + & + m_deadstemn_to_litter_fire_p(m) * stem_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdn(j,i) = fire_mortality_to_cwdn(j,i) + & + m_deadcrootn_to_litter_fire_p(m) * croot_prof_p(j,m) * pftfrac(m) + + + fire_mortality_to_cwdc(j,i) = fire_mortality_to_cwdc(j,i) + & + m_livestemc_to_litter_fire_p(m) * stem_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdc(j,i) = fire_mortality_to_cwdc(j,i) + & + m_livecrootc_to_litter_fire_p(m) * croot_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdn(j,i) = fire_mortality_to_cwdn(j,i) + & + m_livestemn_to_litter_fire_p(m) * stem_prof_p(j,m) * pftfrac(m) + fire_mortality_to_cwdn(j,i) = fire_mortality_to_cwdn(j,i) + & + m_livecrootn_to_litter_fire_p(m) * croot_prof_p(j,m) * pftfrac(m) + + + fire_mortality_to_met_c(j,i)=fire_mortality_to_met_c(j,i) & + +((m_leafc_to_litter_fire_p(m)*lf_flab(ivt) & + + m_leafc_storage_to_litter_fire_p(m) & + + m_leafc_xfer_to_litter_fire_p(m) & + + m_gresp_storage_to_litter_fire_p(m) & + + m_gresp_xfer_to_litter_fire_p(m)) * leaf_prof_p(j,m) & + + (m_frootc_to_litter_fire_p(m)*fr_flab(ivt) & + + m_frootc_storage_to_litter_fire_p(m) & + + m_frootc_xfer_to_litter_fire_p(m)) * froot_prof_p(j,m) & + + (m_livestemc_storage_to_litter_fire_p(m) & + + m_livestemc_xfer_to_litter_fire_p(m) & + + m_deadstemc_storage_to_litter_fire_p(m) & + + m_deadstemc_xfer_to_litter_fire_p(m)) * stem_prof_p(j,m) & + + (m_livecrootc_storage_to_litter_fire_p(m) & + + m_livecrootc_xfer_to_litter_fire_p(m) & + + m_deadcrootc_storage_to_litter_fire_p(m) & + + m_deadcrootc_xfer_to_litter_fire_p(m)) * croot_prof_p(j,m)) * pftfrac(m) + fire_mortality_to_cel_c(j,i)=fire_mortality_to_cel_c(j,i) & + + (m_leafc_to_litter_fire_p(m)*lf_fcel(ivt)*leaf_prof_p(j,m) & + + m_frootc_to_litter_fire_p(m)*fr_fcel(ivt)*froot_prof_p(j,m)) * pftfrac(m) + fire_mortality_to_lig_c(j,i)=fire_mortality_to_lig_c(j,i) & + + (m_leafc_to_litter_fire_p(m)*lf_flig(ivt)*leaf_prof_p(j,m) & + + m_frootc_to_litter_fire_p(m)*fr_flig(ivt)*froot_prof_p(j,m)) * pftfrac(m) + + fire_mortality_to_met_n(j,i)=fire_mortality_to_met_n(j,i) & + + ((m_leafn_to_litter_fire_p(m)*lf_flab(ivt) & + + m_leafn_storage_to_litter_fire_p(m) & + + m_leafn_xfer_to_litter_fire_p(m) & + + m_retransn_to_litter_fire_p(m)) *leaf_prof_p(j,m) & + + (m_frootn_to_litter_fire_p(m)*fr_flab(ivt) & + + m_frootn_storage_to_litter_fire_p(m) & + + m_frootn_xfer_to_litter_fire_p(m))*froot_prof_p(j,m) & + + (m_livestemn_storage_to_litter_fire_p(m) & + + m_livestemn_xfer_to_litter_fire_p(m) & + + m_deadstemn_storage_to_litter_fire_p(m) & + + m_deadstemn_xfer_to_litter_fire_p(m))* stem_prof_p(j,m)& + + (m_livecrootn_storage_to_litter_fire_p(m) & + + m_livecrootn_xfer_to_litter_fire_p(m) & + + m_deadcrootn_storage_to_litter_fire_p(m) & + + m_deadcrootn_xfer_to_litter_fire_p(m)) * croot_prof_p(j,m)) * pftfrac(m) + fire_mortality_to_cel_n(j,i)=fire_mortality_to_cel_n(j,i) & + + (m_leafn_to_litter_fire_p(m)*lf_fcel(i)*leaf_prof_p(j,m) & + + m_frootn_to_litter_fire_p(m)*fr_fcel(i)*froot_prof_p(j,m)) * pftfrac(m) + fire_mortality_to_lig_n(j,i)=fire_mortality_to_lig_n(j,i) & + + (m_leafn_to_litter_fire_p(m)*lf_flig(i)*leaf_prof_p(j,m) & + + m_frootn_to_litter_fire_p(m)*fr_flig(i)*froot_prof_p(j,m)) * pftfrac(m) + ENDDO + ENDDO + ! + ! vertically-resolved decomposing C/N fire loss + ! column loop + ! + DO j = 1, nl_soil + ! carbon fluxes + DO l = 1, ndecomp_pools + IF ( is_litter(l) ) THEN + m_decomp_cpools_to_fire_vr(j,l,i) = decomp_cpools_vr(j,l,i) * f * & + cmb_cmplt_fact(lit_fp) + ENDIF + IF ( is_cwd(l) ) THEN + m_decomp_cpools_to_fire_vr(j,l,i) = decomp_cpools_vr(j,l,i) * & + (f-baf_crop(i)) * cmb_cmplt_fact(cwd_fp) + ENDIF + ENDDO + + ! nitrogen fluxes + DO l = 1, ndecomp_pools + IF ( is_litter(l) ) THEN + m_decomp_npools_to_fire_vr(j,l,i) = decomp_npools_vr(j,l,i) * f * & + cmb_cmplt_fact(lit_fp) + ENDIF + IF ( is_cwd(l) ) THEN + m_decomp_npools_to_fire_vr(j,l,i) = decomp_npools_vr(j,l,i) * & + (f-baf_crop(i)) * cmb_cmplt_fact(cwd_fp) + ENDIF + ENDDO + + ENDDO + ! Carbon loss due to peat fires + ! + ! somc_fire is not connected to clm45 soil carbon pool, ie does not decrease + ! soil carbon b/c clm45 soil carbon was very low in several peatland grids + IF( patchlatr(i) < borealat)THEN + somc_fire(i)= totsomc(i)*baf_peatf(i)*6.0_r8/33.9_r8 + ELSE + somc_fire(i)= baf_peatf(i)*2.2e3_r8 + ENDIF + + ! Fang Li has not added aerosol and trace gas emissions due to fire, yet + ! They will be added here in proportion to the carbon emission + ! Emission factors differ for various fire types + + + END SUBROUTINE CNFireFluxes + +END MODULE MOD_BGC_Veg_CNFireBase +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 new file mode 100644 index 0000000000..c2b77e572e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNFireLi2016.F90 @@ -0,0 +1,320 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNFireLi2016 + +!------------------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculate burned area of each fire. The burned area is used to calculate fire induced CN loss rates +! in bgc_veg_CNFireBaseMod.F90 +! +! !REFERENCES: +! Li, F., Levis, S., and Ward, D. S. 2013a. Quantifying the role of fire in the Earth system - Part 1: Improved global fire +! modeling in the Community Earth System Model (CESM1). Biogeosciences 10:2293-2314. +! Li, F., and Lawrence, D. 2017. Role of fire in the global land water budget during the 20th century through changing +! ecosystems. J. Clim. 30: 1894-1908. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_TimeManager + USE MOD_Const_Physical, only: tfrz + USE MOD_Vars_1DForcing, only: & + forc_q, forc_t, forc_psrf, forc_us, forc_vs + USE MOD_Const_PFT, only: isshrub, isgrass, isbetr, isbdtr, isbare, iscrop, isnatveg, fd_pft, fsr_pft, rootfr_p + USE MOD_Vars_TimeInvariants, only: & + i_cwd, occur_hi_gdp_tree, gdp_lf, abm_lf, peatf_lf, & + lfuel, ufuel, cropfire_a1, borealat, troplat, non_boreal_peatfire_c, boreal_peatfire_c, rh_low, rh_hgh, & + bt_min, bt_max, pot_hmn_ign_counts_alpha, g0_fire, psi0, porsl, bsw +#ifdef vanGenuchten_Mualem_SOIL_MODEL + USE MOD_Vars_TimeInvariants, only: theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm +#endif + USE MOD_Vars_TimeVariables, only: & + decomp_cpools_vr , totlitc , totvegc , cropf , lfwt , fuelc , fuelc_crop , fsr , & + fd , rootc , lgdp , lgdp1 , lpop , wtlf , & + trotr1 , trotr2 , hdm_lf , lnfm , baf_crop , baf_peatf , & + farea_burned , nfire , fsat , prec60 , wf2 , & + tsoi17 , rh30 , t_soisno , wliq_soisno + USE MOD_BGC_Vars_PFTimeVariables, only: & + burndate_p + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + USE MOD_BGC_Vars_PFTimeVariables, only: leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + deadcrootc_p, deadcrootc_storage_p, deadcrootc_xfer_p, & + livecrootc_p, livecrootc_storage_p, livecrootc_xfer_p + USE MOD_Eroot, only: eroot + USE MOD_Qsadv + + IMPLICIT NONE + + PUBLIC CNFireArea + +CONTAINS + + SUBROUTINE CNFireArea(i,ps,pe,dlat,nl_soil,idate,dz_soi) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: dlat ! latitude (degree) + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: idate(3) ! current date (year, day of the year, seconds of the day) + real(r8),intent(in) :: dz_soi(1:nl_soil) ! thicknesses of each soil layer + + integer :: g,l,c,p,j,fc,fp,kyr, kmo, kda, mcsec ! index variables + integer :: ivt + real(r8) :: dayspyr ! days per year + real(r8) :: fb ! availability of fuel for regs A and C + real(r8) :: fhd ! impact of hd on agricultural fire + real(r8) :: fgdp ! impact of gdp on agricultural fire + real(r8) :: fire_m ! combustability of fuel for fire occurrence + real(r8) :: spread_m ! combustability of fuel for fire spread + real(r8) :: Lb_lf ! length-to-breadth ratio added by Lifang + real(r8) :: lh ! anthro. ignitions (count/km2/hr) + real(r8) :: fs ! hd-dependent fires suppression (0-1) + real(r8) :: ig ! total ignitions (count/km2/hr) + real(r8) :: arh, arh30 !combustability of fuel related to RH and RH30 + real(r8) :: afuel !weight for arh and arh30 + real(r8) :: eq + real(r8) :: deqdT + real(r8) :: qsatq + real(r8) :: qsatqdT + real(r8) :: forc_rh + real(r8) :: rootr(nl_soil) + real(r8) :: rresis(nl_soil) + real(r8) :: smp_node + real(r8) :: s_node + real(r8) :: tmp1d(nl_soil) + real(r8) :: tmp0d + real(r8) :: btran2 + real(r8) :: btran2_p(ps:pe) + + real(r8),parameter :: secsphr = 3600._r8 + real(r8),parameter :: secspday = 86400._r8 + real(r8),parameter :: PI = 4.*atan(1.) + integer m + + tsoi17 = forc_t(i) ! Temporarily use air temperature for tsoi17, need to revised later. + prec60 = 0 ! Temporarily use 0 for prec60, need to revised later + wf2 = 0.5 ! Temporarily set up, need to revise later. + fsat = 0 ! Temporarily set up, need to revise later. + rh30 = 0 ! Temporarily set up, need to revise later. + + CALL julian2monthday(idate(1),idate(2),kmo,kda) + + DO m = ps, pe + CALL eroot(nl_soil,0._r8,porsl(1:,i),& +#ifdef Campbell_SOIL_MODEL + bsw(1:,i),& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r(1:,i), alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), sc_vgm(1:,i), fc_vgm(1:,i), & +#endif + psi0(1:,i),rootfr_p(1:,pftclass(m)),dz_soi(1:),& + t_soisno(1:,i),wliq_soisno(1:,i),tmp1d,tmp0d,btran2_p(m)) + btran2 = sum(btran2_p(ps:pe) * pftfrac(m)) + ENDDO + ! + ! Calculate fraction of crop (cropf_col) and non-crop and non-bare-soil + ! vegetation (lfwt) in vegetated column + ! + cropf(i) = 0._r8 + lfwt (i) = 0._r8 + + ! For crop veg types + DO m = ps, pe + IF( iscrop(pftclass(m)) )THEN + cropf(i) = cropf(i) + pftfrac(m) + ENDIF + ! For natural vegetation (non-crop and non-bare-soil) + IF( isnatveg(pftclass(m)))THEN + lfwt (i) = lfwt(i) + pftfrac(m) + ENDIF + ENDDO + + ! + ! Calculate crop fuel + ! + fuelc_crop(i)=0._r8 + + ! For crop PFTs, fuel load includes leaf and litter; only + ! column-level litter carbon + ! is available, so we use leaf carbon to estimate the + ! litter carbon for crop PFTs + DO m = ps, pe + IF( iscrop(pftclass(m)) .and. sum(leafc_p(ps:pe)*pftfrac(ps:pe)) > 0._r8 )THEN + fuelc_crop(i)= fuelc_crop(i) + (leafc_p(m) + leafc_storage_p(m) + leafc_xfer_p(m))*pftfrac(m)/cropf(i) & + + totlitc(i)*leafc_p(m)/sum(leafc_p(ps:pe)*pftfrac(ps:pe))*pftfrac(m)/cropf(i) + ENDIF + ENDDO + ! + ! Calculate noncrop column variables + ! + fsr (i) = 0._r8 + fd (i) = 0._r8 + rootc (i) = 0._r8 + lgdp (i) = 0._r8 + lgdp1 (i) = 0._r8 + lpop (i) = 0._r8 + wtlf (i) = 0._r8 + trotr1(i) = 0._r8 + trotr2(i) = 0._r8 + + ! Warning : ivt is not initialized. + ! For non-crop -- natural vegetation and bare-soil + IF( isnatveg(ivt) .or. isbare(ivt) )THEN + IF (btran2 <= 1._r8 ) THEN + wtlf(i) = 1._r8 + ENDIF + + IF( isbetr(ivt) )THEN + trotr1(i)=1._r8 + ENDIF + IF( isbdtr(ivt) .and. abs(dlat) .lt. troplat)THEN + trotr2(i)=1._r8 + ENDIF + + rootc(i) = rootc(i) + sum((frootc_p(ps:pe) + frootc_storage_p(ps:pe) + & + frootc_xfer_p(ps:pe) + deadcrootc_p(ps:pe) + & + deadcrootc_storage_p(ps:pe) + deadcrootc_xfer_p(ps:pe) + & + livecrootc_p(ps:pe)+livecrootc_storage_p(ps:pe) + & + livecrootc_xfer_p(ps:pe)) * pftfrac(ps:pe)) + + fsr(i) = fsr_pft(ivt) + + ! all these constants are in Li et al. BG (2012a,b;2013) + + IF( hdm_lf(i) > 0.1_r8 )THEN + ! For not bare-soil + IF(.not. isbare(ivt) )THEN + ! For shrub and grass (crop already excluded above) + IF( isshrub(ivt) .or. isgrass(ivt) )THEN !for shurb and grass + lgdp(i) = lgdp(i) + (0.1_r8 + 0.9_r8* & + exp(-1._r8*PI* & + (gdp_lf(i)/8._r8)**0.5_r8))/(1.0_r8-cropf(i)) + lgdp1(i) = lgdp1(i) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*PI* & + (gdp_lf(i)/7._r8)))/(1._r8-cropf(i)) + lpop(i) = lpop(i) + (0.2_r8 + 0.8_r8* & + exp(-1._r8*PI* & + (hdm_lf(i)/450._r8)**0.5_r8))/(1._r8-cropf(i)) + ELSE ! for trees + IF( gdp_lf(i) > 20._r8 )THEN + lgdp(i) =lgdp(i)+occur_hi_gdp_tree/(1._r8-cropf(i)) + lgdp1(i) =lgdp1(i)+0.62_r8/(1._r8-cropf(i)) + ELSE + IF( gdp_lf(i) > 8._r8 )THEN + lgdp(i)=lgdp(i)+0.79_r8/(1._r8-cropf(i)) + lgdp1(i)=lgdp1(i)+0.83_r8/(1._r8-cropf(i)) + ELSE + lgdp(i) = lgdp(i)+1._r8/(1._r8-cropf(i)) + lgdp1(i)=lgdp1(i)+1._r8/(1._r8-cropf(i)) + ENDIF + ENDIF + lpop(i) = lpop(i) + (0.4_r8 + 0.6_r8* & + exp(-1._r8*PI* & + (hdm_lf(i)/125._r8)))/(1._r8-cropf(i)) + ENDIF + ENDIF + ELSE + lgdp(i) = lgdp(i) + 1._r8/(1._r8-cropf(i)) + lgdp1(i) = lgdp1(i) + 1._r8/(1._r8-cropf(i)) + lpop(i) = lpop(i) + 1._r8/(1._r8-cropf(i)) + ENDIF + + fd(i) = fd_pft(ivt) * secsphr / (1.0_r8-cropf(i)) + ENDIF + ! + ! calculate burned area fraction in cropland + ! + baf_crop(i)=0._r8 + + DO m = ps, pe + IF( kmo == 1 .and. kda == 1 .and. idate(3) == 0 )THEN + burndate_p(m) = 10000 ! init. value; actual range [0 365] + ENDIF + ENDDO + + ! For crop + DO m = ps, pe + IF( forc_t(i) >= tfrz .and. iscrop(ivt) .and. & + kmo == abm_lf(i) .and. burndate_p(m) >= 999)THEN ! catch crop burn time + + ! calculate human density impact on ag. fire + fhd = 0.04_r8+0.96_r8*exp(-1._r8*PI*(hdm_lf(i)/350._r8)**0.5_r8) + + ! calculate impact of GDP on ag. fire + fgdp = 0.01_r8+0.99_r8*exp(-1._r8*PI*(gdp_lf(i)/10._r8)) + + ! calculate burned area + fb = max(0.0_r8,min(1.0_r8,(fuelc_crop(i)-lfuel)/(ufuel-lfuel))) + + ! crop fire only for generic crop types at this time + ! managed crops are treated as grasses IF crop model is turned on + baf_crop(i) = baf_crop(i) + cropfire_a1/secsphr*fhd*fgdp + IF( fb*fhd*fgdp > 0._r8)THEN + burndate_p(m) = kda + ENDIF + ENDIF + ENDDO + + ! + ! calculate peatland fire + ! + IF(dlat < borealat )THEN + baf_peatf(i) = non_boreal_peatfire_c/secsphr*max(0._r8, & + min(1._r8,(4.0_r8-prec60(i)*secspday)/ & + 4.0_r8))**2*peatf_lf(i)*(1._r8-fsat(i)) + ELSE + baf_peatf(i) = boreal_peatfire_c/secsphr*exp(-PI*(max(wf2(i),0._r8)/0.3_r8))* & + max(0._r8,min(1._r8,(tsoi17(i)-tfrz)/10._r8))*peatf_lf(i)* & + (1._r8-fsat(i)) + ENDIF + ! + ! calculate other fires + ! + + CALL qsadv(forc_t(i),forc_psrf(i),eq,deqdT,qsatq,qsatqdT) + forc_rh = forc_q(i) / eq + + IF( cropf(i) < 1._r8 )THEN + fuelc(i) = totlitc(i)+totvegc(i)-rootc(i)-fuelc_crop(i)*cropf(i) + DO j = 1, nl_soil + fuelc(i) = fuelc(i)+decomp_cpools_vr(j,i_cwd,i) * dz_soi(j) + ENDDO + fuelc(i) = fuelc(i)/(1._r8-cropf(i)) + fb = max(0.0_r8,min(1.0_r8,(fuelc(i)-lfuel)/(ufuel-lfuel))) + IF (trotr1(i)+trotr2(i)<=0.6_r8) THEN + afuel =min(1._r8,max(0._r8,(fuelc(i)-2500._r8)/(5000._r8-2500._r8))) + arh=1._r8-max(0._r8, min(1._r8,(forc_rh-rh_low)/(rh_hgh-rh_low))) + arh30=1._r8-max(0.7_r8, min(1._r8,rh30(i)/90._r8)) + IF (forc_rh < rh_hgh.and. wtlf(i) > 0._r8 .and. tsoi17(i)> tfrz)THEN + fire_m = ((afuel*arh30+(1._r8-afuel)*arh)**1.5_r8)*((1._r8 -max(0._r8,& + min(1._r8,(btran2/wtlf(i)-bt_min)/(bt_max-bt_min))))**0.5_r8) + ELSE + fire_m = 0._r8 + ENDIF + lh = pot_hmn_ign_counts_alpha*6.8_r8*hdm_lf(i)**(0.43_r8)/30._r8/24._r8 + fs = 1._r8-(0.01_r8+0.98_r8*exp(-0.025_r8*hdm_lf(i))) + ig = (lh+lnfm(i)/(5.16_r8+2.16_r8*cos(PI/180._r8*3*min(60._r8,abs(dlat/PI*180))))*0.22_r8) & + *(1._r8-fs)*(1._r8-cropf(i)) + nfire(i) = ig/secsphr*fb*fire_m*lgdp(i) !fire counts/km2/sec + Lb_lf = 1._r8+10._r8*(1._r8-EXP(-0.06_r8*sqrt(forc_us(i)*forc_us(i)+forc_vs(i)*forc_vs(i)))) + spread_m = fire_m**0.5_r8 + farea_burned(i) = min(1._r8,(g0_fire*spread_m*fsr(i)* & + fd(i)/1000._r8)**2*lgdp1(i)* & + lpop(i)*nfire(i)*PI*Lb_lf+ & + baf_crop(i)+baf_peatf(i)) ! fraction (0-1) per sec + ELSE + farea_burned(i)=min(1._r8,baf_crop(i)+baf_peatf(i)) + ENDIF + ELSE + farea_burned(i) = min(1._r8,baf_crop(i)+baf_peatf(i)) + ENDIF + END SUBROUTINE CNFireArea + +END MODULE MOD_BGC_Veg_CNFireLi2016 +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGResp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGResp.F90 new file mode 100644 index 0000000000..9fcc35bb6d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGResp.F90 @@ -0,0 +1,139 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNGResp + +!----------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculate growth respiration rate. +! +! !REFERENCES: +! Atkin, O.K., Bahar, N.H., Bloomfield, K.J., Griffin, K.L., Heskel, M.A., Huntingford, C., de la Torre, A.M. +! and Turnbull, M.H., 2017. Leaf respiration in terrestrial biosphere models. Plant respiration: metabolic +! fluxes and carbon balance, pp.107-142. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Const_PFT, only: & + grperc, grpnow, woody + + USE MOD_Vars_PFTimeInvariants, only: pftclass + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + cpool_to_leafc_p , cpool_to_leafc_storage_p , leafc_xfer_to_leafc_p , & + cpool_to_frootc_p , cpool_to_frootc_storage_p , frootc_xfer_to_frootc_p , & + cpool_to_livestemc_p , cpool_to_livestemc_storage_p , livestemc_xfer_to_livestemc_p , & + cpool_to_deadstemc_p , cpool_to_deadstemc_storage_p , deadstemc_xfer_to_deadstemc_p , & + cpool_to_livecrootc_p, cpool_to_livecrootc_storage_p, livecrootc_xfer_to_livecrootc_p, & + cpool_to_deadcrootc_p, cpool_to_deadcrootc_storage_p, deadcrootc_xfer_to_deadcrootc_p, & + cpool_to_grainc_p , cpool_to_grainc_storage_p , grainc_xfer_to_grainc_p , & + cpool_leaf_gr_p , cpool_leaf_storage_gr_p , transfer_leaf_gr_p , & + cpool_froot_gr_p , cpool_froot_storage_gr_p , transfer_froot_gr_p , & + cpool_livestem_gr_p , cpool_livestem_storage_gr_p , transfer_livestem_gr_p , & + cpool_deadstem_gr_p , cpool_deadstem_storage_gr_p , transfer_deadstem_gr_p , & + cpool_livecroot_gr_p , cpool_livecroot_storage_gr_p , transfer_livecroot_gr_p , & + cpool_deadcroot_gr_p , cpool_deadcroot_storage_gr_p , transfer_deadcroot_gr_p , & + cpool_grain_gr_p , cpool_grain_storage_gr_p , transfer_grain_gr_p + + IMPLICIT NONE + + PUBLIC CNGResp + +CONTAINS + + SUBROUTINE CNGResp(i, ps, pe, npcropmin) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! end pft index + integer ,intent(in) :: npcropmin ! first crop pft index + + ! !LOCAL VARIABLES: + real(r8):: respfact_leaf + real(r8):: respfact_froot + real(r8):: respfact_livecroot + real(r8):: respfact_livestem + real(r8):: respfact_leaf_storage + real(r8):: respfact_froot_storage + real(r8):: respfact_livecroot_storage + real(r8):: respfact_livestem_storage + integer :: ivt, m + + + DO m = ps, pe + ivt = pftclass(m) + respfact_leaf = 1.0_r8 + respfact_froot = 1.0_r8 + respfact_livecroot = 1.0_r8 + respfact_livestem = 1.0_r8 + respfact_livecroot = 1.0_r8 + respfact_livestem = 1.0_r8 + respfact_leaf_storage = 1.0_r8 + respfact_froot_storage = 1.0_r8 + respfact_livecroot_storage = 1.0_r8 + respfact_livestem_storage = 1.0_r8 + respfact_livecroot_storage = 1.0_r8 + respfact_livestem_storage = 1.0_r8 + + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + cpool_livestem_gr_p (m) = cpool_to_livestemc_p (m) * grperc(ivt) * respfact_livestem + + cpool_livestem_storage_gr_p (m) = cpool_to_livestemc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_livestem_storage + + transfer_livestem_gr_p (m) = livestemc_xfer_to_livestemc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_livestem_storage + + cpool_grain_gr_p (m) = cpool_to_grainc_p (m) * grperc(ivt) + + cpool_grain_storage_gr_p (m) = cpool_to_grainc_storage_p (m) * grperc(ivt) * grpnow(ivt) + + transfer_grain_gr_p (m) = grainc_xfer_to_grainc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) + ENDIF + + ! leaf and fine root growth respiration + cpool_leaf_gr_p (m) = cpool_to_leafc_p (m) * grperc(ivt) * respfact_leaf + + cpool_leaf_storage_gr_p (m) = cpool_to_leafc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_leaf_storage + + transfer_leaf_gr_p (m) = leafc_xfer_to_leafc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_leaf_storage + + cpool_froot_gr_p (m) = cpool_to_frootc_p (m) * grperc(ivt) * respfact_froot + + cpool_froot_storage_gr_p (m) = cpool_to_frootc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_froot_storage + + transfer_froot_gr_p (m) = frootc_xfer_to_frootc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_froot_storage + + IF (woody(ivt) == 1._r8) THEN + cpool_livestem_gr_p (m) = cpool_to_livestemc_p (m) * grperc(ivt) * respfact_livestem + + cpool_livestem_storage_gr_p (m) = cpool_to_livestemc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_livestem_storage + + transfer_livestem_gr_p (m) = livestemc_xfer_to_livestemc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_livestem_storage + + cpool_deadstem_gr_p (m) = cpool_to_deadstemc_p (m) * grperc(ivt) + + cpool_deadstem_storage_gr_p (m) = cpool_to_deadstemc_storage_p (m) * grperc(ivt) * grpnow(ivt) + + transfer_deadstem_gr_p (m) = deadstemc_xfer_to_deadstemc_p (m) * grperc(ivt) * (1._r8 - grpnow(ivt)) + + cpool_livecroot_gr_p (m) = cpool_to_livecrootc_p (m) * grperc(ivt) * respfact_livecroot + + cpool_livecroot_storage_gr_p(m) = cpool_to_livecrootc_storage_p (m) * grperc(ivt) * grpnow(ivt) * respfact_livecroot_storage + + transfer_livecroot_gr_p (m) = livecrootc_xfer_to_livecrootc_p(m) * grperc(ivt) * (1._r8 - grpnow(ivt)) * respfact_livecroot_storage + + cpool_deadcroot_gr_p (m) = cpool_to_deadcrootc_p (m) * grperc(ivt) + + cpool_deadcroot_storage_gr_p(m) = cpool_to_deadcrootc_storage_p (m) * grperc(ivt) * grpnow(ivt) + + transfer_deadcroot_gr_p (m) = deadcrootc_xfer_to_deadcrootc_p(m) * grperc(ivt) * (1._r8 - grpnow(ivt)) + ENDIF + ENDDO + + END SUBROUTINE CNGResp + +END MODULE MOD_BGC_Veg_CNGResp +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGapMortality.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGapMortality.F90 new file mode 100644 index 0000000000..b4f22dfb92 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNGapMortality.F90 @@ -0,0 +1,274 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNGapMortality + +!--------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculates the CN fluxes from vegetation to litterfall due to gap mortality. +! The mortality rates are assumed constant for all vegetation function types. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_Const_PFT, only: lf_flab, lf_fcel, lf_flig, fr_flab, fr_fcel, fr_flig + USE MOD_BGC_Vars_TimeInvariants, only: & + ! bgc constants + am + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + + USE MOD_BGC_Vars_1DFluxes, only: & + ! decomposition carbon flux varables (in) + gap_mortality_to_met_c, gap_mortality_to_cel_c , & + gap_mortality_to_lig_c, gap_mortality_to_cwdc , & + + ! decompositionn nitrogen fluxes variables (inout) + gap_mortality_to_met_n, gap_mortality_to_cel_n , & + gap_mortality_to_lig_n, gap_mortality_to_cwdn + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + ! vegetation carbon flux variables + m_leafc_to_litter_p , m_leafc_storage_to_litter_p , m_leafc_xfer_to_litter_p , & + m_frootc_to_litter_p , m_frootc_storage_to_litter_p , m_frootc_xfer_to_litter_p , & + m_livestemc_to_litter_p , m_livestemc_storage_to_litter_p , m_livestemc_xfer_to_litter_p , & + m_deadstemc_to_litter_p , m_deadstemc_storage_to_litter_p , m_deadstemc_xfer_to_litter_p , & + m_livecrootc_to_litter_p , m_livecrootc_storage_to_litter_p, m_livecrootc_xfer_to_litter_p, & + m_deadcrootc_to_litter_p , m_deadcrootc_storage_to_litter_p, m_deadcrootc_xfer_to_litter_p, & + m_gresp_storage_to_litter_p, m_gresp_xfer_to_litter_p , & + + ! vegetation nitrogen flux variables + m_leafn_to_litter_p , m_leafn_storage_to_litter_p , m_leafn_xfer_to_litter_p , & + m_frootn_to_litter_p , m_frootn_storage_to_litter_p , m_frootn_xfer_to_litter_p , & + m_livestemn_to_litter_p , m_livestemn_storage_to_litter_p , m_livestemn_xfer_to_litter_p , & + m_deadstemn_to_litter_p , m_deadstemn_storage_to_litter_p , m_deadstemn_xfer_to_litter_p , & + m_livecrootn_to_litter_p , m_livecrootn_storage_to_litter_p, m_livecrootn_xfer_to_litter_p, & + m_deadcrootn_to_litter_p , m_deadcrootn_storage_to_litter_p, m_deadcrootn_xfer_to_litter_p, & + m_retransn_to_litter_p + + USE MOD_BGC_Vars_PFTimeVariables, only: & + ! vegetation carbon state variables (inout) + leafc_p , leafc_storage_p , leafc_xfer_p , & + frootc_p , frootc_storage_p , frootc_xfer_p , & + livestemc_p , livestemc_storage_p , livestemc_xfer_p , & + deadstemc_p , deadstemc_storage_p , deadstemc_xfer_p , & + livecrootc_p , livecrootc_storage_p, livecrootc_xfer_p, & + deadcrootc_p , deadcrootc_storage_p, deadcrootc_xfer_p, & + gresp_storage_p , gresp_xfer_p , & + + ! vegetation nitrogen state variables (inout) + leafn_p , leafn_storage_p , leafn_xfer_p , & + frootn_p , frootn_storage_p , frootn_xfer_p , & + livestemn_p , livestemn_storage_p , livestemn_xfer_p , & + deadstemn_p , deadstemn_storage_p , deadstemn_xfer_p , & + livecrootn_p , livecrootn_storage_p, livecrootn_xfer_p, & + deadcrootn_p , deadcrootn_storage_p, deadcrootn_xfer_p, & + retransn_p , & + + ! profiles + leaf_prof_p, stem_prof_p, froot_prof_p, croot_prof_p + + IMPLICIT NONE + + PUBLIC CNGapMortality + + PRIVATE CNGap_VegToLitter + +CONTAINS + + SUBROUTINE CNGapMortality(i, ps, pe, nl_soil, npcropmin) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! end pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: npcropmin! first crop pft index + + real(r8):: mort ! rate for fractional mortality (1/s) + integer :: ivt, m + + DO m = ps , pe + ivt = pftclass(m) + + mort = am/(365._r8 * 86400._r8) + + !------------------------------------------------------ + ! pft-level gap mortality carbon fluxes + !------------------------------------------------------ + + ! displayed pools + m_leafc_to_litter_p (m) = leafc_p (m) * mort + m_frootc_to_litter_p (m) = frootc_p (m) * mort + m_livestemc_to_litter_p (m) = livestemc_p (m) * mort + m_livecrootc_to_litter_p (m) = livecrootc_p (m) * mort + m_deadstemc_to_litter_p (m) = deadstemc_p (m) * mort + m_deadcrootc_to_litter_p (m) = deadcrootc_p (m) * mort + + ! storage pools + m_leafc_storage_to_litter_p (m) = leafc_storage_p (m) * mort + m_frootc_storage_to_litter_p (m) = frootc_storage_p (m) * mort + m_livestemc_storage_to_litter_p (m) = livestemc_storage_p (m) * mort + m_deadstemc_storage_to_litter_p (m) = deadstemc_storage_p (m) * mort + m_livecrootc_storage_to_litter_p(m) = livecrootc_storage_p(m) * mort + m_deadcrootc_storage_to_litter_p(m) = deadcrootc_storage_p(m) * mort + m_gresp_storage_to_litter_p (m) = gresp_storage_p (m) * mort + + ! transfer pools + m_leafc_xfer_to_litter_p (m) = leafc_xfer_p (m) * mort + m_frootc_xfer_to_litter_p (m) = frootc_xfer_p (m) * mort + m_livestemc_xfer_to_litter_p (m) = livestemc_xfer_p (m) * mort + m_deadstemc_xfer_to_litter_p (m) = deadstemc_xfer_p (m) * mort + m_livecrootc_xfer_to_litter_p (m) = livecrootc_xfer_p (m) * mort + m_deadcrootc_xfer_to_litter_p (m) = deadcrootc_xfer_p (m) * mort + m_gresp_xfer_to_litter_p (m) = gresp_xfer_p (m) * mort + + !------------------------------------------------------ + ! pft-level gap mortality nitrogen fluxes + !------------------------------------------------------ + + ! displayed pools + m_leafn_to_litter_p (m) = leafn_p (m) * mort + m_frootn_to_litter_p (m) = frootn_p (m) * mort + m_livestemn_to_litter_p (m) = livestemn_p (m) * mort + m_livecrootn_to_litter_p (m) = livecrootn_p (m) * mort + + m_deadstemn_to_litter_p (m) = deadstemn_p (m) * mort + m_deadcrootn_to_litter_p (m) = deadcrootn_p (m) * mort + + IF (ivt < npcropmin) THEN + m_retransn_to_litter_p (m) = retransn_p (m) * mort + ENDIF + + ! storage pools + m_leafn_storage_to_litter_p (m) = leafn_storage_p (m) * mort + m_frootn_storage_to_litter_p (m) = frootn_storage_p (m) * mort + m_livestemn_storage_to_litter_p (m) = livestemn_storage_p (m) * mort + m_deadstemn_storage_to_litter_p (m) = deadstemn_storage_p (m) * mort + m_livecrootn_storage_to_litter_p(m) = livecrootn_storage_p(m) * mort + m_deadcrootn_storage_to_litter_p(m) = deadcrootn_storage_p(m) * mort + + ! transfer pools + m_leafn_xfer_to_litter_p (m) = leafn_xfer_p (m) * mort + m_frootn_xfer_to_litter_p (m) = frootn_xfer_p (m) * mort + m_livestemn_xfer_to_litter_p (m) = livestemn_xfer_p (m) * mort + m_deadstemn_xfer_to_litter_p (m) = deadstemn_xfer_p (m) * mort + m_livecrootn_xfer_to_litter_p (m) = livecrootn_xfer_p (m) * mort + m_deadcrootn_xfer_to_litter_p (m) = deadcrootn_xfer_p (m) * mort + ENDDO + + CALL CNGap_VegToLitter(i, ps, pe, nl_soil) + + END SUBROUTINE CNGapMortality + + SUBROUTINE CNGap_VegToLitter(i, ps, pe, nl_soil) + + integer ,intent(in) :: i + integer ,intent(in) :: ps + integer ,intent(in) :: pe + integer ,intent(in) :: nl_soil + + integer j,m,ivt + real(r8) :: wtcol + + DO j = 1,nl_soil + DO m = ps, pe + ivt = pftclass(m) + wtcol = pftfrac(m) + + ! leaf gap mortality carbon fluxes + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + m_leafc_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_cel_c(j,i) = gap_mortality_to_cel_c(j,i) + & + m_leafc_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_lig_c(j,i) = gap_mortality_to_lig_c(j,i) + & + m_leafc_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! fine root gap mortality carbon fluxes + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + m_frootc_to_litter_p(m) * fr_flab(ivt) * wtcol * froot_prof_p(j,m) + gap_mortality_to_cel_c(j,i) = gap_mortality_to_cel_c(j,i) + & + m_frootc_to_litter_p(m) * fr_fcel(ivt) * wtcol * froot_prof_p(j,m) + gap_mortality_to_lig_c(j,i) = gap_mortality_to_lig_c(j,i) + & + m_frootc_to_litter_p(m) * fr_flig(ivt) * wtcol * froot_prof_p(j,m) + + ! wood gap mortality carbon fluxes + gap_mortality_to_cwdc(j,i) = gap_mortality_to_cwdc(j,i) + & + (m_livestemc_to_litter_p(m) + m_deadstemc_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_cwdc(j,i) = gap_mortality_to_cwdc(j,i) + & + (m_livecrootc_to_litter_p(m) + m_deadcrootc_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! storage gap mortality carbon fluxes + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_leafc_storage_to_litter_p(m) + m_gresp_storage_to_litter_p(m)) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + m_frootc_storage_to_litter_p(m) * wtcol * froot_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_livestemc_storage_to_litter_p(m) + m_deadstemc_storage_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_livecrootc_storage_to_litter_p(m) + m_deadcrootc_storage_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! transfer gap mortality carbon fluxes + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_leafc_xfer_to_litter_p(m) + m_gresp_xfer_to_litter_p(m)) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + m_frootc_xfer_to_litter_p(m) * wtcol * froot_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_livestemc_xfer_to_litter_p(m) + m_deadstemc_xfer_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_met_c(j,i) = gap_mortality_to_met_c(j,i) + & + (m_livecrootc_xfer_to_litter_p(m) + m_deadcrootc_xfer_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! leaf gap mortality nitrogen fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_leafn_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_cel_n(j,i) = gap_mortality_to_cel_n(j,i) + & + m_leafn_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_lig_n(j,i) = gap_mortality_to_lig_n(j,i) + & + m_leafn_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! fine root litter nitrogen fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_frootn_to_litter_p(m) * fr_flab(ivt) * wtcol * froot_prof_p(j,m) + gap_mortality_to_cel_n(j,i) = gap_mortality_to_cel_n(j,i) + & + m_frootn_to_litter_p(m) * fr_fcel(ivt) * wtcol * froot_prof_p(j,m) + gap_mortality_to_lig_n(j,i) = gap_mortality_to_lig_n(j,i) + & + m_frootn_to_litter_p(m) * fr_flig(ivt) * wtcol * froot_prof_p(j,m) + + ! wood gap mortality nitrogen fluxes + gap_mortality_to_cwdn(j,i) = gap_mortality_to_cwdn(j,i) + & + (m_livestemn_to_litter_p(m) + m_deadstemn_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_cwdn(j,i) = gap_mortality_to_cwdn(j,i) + & + (m_livecrootn_to_litter_p(m) + m_deadcrootn_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! retranslocated N pool gap mortality fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_retransn_to_litter_p(m) * wtcol * leaf_prof_p(j,m) + + ! storage gap mortality nitrogen fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_leafn_storage_to_litter_p(m) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_frootn_storage_to_litter_p(m) * wtcol * froot_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + (m_livestemn_storage_to_litter_p(m) + m_deadstemn_storage_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + (m_livecrootn_storage_to_litter_p(m) + m_deadcrootn_storage_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ! transfer gap mortality nitrogen fluxes + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_leafn_xfer_to_litter_p(m) * wtcol * leaf_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + m_frootn_xfer_to_litter_p(m) * wtcol * froot_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + (m_livestemn_xfer_to_litter_p(m) + m_deadstemn_xfer_to_litter_p(m)) * wtcol * stem_prof_p(j,m) + gap_mortality_to_met_n(j,i) = gap_mortality_to_met_n(j,i) + & + (m_livecrootn_xfer_to_litter_p(m) + m_deadcrootn_xfer_to_litter_p(m)) * wtcol * croot_prof_p(j,m) + + ENDDO + ENDDO + + END SUBROUTINE CNGap_VegToLitter + +END MODULE MOD_BGC_Veg_CNGapMortality +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNMResp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNMResp.F90 new file mode 100644 index 0000000000..a1a2dc434b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNMResp.F90 @@ -0,0 +1,119 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNMResp + +!----------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This module calculates plant maintenance respiration +! +! !REFERENCES: +! Atkin OK, Bloomfield KJ, Reich PB, Tjoelker MG, Asner GP, Bonal D et al (2015) Global variability in leaf respiration +! in relation to climate, plant functional types and leaf traits. New Phytologist 206:614-636 +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + USE MOD_BGC_Vars_TimeInvariants, only: & + Q10,br, br_root + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_Vars_TimeVariables, only: & + t_soisno, tref + USE MOD_Vars_PFTimeVariables, only: & + laisun_p, laisha_p, sigf_p + USE MOD_BGC_Vars_PFTimeVariables, only: & + frootn_p, livestemn_p, livecrootn_p, grainn_p + USE MOD_Vars_1DPFTFluxes, only: & + respc_p + USE MOD_BGC_Vars_1DPFTFluxes, only: & + leaf_mr_p, froot_mr_p, livestem_mr_p, livecroot_mr_p, grain_mr_p + USE MOD_Const_PFT, only: & + woody, rootfr_p + + IMPLICIT NONE + + PUBLIC CNMResp + +CONTAINS + + SUBROUTINE CNMResp(i, ps, pe, nl_soil, npcropmin) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: npcropmin ! first crop pft index + + ! !LOCAL VARIABLES: + integer :: j ! indices + integer :: ivt, m + + real(r8):: tc ! temperature correction, 2m air temp (unitless) + real(r8):: tcsoi(nl_soil) ! temperature correction by soil layer (unitless) + +! base rate for maintenance respiration is from: +! M. Ryan, 1991. Effects of climate change on plant respiration. +! Ecological Applications, 1(2), 157-167. +! Original expression is br = 0.0106 molC/(molN h) +! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) +! set constants + +! Peter Thornton: 3/13/09 +! Q10 was originally set to 2.0, an arbitrary choice, but reduced to 1.5 as part of the tuning +! to improve seasonal CYCLE of atmospheric CO2 concentration in global +! simulatoins + +! column loop to calculate temperature factors in each soil layer + DO j=1,nl_soil + + ! calculate temperature corrections for each soil layer, for USE in + ! estimating fine root maintenance respiration with depth + tcsoi(j) = Q10**((t_soisno(j,i) - 273.15_r8 - 20.0_r8)/10.0_r8) + ENDDO + + ! calculate maintenance respiration fluxes in + ! gC/m2/s for each of the live plant tissues. + ! Leaf and live wood MR + + tc = Q10**((tref(i) - 273.15_r8 - 20.0_r8)/10.0_r8) + + !RF: acclimation of root and stem respiration fluxes + ! n.b. we DO not yet know IF this is defensible scientifically (awaiting data analysis) + ! turning this on will increase R and decrease productivity in boreal forests, A LOT. :) + + DO m = ps, pe + ivt = pftclass(m) + IF (sigf_p(m) == 1) THEN + leaf_mr_p(m) = respc_p(m) * 12.011_r8 + ELSE !nosno + leaf_mr_p(m) = 0._r8 + ENDIF + + IF (woody(ivt) == 1) THEN + livestem_mr_p (m) = livestemn_p (m)*br*tc + livecroot_mr_p(m) = livecrootn_p(m)*br_root*tc + ELSE IF (ivt >= npcropmin) THEN + livestem_mr_p (m) = livestemn_p (m)*br*tc + grain_mr_p (m) = grainn_p (m)*br*tc + ENDIF + ! soil and patch loop for fine root + + DO j = 1,nl_soil + + ! Fine root MR + ! crootfr(j) sums to 1.0 over all soil layers, and + ! describes the fraction of root mass for carbon that is in each + ! layer. This is used with the layer temperature correction + ! to estimate the total fine root maintenance respiration as a + ! function of temperature and N content. + froot_mr_p(m) = froot_mr_p(m) + frootn_p(m)*br_root*tcsoi(j)*rootfr_p(j,ivt) + ENDDO + ENDDO + + END SUBROUTINE CNMResp + +END MODULE MOD_BGC_Veg_CNMResp +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 new file mode 100644 index 0000000000..cdea61366b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNNDynamics.F90 @@ -0,0 +1,193 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNNDynamics + +!--------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! This MODULE simulates the plant biological fixation (Cleveland et al., 1999), +! crop fertilisation (Lawrence et al., 2016, and soy nitrogen fixation (Neitsch et al., 2005). +! +! !REFERENCES: +! Cleveland, C.C., Townsend, A.R., Schimel, D.S., Fisher, H., Howarth, R.W., Hedin, L.O., Perakis, S.S., Latty, E.F., +! Von Fischer, J.C., Elseroad, A., and Wasson, M.F. 1999. Global patterns of terrestrial biological nitrogen (N2) fixation +! in natural ecosystems. Global Biogeochem. Cycles 13:623-645. +! Lawrence, D.M., Hurtt, G.C., Arneth, A., Brovkin, V., Calvin, K.V., Jones, A.D., Jones, C.D., Lawrence, P.J., de +! Noblet-Ducoudré, N., Pongratz, J., Seneviratne, S.I., and Shevliakova, E. 2016. The Land USE Model Intercomparison +! Project (LUMIP) contribution to CMIP6: rationale and experimental design. Geosci. Model Dev. 9:2973-2998. +! DOI:10.5194/gmd-9-2973-2016. +! Neitsch, S.L., Arnold, J.G., Kiniry, J.R., and Williams J.R. 2005. Soil and Water Assessment Tool, +! Theoretical Documentation: Version 2005. Temple, TX. USDA Agricultural Research Service and +! Texas A&M Blackland Research Center. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. + + USE MOD_Precision + + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + USE MOD_Vars_TimeInvariants, only: porsl, psi0, bsw + USE MOD_Vars_TimeVariables, only: h2osoi + + USE MOD_BGC_Vars_1DFluxes, only: fert_to_sminn, soyfixn_to_sminn, nfix_to_sminn + + USE MOD_BGC_Vars_TimeVariables, only: sminn, fpg, lag_npp +#ifdef CROP + USE MOD_BGC_Vars_PFTimeVariables, only: croplive_p, hui_p + USE MOD_BGC_Vars_PFTimeVariables, only: fert_p +#endif + + USE MOD_BGC_Vars_1DPFTFluxes, only: plant_ndemand_p, soyfixn_p + + USE MOD_Vars_Global, only: z_soi, dz_soi, spval + USE MOD_TimeManager + IMPLICIT NONE + + PUBLIC CNNFixation +#ifdef CROP + PUBLIC CNNFert + PUBLIC CNSoyfix +#endif + +CONTAINS + + SUBROUTINE CNNFixation(i,idate) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: idate(3) ! current date (year, day of the year, seconds of the day) + real(r8) t, dayspyr + + IF(isleapyear(idate(1)))THEN + dayspyr = 366 + ELSE + dayspyr = 365 + ENDIF + + IF (lag_npp(i) /= spval) THEN + ! need to put npp in units of gC/m^2/year here first + t = (1.8_r8 * (1._r8 - exp(-0.003_r8 * lag_npp(i)*(86400._r8 * dayspyr))))/(86400._r8 * dayspyr) + nfix_to_sminn(i) = max(0._r8,t) + ELSE + nfix_to_sminn(i) = 0._r8 + ENDIF + + END SUBROUTINE CNNFixation + +#ifdef CROP + SUBROUTINE CNNFert(i,ps,pe) + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + + fert_to_sminn(i) = sum(fert_p(ps:pe)) + + END SUBROUTINE CNNFert + + SUBROUTINE CNSoyfix (i, ps, pe, nl_soil) + ! GPAM Soybean biological N fixation + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! end pft index + integer, intent(in) :: nl_soil ! number of total soil layers + real(r8):: fxw,fxn,fxg,fxr ! soil water factor, nitrogen factor, growth stage factor + real(r8):: soy_ndemand ! difference between nitrogen supply and demand + real(r8):: sminnthreshold1, sminnthreshold2 + real(r8):: GDDfracthreshold1, GDDfracthreshold2 + real(r8):: GDDfracthreshold3, GDDfracthreshold4 + integer m, ivt, j + real(r8) :: rwat, swat, rz, watdry, wf, tsw, stsw + + sminnthreshold1 = 30._r8 + sminnthreshold2 = 10._r8 + GDDfracthreshold1 = 0.15_r8 + GDDfracthreshold2 = 0.30_r8 + GDDfracthreshold3 = 0.55_r8 + GDDfracthreshold4 = 0.75_r8 + + rwat = 0._r8 + swat = 0._r8 + rz = 0._r8 + + DO j = 1, nl_soil + IF (z_soi(j)+0.5_r8*dz_soi(j) <= 0.05_r8) THEN + watdry = porsl(j,i) * (316230._r8/(-psi0(j,i))) ** (-1._r8/bsw(j,i)) + rwat = rwat + (h2osoi(j,i)-watdry) * dz_soi(j) + swat = swat + (porsl (j,i)-watdry) * dz_soi(j) + rz = rz + dz_soi(j) + ENDIF + ENDDO + + tsw = rwat/rz + stsw = swat/rz + IF (rz .gt. 0._r8 .and. stsw .gt. 0._r8) THEN + wf = tsw/stsw + ELSE + wf = 0._r8 + ENDIF + + DO m = ps, pe + ivt = pftclass(m) + IF(croplive_p(m) .and. (ivt == 23 .or. ivt == 24 .or. ivt == 77 .or. ivt == 78))THEN + + ! difference between supply and demand + + IF(fpg(i) .lt. 1._r8) THEN + soy_ndemand = plant_ndemand_p(m) - plant_ndemand_p(m) * fpg(i) + + ! fixation depends on nitrogen, soil water, and growth stage + ! soil water factor + + fxw = wf / 0.85_r8 + + ! soil nitrogen factor (Beth says: CHECK UNITS) + + IF (sminn(i) .gt. sminnthreshold1) THEN + fxn = 0._r8 + ELSE IF (sminn(i) > sminnthreshold2 .and. sminn(i) <= sminnthreshold1) THEN + fxn = 1.5_r8 - .005_r8 * (sminn(i) * 10._r8) + ELSE IF (sminn(i) <= sminnthreshold2) THEN + fxn = 1._r8 + ENDIF + + ! growth stage factor + + IF (hui_p(m) <= GDDfracthreshold1) THEN + fxg = 0._r8 + ELSE IF (hui_p(m) > GDDfracthreshold1 .and. hui_p(m) <= GDDfracthreshold2) THEN + fxg = 6.67_r8 * hui_p(m) - 1._r8 + ELSE IF (hui_p(m) > GDDfracthreshold2 .and. hui_p(m) <= GDDfracthreshold3) THEN + fxg = 1._r8 + ELSE IF (hui_p(m) > GDDfracthreshold3 .and. hui_p(m) <= GDDfracthreshold4) THEN + fxg = 3.75_r8 - 5._r8 * hui_p(m) + ELSE + fxg = 0._r8 + ENDIF + + ! calculate the nitrogen fixed by the soybean + + fxr = max(0._r8, min(1._r8, fxw, fxn) * fxg) + soyfixn_p(m) = min(fxr * soy_ndemand, soy_ndemand) + + ELSE ! IF nitrogen demand met, no fixation + + soyfixn_p(m) = 0._r8 + + ENDIF + + ELSE ! IF not live soybean, no fixation + + soyfixn_p(m) = 0._r8 + + ENDIF + ENDDO + + soyfixn_to_sminn(i) = sum(soyfixn_p(ps:pe)*pftfrac(ps:pe)) + + END SUBROUTINE CNSoyfix +#endif + +END MODULE MOD_BGC_Veg_CNNDynamics +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 new file mode 100644 index 0000000000..6be0468d15 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNPhenology.F90 @@ -0,0 +1,1615 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNPhenology + +!-------------------- +! !DESCRIPTION: +! This MODULE holds all phenology related subroutines for natural vegetation and crop in the C and N cycle. +! CoLM Phenology controls the gain and loss of leaf carbon. LAI is then updated from leaf carbon. +! So, the seasonal variation in LAI can be simulated for different phenology types. +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. +! Fang Li, 2022, implemented GPAM crop model in this MODULE. +! +! !USES: + USE MOD_Const_PFT, only: & + isevg , issed , isstd , leaf_long, woody , leafcn , frootcn, livewdcn, deadwdcn, & + lflitcn, lf_flab, lf_fcel, lf_flig , fr_flab, fr_fcel, fr_flig, & + + ! crop variables + lfemerg, mxmat, grnfill, baset + + USE MOD_BGC_Vars_TimeInvariants, only: & + ndays_on , ndays_off , fstor2tran, crit_dayl , crit_onset_fdd, crit_onset_swi, & + crit_offset_fdd , crit_offset_swi, soilpsi_on, soilpsi_off, lwtop, rice2pdt + + USE MOD_Vars_Global, only: & + !crop variables + nswheat , nirrig_swheat , nsugarcane , nirrig_sugarcane , & + nwwheat , nirrig_wwheat , ntmp_corn , nirrig_tmp_corn , & + ntrp_corn , nirrig_trp_corn , nmiscanthus , nirrig_miscanthus , & + nswitchgrass , nirrig_switchgrass, ncotton , nirrig_cotton , & + nrice , nirrig_rice , ntmp_soybean, nirrig_tmp_soybean, & + ntrp_soybean , nirrig_trp_soybean, & + spval + USE MOD_Const_Physical, only: tfrz + + USE MOD_Vars_TimeVariables, only: & + t_soisno, smp + + USE MOD_BGC_Vars_TimeVariables, only: & + dayl, prev_dayl, prec10, prec60, prec365, prec_today, prec_daily, accumnstep + + USE MOD_Vars_PFTimeVariables, only: & + tref_p ,tlai_p + + USE MOD_BGC_Vars_PFTimeVariables, only: & + tempavg_tref_p , annavg_tref_p , gdd0_p , gdd8_p , & + gdd10_p , gdd020_p , gdd820_p , gdd1020_p , nyrs_crop_active_p, & + bglfr_p , bgtr_p , lgsf_p , offset_flag_p , offset_counter_p , & + onset_flag_p , onset_counter_p, onset_gddflag_p, onset_gdd_p , onset_fdd_p , & + onset_swi_p , offset_fdd_p , offset_swi_p , dormant_flag_p, & + + prev_leafc_to_litter_p , prev_frootc_to_litter_p , days_active_p , & + + leafc_p , frootc_p , livestemc_p , & + livestemn_p , livecrootc_p , grainc_p, grainn_p , & + + leafc_storage_p , frootc_storage_p , livestemc_storage_p , & + deadstemc_storage_p, livecrootc_storage_p, deadcrootc_storage_p, & + leafn_storage_p , frootn_storage_p , livestemn_storage_p , & + deadstemn_storage_p, livecrootn_storage_p, deadcrootn_storage_p, & + + leafc_xfer_p , frootc_xfer_p , livestemc_xfer_p , & + deadstemc_xfer_p , livecrootc_xfer_p , deadcrootc_xfer_p , & + leafn_xfer_p , frootn_xfer_p , livestemn_xfer_p , & + deadstemn_xfer_p , livecrootn_xfer_p , deadcrootn_xfer_p , & + gresp_storage_p , & + +! crop variables +#ifdef CROP + cropplant_p , idop_p , a5tmin_p , a10tmin_p , t10_p , & + cumvd_p , vf_p , cphase_p , fert_counter_p , & + croplive_p , gddplant_p , harvdate_p , gddmaturity_p , & + hui_p , peaklai_p , & + tref_min_p , tref_max_p , tref_min_inst_p , tref_max_inst_p , & + manunitro_p , fertnitro_p , plantdate_p , fert_p , &! input from files +#endif + + leaf_prof_p , froot_prof_p , & + cropseedc_deficit_p, cropseedn_deficit_p + + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + livestemc_to_deadstemc_p , livecrootc_to_deadcrootc_p , & + + leafc_storage_to_xfer_p , frootc_storage_to_xfer_p , & + livestemc_storage_to_xfer_p , deadstemc_storage_to_xfer_p , & + livecrootc_storage_to_xfer_p , deadcrootc_storage_to_xfer_p , & + gresp_storage_to_xfer_p , & + + leafc_xfer_to_leafc_p , frootc_xfer_to_frootc_p , & + livestemc_xfer_to_livestemc_p , deadstemc_xfer_to_deadstemc_p , & + livecrootc_xfer_to_livecrootc_p, deadcrootc_xfer_to_deadcrootc_p, & + + livestemn_to_deadstemn_p , livecrootn_to_deadcrootn_p , & + livestemn_to_retransn_p , livecrootn_to_retransn_p , & + + leafn_storage_to_xfer_p , frootn_storage_to_xfer_p , & + livestemn_storage_to_xfer_p , deadstemn_storage_to_xfer_p , & + livecrootn_storage_to_xfer_p , deadcrootn_storage_to_xfer_p , & + + leafn_xfer_to_leafn_p , frootn_xfer_to_frootn_p , & + livestemn_xfer_to_livestemn_p , deadstemn_xfer_to_deadstemn_p , & + livecrootn_xfer_to_livecrootn_p, deadcrootn_xfer_to_deadcrootn_p, & + cpool_to_leafc_p , cpool_to_frootc_p , & + leafc_to_litter_p , frootc_to_litter_p , & + leafn_to_litter_p , frootn_to_litter_p , & + leafn_to_retransn_p , & + + crop_seedc_to_leaf_p , crop_seedn_to_leaf_p , & + grainc_to_seed_p , grainn_to_seed_p , & + grainc_to_food_p , grainn_to_food_p , & + cpool_to_grainc_p , npool_to_grainn_p , & + livestemc_to_litter_p , livestemn_to_litter_p , & + cpool_to_livestemc_p + + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + + USE MOD_BGC_Vars_1DFluxes, only: & + phenology_to_met_c , phenology_to_cel_c , phenology_to_lig_c, & + phenology_to_met_n , phenology_to_cel_n , phenology_to_lig_n, & + grainc_to_cropprodc, grainn_to_cropprodn + + USE MOD_Vars_1DForcing, only: forc_prc, forc_prl + + USE MOD_TimeManager + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_FERT + USE MOD_BGC_Daylength, only: daylength + USE MOD_MPAS_MPI + + IMPLICIT NONE + + PUBLIC CNPhenology + + integer, parameter :: NOT_Planted = 999 ! If not planted yet in year + integer, parameter :: NOT_Harvested = 999 ! If not harvested yet in year + +CONTAINS + + SUBROUTINE CNPhenology(i,ps,pe,nl_soil,idate,dz_soi,deltim,dlat,npcropmin,phase) + +! !DESCRIPTION: +! The main driver of phenology model. Two phases are included: +! 1) phase==1: Calculates the phenology-related carbon and nitroge pool size changes, +! especially when specific phenology trigure is on (eg. leaf onset and offset). +! The pool size change rates is calculated from phase 2. +! 2) phase==2: Calculates phenology climatic diagnostics for onset and offset trigures +! Calculates the pool size change rates of all phenology processes. +! +! ! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + IMPLICIT NONE + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: idate(3) ! current date (year, day of the year, seconds of the day) + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dlat ! latitude (degrees) + integer ,intent(in) :: npcropmin ! first crop pft index + real(r8),intent(in) :: dz_soi(nl_soil)! thicknesses of each soil layer + integer ,intent(in) :: phase ! indicator of the SUBROUTINE options (see DESCRIPTION above) + + real(r8) dayspyr + integer h ! 1 for north hemsiphere; 2 for south hemisphere + + IF(isleapyear(idate(1)))THEN + dayspyr = 366 + ELSE + dayspyr = 365 + ENDIF + + IF ( phase == 1 ) THEN + CALL CNPhenologyClimate (i,ps,pe,idate(1:3),deltim,dayspyr,npcropmin,nl_soil,dz_soi,dlat) + + CALL CNEvergreenPhenology (i,ps,pe,deltim,dayspyr) + + CALL CNSeasonDecidPhenology(i,ps,pe,idate(1:3),deltim,dayspyr,dlat) + + CALL CNStressDecidPhenology(i,ps,pe,deltim,dayspyr) + +#ifdef CROP + IF(dlat >= 0)THEN + h = 1 + ELSE + h = 2 + ENDIF + CALL CropPhenology(i,ps,pe,idate(1:3),h,deltim,dayspyr,npcropmin) +#endif + ELSE IF ( phase == 2 ) THEN + ! the same onset and offset routines are called regardless of + ! phenology type - they depend only on onset_flag, offset_flag, bglfr, and bgtr + + CALL CNOnsetGrowth(i,ps,pe,deltim) + + CALL CNOffsetLitterfall(i,ps,pe,deltim,npcropmin) + + CALL CNBackgroundLitterfall(i,ps,pe) + + CALL CNLivewoodTurnover(i,ps,pe) + + CALL CNLitterToColumn(i,ps,pe,nl_soil,npcropmin) + ELSE + write(*,*) 'bad phenology phase' + ENDIF + + END SUBROUTINE CNPhenology + + SUBROUTINE CNPhenologyClimate (i,ps,pe,idate,deltim,dayspyr,npcropmin,nl_soil,dz_soi,dlat) + +! !DESCRIPTION: +! This SUBROUTINE summaries climate statistics, such as annual averaged temperature, +! maximum and minimum temperature, averaged precipitation over recent 10 days, 60 days and 365 days, +! growing degree days above 0, 8, and 10 degrees celsius. These climate statistics will be +! used in following phenology simulations. +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + ! + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: idate(3) ! current date (year, days of the year, seconds of the day) + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dayspyr ! days per year (days) + integer ,intent(in) :: npcropmin! first crop pft index + integer ,intent(in) :: nl_soil ! number of total soil layers + real(r8),intent(in) :: dz_soi(nl_soil) ! thicknesses of each soil layer + real(r8),intent(in) :: dlat ! latitude (degrees) + + ! !LOCAL VARIABLES: + real(r8), parameter :: yravg = 20.0_r8 ! length of years to average for gdd + real(r8), parameter :: yravgm1 = yravg-1.0_r8 ! minus 1 of above + integer :: m,ivt + logical , parameter :: isconst_baset = .true. ! .true. for constant base temperature + ! .false. for latidinal varied base temperature + real(r8) stepperday, nsteps + integer month, mday + !----------------------------------------------------------------------- + + ! set time steps + + stepperday = 86400._r8 / deltim + DO m = ps , pe + tempavg_tref_p(m) = tempavg_tref_p(m) + tref_p(m) * (deltim/86400._r8/dayspyr) +#ifdef CROP + IF(idate(3) .eq. deltim .or. tref_max_inst_p(m) .eq. spval)THEN + tref_max_inst_p(m) = tref_p(m) + ELSE + tref_max_inst_p(m) = max(tref_max_inst_p(m) , tref_p(m)) + ENDIF + + IF(idate(3) .eq. deltim .or. tref_min_inst_p(m) .eq. spval)THEN + tref_min_inst_p(m) = tref_p(m) + ELSE + tref_min_inst_p(m) = min(tref_min_inst_p(m) , tref_p(m)) + ENDIF + IF(idate(3) .eq. 86400 - nint(deltim))THEN + tref_max_p(m) = tref_max_inst_p(m) + tref_min_p(m) = tref_min_inst_p(m) + ENDIF +#endif + ENDDO + + accumnstep(i) = accumnstep(i) + 1 + prec_today(i) = forc_prc(i) + forc_prl(i) + + nsteps = amin1(10._r8 * stepperday, accumnstep(i)) + prec10 (i) = ( prec10 (i) * (nsteps - 1) + prec_today(i) ) / nsteps + + nsteps = amin1(60._r8 * stepperday, accumnstep(i)) + prec60 (i) = ( prec60 (i) * (nsteps - 1) + prec_today(i) ) / nsteps + + nsteps = amin1(365._r8 * stepperday, accumnstep(i)) + prec365 (i) = ( prec365(i) * (nsteps - 1) + prec_today(i) ) / nsteps + + CALL julian2monthday(idate(1),idate(2),month,mday) + !calculate gdd0,gdd8,gdd10,gddplant for GPAM crop phenology F. Li + DO m = ps , pe + ivt = pftclass(m) + IF(((month .ge. 4 .and. month .le. 9) .and. dlat .ge. 0) .or. & + ((month .gt. 9 .or. month .lt. 4) .and. dlat .lt. 0)) THEN + gdd0_p (m) = gdd0_p (m) + max(0._r8, tref_p(m) - 273.15) * deltim / 86400._r8 + gdd8_p (m) = gdd8_p (m) + max(0._r8, tref_p(m) - 273.15 - 8) * deltim / 86400._r8 + gdd10_p(m) = gdd10_p(m) + max(0._r8, tref_p(m) - 273.15 - 10) * deltim / 86400._r8 + ENDIF +#ifdef CROP + IF(croplive_p(m))THEN + IF((ivt == nwwheat .or. ivt == nirrig_wwheat).and.cphase_p(m) == 2._r8)THEN + gddplant_p(m) = gddplant_p(m) +vf_p(m) * max(0._r8, & + tref_p(m) - (273.15 + baset(ivt))) * deltim / 86400._r8 + ELSE + gddplant_p(m) = gddplant_p(m) + max(0._r8, & + tref_p(m) - (273.15 + baset(ivt))) * deltim / 86400._r8 + ENDIF + ELSE + gddplant_p(m) = 0._r8 + ENDIF +#endif + ENDDO + + !calculate gdd020,gdd820,gdd1020 for gddmaturity in GPAM crop phenology F. Li + DO m = ps , pe + ivt = pftclass(m) + IF (idate(2) == 1 .and. idate(3) == deltim)THEN + IF(nyrs_crop_active_p(m) == 0) THEN ! YR 1: + gdd020_p(m) = 0._r8 ! set gdd..20 variables to 0 + gdd820_p(m) = 0._r8 ! and crops will not be planted + gdd1020_p(m) = 0._r8 + ELSE + IF (nyrs_crop_active_p(m) == 1) THEN ! <-- END of YR 1 + gdd020_p(m) = gdd0_p(m) ! <-- END of YR 1 + gdd820_p(m) = gdd8_p(m) ! <-- END of YR 1 + gdd1020_p(m) = gdd10_p(m) ! <-- END of YR 1 + ELSE + gdd020_p(m) = (yravgm1* gdd020_p(m) + gdd0_p(m)) / yravg ! gdd..20 must be long term avgs + gdd820_p(m) = (yravgm1* gdd820_p(m) + gdd8_p(m)) / yravg ! so ignore results for yrs 1 & 2 + gdd1020_p(m) = (yravgm1* gdd1020_p(m) + gdd10_p(m)) / yravg + ENDIF + ENDIF ! <-- END of YR 1 + gdd0_p (m) = 0._r8 + gdd8_p (m) = 0._r8 + gdd10_p(m) = 0._r8 + ENDIF + IF (isendofyear(idate,deltim)) THEN ! <-- END of EVERY YR: + nyrs_crop_active_p(m) = nyrs_crop_active_p(m) + 1 + ENDIF + ENDDO + + END SUBROUTINE CNPhenologyClimate + + + SUBROUTINE CNEvergreenPhenology (i,ps,pe,deltim,dayspyr) +! +! !DESCRIPTION: +! Evergreen phenology assumes CN stock from vegetation storage pool go to transfer +! pool steadily with a constant rate 0.0002. All CN stock from transfer pool go to +! display pool immediately when it receives CN flow from storage pool. in recent version, +! Evergreen types only allocate NPP or N uptake to display pools. Storage and transfer +! pool stay 0 over whole simulation periods. Leaf litter fall simulation depends on a +! background turnover, which a constant parameter leaf_long was assigned (from MOD_Const_PFT.F90) +! to indicate the background turnover rates. +! +! Allocation NPP -> DISPLAY pool -> litter +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + +! +! !ARGUMENTS: + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dayspyr ! Days per year + ! + ! !LOCAL VARIABLES: + + real(r8):: tranr + real(r8):: t1 ! temporary variable + integer :: ivt, m + !----------------------------------------------------------------------- + + DO m = ps , pe + ivt = pftclass(m) + IF (isevg(ivt)) THEN + bglfr_p(m) = 1._r8/(leaf_long(ivt) * dayspyr * 86400._r8) + bgtr_p(m) = 0._r8 + lgsf_p(m) = 0._r8 + ENDIF + ENDDO + + DO m = ps , pe + ivt = pftclass(m) + IF (isevg(ivt)) THEN + + tranr=0.0002_r8 + ! set carbon fluxes for shifting storage pools to transfer pools + leafc_storage_to_xfer_p(m) = tranr * leafc_storage_p(m)/deltim + frootc_storage_to_xfer_p(m) = tranr * frootc_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemc_storage_to_xfer_p(m) = tranr * livestemc_storage_p(m)/deltim + deadstemc_storage_to_xfer_p(m) = tranr * deadstemc_storage_p(m)/deltim + livecrootc_storage_to_xfer_p(m) = tranr * livecrootc_storage_p(m)/deltim + deadcrootc_storage_to_xfer_p(m) = tranr * deadcrootc_storage_p(m)/deltim + gresp_storage_to_xfer_p(m) = tranr * gresp_storage_p(m)/deltim + ENDIF + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer_p(m) = tranr * leafn_storage_p(m)/deltim + frootn_storage_to_xfer_p(m) = tranr * frootn_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemn_storage_to_xfer_p(m) = tranr * livestemn_storage_p(m)/deltim + deadstemn_storage_to_xfer_p(m) = tranr * deadstemn_storage_p(m)/deltim + livecrootn_storage_to_xfer_p(m) = tranr * livecrootn_storage_p(m)/deltim + deadcrootn_storage_to_xfer_p(m) = tranr * deadcrootn_storage_p(m)/deltim + ENDIF + + t1 = 1.0_r8 / deltim + + leafc_xfer_to_leafc_p(m) = t1 * leafc_xfer_p(m) + frootc_xfer_to_frootc_p(m) = t1 * frootc_xfer_p(m) + + leafn_xfer_to_leafn_p(m) = t1 * leafn_xfer_p(m) + frootn_xfer_to_frootn_p(m) = t1 * frootn_xfer_p(m) + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = t1 * livestemc_xfer_p(m) + deadstemc_xfer_to_deadstemc_p(m) = t1 * deadstemc_xfer_p(m) + livecrootc_xfer_to_livecrootc_p(m) = t1 * livecrootc_xfer_p(m) + deadcrootc_xfer_to_deadcrootc_p(m) = t1 * deadcrootc_xfer_p(m) + + livestemn_xfer_to_livestemn_p(m) = t1 * livestemn_xfer_p(m) + deadstemn_xfer_to_deadstemn_p(m) = t1 * deadstemn_xfer_p(m) + livecrootn_xfer_to_livecrootn_p(m) = t1 * livecrootn_xfer_p(m) + deadcrootn_xfer_to_deadcrootn_p(m) = t1 * deadcrootn_xfer_p(m) + ENDIF + + ENDIF ! END of IF (isevg(ivt(p)) == 1._r8) THEN + + ENDDO ! END of pft loop + + END SUBROUTINE CNEvergreenPhenology + + SUBROUTINE CNSeasonDecidPhenology(i,ps,pe,idate,deltim,dayspyr,dlat) + +! +! !DESCRIPTION: +! This routine handles the seasonal deciduous phenology code (temperate deciduous +! vegetation that has only one growing season per year). Seasonal deciduous phenology +! assumes 0 background turnover rates. NPP or N uptake only allocated to storage pool. +! Display pool size changes occur only in onset and offset period. All CN stock from +! transfer pool go to display pool immediately when it receives CN flow from storage +! pool. +! +! Onset period: +! Allocation NPP -> STORAGE pool -> XFER pool -> DISPLAY pool +! Offset period: +! DISPLAY pool -> litter +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + +! !ARGUMENTS: + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: idate(3)! current date (year, day of the year, second of the day) + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dayspyr ! Days per year + real(r8),intent(in) :: dlat ! latitude (degree) + + ! + ! !LOCAL VARIABLES: + real(r8):: ws_flag !winter-summer solstice flag (0 or 1) + real(r8):: crit_onset_gdd !critical onset growing degree-day sum + real(r8):: soilt + integer :: idate2_last + integer :: ivt, m + !----------------------------------------------------------------------- + + + idate2_last = idate(2) - 1 + IF(idate2_last .le. 0)idate2_last=idate2_last+365 + prev_dayl(i)=daylength(dlat,idate2_last) + dayl(i) =daylength(dlat,idate(2)) + + DO m = ps , pe + ivt = pftclass(m) + IF (issed(ivt)) THEN + + ! set background litterfall rate, background transfer rate, and + ! long growing season factor to 0 for seasonal deciduous types + bglfr_p(m) = 0._r8 + bgtr_p(m) = 0._r8 + lgsf_p(m) = 0._r8 + + ! onset gdd sum from Biome-BGC, v4.1.2 + crit_onset_gdd = exp(4.8_r8 + 0.13_r8*(annavg_tref_p(m) - 273.15_r8)) + + ! set flag for solstice period (winter->summer = 1, summer->winter = 0) + IF (dayl(i) >= prev_dayl(i)) THEN + ws_flag = 1._r8 + ELSE + ws_flag = 0._r8 + ENDIF + + ! update offset_counter and test for the END of the offset period + IF (offset_flag_p(m) == 1.0_r8) THEN + ! decrement counter for offset period + offset_counter_p(m) = offset_counter_p(m) - deltim + + ! IF this is the END of the offset_period, reset phenology + ! flags and indices + IF (abs(offset_counter_p(m)) .lt. 0.1_r8) THEN + ! this code block was originally handled by CALL cn_offset_cleanup(i) + ! inlined during vectorization + + offset_flag_p(m) = 0._r8 + offset_counter_p(m) = 0._r8 + dormant_flag_p(m) = 1._r8 + days_active_p(m) = 0._r8 + + ! reset the previous timestep litterfall flux memory + prev_leafc_to_litter_p(m) = 0._r8 + prev_frootc_to_litter_p(m) = 0._r8 + ENDIF + ENDIF + + ! update onset_counter and test for the END of the onset period + IF (onset_flag_p(m) == 1.0_r8) THEN + ! decrement counter for onset period + onset_counter_p(m) = onset_counter_p(m) - deltim + + ! IF this is the END of the onset period, reset phenology + ! flags and indices + IF (abs(onset_counter_p(m)) .lt. 0.1_r8) THEN + ! this code block was originally handled by CALL cn_onset_cleanup(i) + ! inlined during vectorization + + onset_flag_p(m) = 0.0_r8 + onset_counter_p(m) = 0.0_r8 + ! set all transfer growth rates to 0.0 + leafc_xfer_to_leafc_p(m) = 0.0_r8 + frootc_xfer_to_frootc_p(m) = 0.0_r8 + leafn_xfer_to_leafn_p(m) = 0.0_r8 + frootn_xfer_to_frootn_p(m) = 0.0_r8 + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = 0.0_r8 + deadstemc_xfer_to_deadstemc_p(m) = 0.0_r8 + livecrootc_xfer_to_livecrootc_p(m) = 0.0_r8 + deadcrootc_xfer_to_deadcrootc_p(m) = 0.0_r8 + livestemn_xfer_to_livestemn_p(m) = 0.0_r8 + deadstemn_xfer_to_deadstemn_p(m) = 0.0_r8 + livecrootn_xfer_to_livecrootn_p(m) = 0.0_r8 + deadcrootn_xfer_to_deadcrootn_p(m) = 0.0_r8 + ENDIF + ! set transfer pools to 0.0 + leafc_xfer_p(m) = 0.0_r8 + leafn_xfer_p(m) = 0.0_r8 + frootc_xfer_p(m) = 0.0_r8 + frootn_xfer_p(m) = 0.0_r8 + IF (woody(ivt) == 1) THEN + livestemc_xfer_p(m) = 0.0_r8 + livestemn_xfer_p(m) = 0.0_r8 + deadstemc_xfer_p(m) = 0.0_r8 + deadstemn_xfer_p(m) = 0.0_r8 + livecrootc_xfer_p(m) = 0.0_r8 + livecrootn_xfer_p(m) = 0.0_r8 + deadcrootc_xfer_p(m) = 0.0_r8 + deadcrootn_xfer_p(m) = 0.0_r8 + ENDIF + ENDIF + ENDIF + + ! test for switching from dormant period to growth period + IF (dormant_flag_p(m) == 1.0_r8) THEN + + ! Test to turn on growing degree-day sum, IF off. + ! switch on the growing degree day sum on the winter solstice + + IF (onset_gddflag_p(m) == 0._r8 .and. ws_flag == 1._r8) THEN + onset_gddflag_p(m) = 1._r8 + onset_gdd_p(m) = 0._r8 + ENDIF + + ! Test to turn off growing degree-day sum, IF on. + ! This test resets the growing degree day sum IF it gets past + ! the summer solstice without reaching the threshold value. + ! in that CASE, it will take until the next winter solstice + ! before the growing degree-day summation starts again. + + IF (onset_gddflag_p(m) == 1._r8 .and. ws_flag == 0._r8) THEN + onset_gddflag_p(m) = 0._r8 + onset_gdd_p(m) = 0._r8 + ENDIF + + ! IF the gdd flag is set, and IF the soil is above freezing + ! THEN accumulate growing degree days for onset trigger + + soilt = t_soisno(3,i) + IF (onset_gddflag_p(m) == 1.0_r8 .and. soilt > 273.15_r8) THEN + onset_gdd_p(m) = onset_gdd_p(m) + (soilt-273.15_r8)*(deltim/86400._r8) + ENDIF + + ! set onset_flag IF critical growing degree-day sum is exceeded + IF (onset_gdd_p(m) > crit_onset_gdd) THEN + onset_flag_p(m) = 1.0_r8 + dormant_flag_p(m) = 0.0_r8 + onset_gddflag_p(m) = 0.0_r8 + onset_gdd_p(m) = 0.0_r8 + onset_counter_p(m) = ndays_on * 86400._r8 + + ! move all the storage pools into transfer pools, + ! WHERE they will be transfered to displayed growth over the onset period. + ! this code was originally handled with CALL cn_storage_to_xfer(p) + ! inlined during vectorization + + ! set carbon fluxes for shifting storage pools to transfer pools + leafc_storage_to_xfer_p(m) = fstor2tran * leafc_storage_p(m)/deltim + frootc_storage_to_xfer_p(m) = fstor2tran * frootc_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemc_storage_to_xfer_p(m) = fstor2tran * livestemc_storage_p(m)/deltim + deadstemc_storage_to_xfer_p(m) = fstor2tran * deadstemc_storage_p(m)/deltim + livecrootc_storage_to_xfer_p(m) = fstor2tran * livecrootc_storage_p(m)/deltim + deadcrootc_storage_to_xfer_p(m) = fstor2tran * deadcrootc_storage_p(m)/deltim + gresp_storage_to_xfer_p(m) = fstor2tran * gresp_storage_p(m)/deltim + ENDIF + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer_p(m) = fstor2tran * leafn_storage_p(m)/deltim + frootn_storage_to_xfer_p(m) = fstor2tran * frootn_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemn_storage_to_xfer_p(m) = fstor2tran * livestemn_storage_p(m)/deltim + deadstemn_storage_to_xfer_p(m) = fstor2tran * deadstemn_storage_p(m)/deltim + livecrootn_storage_to_xfer_p(m) = fstor2tran * livecrootn_storage_p(m)/deltim + deadcrootn_storage_to_xfer_p(m) = fstor2tran * deadcrootn_storage_p(m)/deltim + ENDIF + ENDIF + + ! test for switching from growth period to offset period + ELSE IF (offset_flag_p(m) == 0.0_r8) THEN + + ! only begin to test for offset daylength once past the summer sol + IF (ws_flag == 0._r8 .and. dayl(i) < crit_dayl) THEN + offset_flag_p(m) = 1._r8 + offset_counter_p(m) = ndays_off * 86400._r8 + prev_leafc_to_litter_p(m) = 0._r8 + prev_frootc_to_litter_p(m) = 0._r8 + ENDIF + ENDIF + + ENDIF ! ENDIF seasonal deciduous + ENDDO + + END SUBROUTINE CNSeasonDecidPhenology + + SUBROUTINE CNStressDecidPhenology(i,ps,pe,deltim,dayspyr) + +! +! !DESCRIPTION: +! This routine handles the stress deciduous phenology code (deciduous vegetation with +! one or more growing season per year). NPP or N uptake only allocated to storage pool. +! +! Onset period: +! Allocation NPP -> STORAGE pool -> XFER pool -> DISPLAY pool +! Offset period: +! DISPLAY pool -> litter +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer, intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + real(r8),intent(in) :: dayspyr ! days per year + + ! !LOCAL VARIABLES: + real(r8),parameter :: secspqtrday = 86400._r8 / 4 ! seconds per quarter day + real(r8):: crit_onset_gdd ! degree days for onset trigger + real(r8):: soilt ! temperature of top soil layer + real(r8):: psi ! soil water potential [MPa] + real(r8):: rain_threshold ! rain threshold for leaf on [mm] + logical :: additional_onset_condition ! additional condition for leaf onset + integer :: ivt, m + !----------------------------------------------------------------------- + + + ! specify rain threshold for leaf onset + rain_threshold = 20._r8 + + DO m = ps , pe + ivt = pftclass(m) + IF (isstd(ivt)) THEN + soilt = t_soisno(3,i) + psi = smp(3,i) * 1.e-5 ! mmH2O -> MPa + + ! onset gdd sum from Biome-BGC, v4.1.2 + crit_onset_gdd = exp(4.8_r8 + 0.13_r8*(annavg_tref_p(m) - 273.15_r8)) + + ! update offset_counter and test for the END of the offset period + IF (offset_flag_p(m) == 1._r8) THEN + ! decrement counter for offset period + offset_counter_p(m) = offset_counter_p(m) - deltim + + ! IF this is the END of the offset_period, reset phenology + ! flags and indices + IF (abs(offset_counter_p(m)) .lt. 0.1_r8) THEN + ! this code block was originally handled by CALL cn_offset_cleanup(i) + ! inlined during vectorization + offset_flag_p(m) = 0._r8 + offset_counter_p(m) = 0._r8 + dormant_flag_p(m) = 1._r8 + days_active_p(m) = 0._r8 + + ! reset the previous timestep litterfall flux memory + prev_leafc_to_litter_p(m) = 0._r8 + prev_frootc_to_litter_p(m) = 0._r8 + ENDIF + ENDIF + + ! update onset_counter and test for the END of the onset period + IF (onset_flag_p(m) == 1.0_r8) THEN + ! decrement counter for onset period + onset_counter_p(m) = onset_counter_p(m) - deltim + + ! IF this is the END of the onset period, reset phenology + ! flags and indices + IF (abs(onset_counter_p(m)) .lt. 0.1_r8) THEN + ! this code block was originally handled by CALL cn_onset_cleanup(i) + ! inlined during vectorization + onset_flag_p(m) = 0._r8 + onset_counter_p(m) = 0._r8 + ! set all transfer growth rates to 0.0 + leafc_xfer_to_leafc_p(m) = 0._r8 + frootc_xfer_to_frootc_p(m) = 0._r8 + leafn_xfer_to_leafn_p(m) = 0._r8 + frootn_xfer_to_frootn_p(m) = 0._r8 + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = 0._r8 + deadstemc_xfer_to_deadstemc_p(m) = 0._r8 + livecrootc_xfer_to_livecrootc_p(m) = 0._r8 + deadcrootc_xfer_to_deadcrootc_p(m) = 0._r8 + livestemn_xfer_to_livestemn_p(m) = 0._r8 + deadstemn_xfer_to_deadstemn_p(m) = 0._r8 + livecrootn_xfer_to_livecrootn_p(m) = 0._r8 + deadcrootn_xfer_to_deadcrootn_p(m) = 0._r8 + ENDIF + ! set transfer pools to 0.0 + leafc_xfer_p(m) = 0._r8 + leafn_xfer_p(m) = 0._r8 + frootc_xfer_p(m) = 0._r8 + frootn_xfer_p(m) = 0._r8 + IF (woody(ivt) == 1) THEN + livestemc_xfer_p(m) = 0._r8 + livestemn_xfer_p(m) = 0._r8 + deadstemc_xfer_p(m) = 0._r8 + deadstemn_xfer_p(m) = 0._r8 + livecrootc_xfer_p(m) = 0._r8 + livecrootn_xfer_p(m) = 0._r8 + deadcrootc_xfer_p(m) = 0._r8 + deadcrootn_xfer_p(m) = 0._r8 + ENDIF + ENDIF + ENDIF + + ! test for switching from dormant period to growth period + IF (dormant_flag_p(m) == 1._r8) THEN + + ! keep track of the number of freezing degree days in this + ! dormancy period (only IF the freeze flag has not previously been set + ! for this dormancy period + + IF (onset_gddflag_p(m) == 0._r8 .and. soilt < 273.15_r8) onset_fdd_p(m) = onset_fdd_p(m) + deltim/86400._r8 + + ! IF the number of freezing degree days exceeds a critical value, + ! THEN onset will require both wet soils and a critical soil + ! temperature sum. IF this CASE is triggered, reset any previously + ! accumulated value in onset_swi, so that onset now depends on + ! the accumulated soil water index following the freeze trigger + + IF (onset_fdd_p(m) > crit_onset_fdd) THEN + onset_gddflag_p(m) = 1._r8 + onset_fdd_p(m) = 0._r8 + onset_swi_p(m) = 0._r8 + ENDIF + + ! IF the freeze flag is set, and IF the soil is above freezing + ! THEN accumulate growing degree days for onset trigger + + IF (onset_gddflag_p(m) == 1._r8 .and. soilt > 273.15_r8) THEN + onset_gdd_p(m) = onset_gdd_p(m) + (soilt-273.15_r8)*deltim/86400._r8 + ENDIF + + ! IF soils are wet, accumulate soil water index for onset trigger + additional_onset_condition = .true. + ! IF additional constraint condition not met, set to false + IF ((prec10(i) * (3600.0_r8*10.0_r8*24.0_r8)) < rain_threshold) THEN + additional_onset_condition = .false. + ENDIF + + IF (psi >= soilpsi_on) THEN + onset_swi_p(m) = onset_swi_p(m) + deltim/86400._r8 + ENDIF + + ! IF critical soil water index is exceeded, set onset_flag, and + ! THEN test for soil temperature criteria + + ! Adding in Kyla's rainfall trigger when fun on. RF. prec10 (mm/s) needs to be higher than 8mm over 10 days. + + IF (onset_swi_p(m) > crit_onset_swi.and. additional_onset_condition) THEN + onset_flag_p(m) = 1._r8 + + ! only check soil temperature criteria IF freeze flag set since + ! beginning of last dormancy. IF freeze flag set and growing + ! degree day sum (since freeze trigger) is lower than critical + ! value, THEN override the onset_flag set from soil water. + + IF (onset_gddflag_p(m) == 1._r8 .and. onset_gdd_p(m) < crit_onset_gdd) onset_flag_p(m) = 0._r8 + ENDIF + + ! only allow onset IF dayl > 6hrs + IF (onset_flag_p(m) == 1._r8 .and. dayl(i) <= secspqtrday) THEN + onset_flag_p(m) = 0._r8 + ENDIF + + ! IF this is the beginning of the onset period + ! THEN reset the phenology flags and indices + + IF (onset_flag_p(m) == 1._r8) THEN + dormant_flag_p(m) = 0._r8 + days_active_p(m) = 0._r8 + onset_gddflag_p(m) = 0._r8 + onset_fdd_p(m) = 0._r8 + onset_gdd_p(m) = 0._r8 + onset_swi_p(m) = 0._r8 + onset_counter_p(m) = ndays_on * 86400._r8 + + ! CALL SUBROUTINE to move all the storage pools into transfer pools, + ! WHERE they will be transfered to displayed growth over the onset period. + ! this code was originally handled with CALL cn_storage_to_xfer(i) + ! inlined during vectorization + + ! set carbon fluxes for shifting storage pools to transfer pools + leafc_storage_to_xfer_p(m) = fstor2tran * leafc_storage_p(m)/deltim + frootc_storage_to_xfer_p(m) = fstor2tran * frootc_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemc_storage_to_xfer_p(m) = fstor2tran * livestemc_storage_p(m)/deltim + deadstemc_storage_to_xfer_p(m) = fstor2tran * deadstemc_storage_p(m)/deltim + livecrootc_storage_to_xfer_p(m) = fstor2tran * livecrootc_storage_p(m)/deltim + deadcrootc_storage_to_xfer_p(m) = fstor2tran * deadcrootc_storage_p(m)/deltim + gresp_storage_to_xfer_p(m) = fstor2tran * gresp_storage_p(m)/deltim + ENDIF + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer_p(m) = fstor2tran * leafn_storage_p(m)/deltim + frootn_storage_to_xfer_p(m) = fstor2tran * frootn_storage_p(m)/deltim + IF (woody(ivt) == 1) THEN + livestemn_storage_to_xfer_p(m) = fstor2tran * livestemn_storage_p(m)/deltim + deadstemn_storage_to_xfer_p(m) = fstor2tran * deadstemn_storage_p(m)/deltim + livecrootn_storage_to_xfer_p(m) = fstor2tran * livecrootn_storage_p(m)/deltim + deadcrootn_storage_to_xfer_p(m) = fstor2tran * deadcrootn_storage_p(m)/deltim + ENDIF + ENDIF + + ! test for switching from growth period to offset period + ELSE IF (offset_flag_p(m) == 0._r8) THEN + + ! IF soil water potential lower than critical value, accumulate + ! as stress in offset soil water index + + IF (psi <= soilpsi_off) THEN + offset_swi_p(m) = offset_swi_p(m) + deltim/86400._r8 + + ! IF the offset soil water index exceeds critical value, and + ! IF this is not the middle of a previously initiated onset period, + ! THEN set flag to start the offset period and reset index variables + + IF (offset_swi_p(m) >= crit_offset_swi .and. onset_flag_p(m) == 0._r8) offset_flag_p(m) = 1._r8 + + ! IF soil water potential higher than critical value, reduce the + ! offset water stress index. By this mechanism, there must be a + ! sustained period of water stress to initiate offset. + + ELSE IF (psi >= soilpsi_on) THEN + offset_swi_p(m) = offset_swi_p(m) - deltim/86400._r8 + offset_swi_p(m) = max(offset_swi_p(m),0._r8) + ENDIF + + ! decrease freezing day accumulator for warm soil + IF (offset_fdd_p(m) > 0._r8 .and. soilt > 273.15_r8) THEN + offset_fdd_p(m) = offset_fdd_p(m) - deltim/86400._r8 + offset_fdd_p(m) = max(0._r8, offset_fdd_p(m)) + ENDIF + + ! increase freezing day accumulator for cold soil + IF (soilt <= 273.15_r8) THEN + offset_fdd_p(m) = offset_fdd_p(m) + deltim/86400._r8 + + ! IF freezing degree day sum is greater than critical value, initiate offset + IF (offset_fdd_p(m) > crit_offset_fdd .and. onset_flag_p(m) == 0._r8) offset_flag_p(m) = 1._r8 + ENDIF + + ! force offset IF daylength is < 6 hrs + IF (dayl(i) <= secspqtrday) THEN + offset_flag_p(m) = 1._r8 + ENDIF + + ! IF this is the beginning of the offset period + ! THEN reset flags and indices + IF (offset_flag_p(m) == 1._r8) THEN + offset_fdd_p(m) = 0._r8 + offset_swi_p(m) = 0._r8 + offset_counter_p(m) = ndays_off * 86400._r8 + prev_leafc_to_litter_p(m) = 0._r8 + prev_frootc_to_litter_p(m) = 0._r8 + ENDIF + ENDIF + + ! keep track of number of days since last dormancy for control on + ! fraction of new growth to send to storage for next growing season + + IF (dormant_flag_p(m) == 0.0_r8) THEN + days_active_p(m) = days_active_p(m) + deltim/86400._r8 + ENDIF + + ! calculate long growing season factor (lgsf) + ! only begin to calculate a lgsf greater than 0.0 once the number + ! of days active exceeds days/year. + lgsf_p(m) = max(min(3.0_r8*(days_active_p(m)-leaf_long(ivt)*dayspyr )/dayspyr, 1._r8),0._r8) + ! RosieF. 5 Nov 2015. Changed this such that the increase in leaf turnover is faster after + ! trees enter the 'fake evergreen' state. Otherwise, they have a whole year of + ! cheating, with less litterfall than they should have, resulting in very high LAI. + ! Further, the 'fake evergreen' state (WHERE lgsf>0) is entered at the END of a single leaf lifespan + ! and not a whole year. The '3' is arbitrary, given that this entire system is quite abstract. + ! set background litterfall rate, when not in the phenological offset period + IF (offset_flag_p(m) == 1._r8) THEN + bglfr_p(m) = 0._r8 + ELSE + ! calculate the background litterfall rate (bglfr) + ! in units 1/s, based on leaf longevity (yrs) and correction for long growing season + + bglfr_p(m) = (1._r8/(leaf_long(ivt)*dayspyr*86400._r8))*lgsf_p(m) + ENDIF + + ! set background transfer rate when active but not in the phenological onset period + IF (onset_flag_p(m) == 1._r8) THEN + bgtr_p(m) = 0._r8 + ELSE + ! the background transfer rate is calculated as the rate that would result + ! in complete turnover of the storage pools in one year at steady state, + ! once lgsf has reached 1.0 (after 730 days active). + + bgtr_p(m) = (1._r8/(dayspyr*86400._r8))*lgsf_p(m) + + ! set carbon fluxes for shifting storage pools to transfer pools + + ! reduced the amount of stored carbon flowing to display pool by only counting the delta + ! between leafc and leafc_store in the flux. RosieF, Nov5 2015. + leafc_storage_to_xfer_p(m) = max(0.0_r8,(leafc_storage_p(m)-leafc_p(m))) * bgtr_p(m) + frootc_storage_to_xfer_p(m) = max(0.0_r8,(frootc_storage_p(m)-frootc_p(m))) * bgtr_p(m) + IF (woody(ivt) == 1) THEN + livestemc_storage_to_xfer_p(m) = livestemc_storage_p(m) * bgtr_p(m) + deadstemc_storage_to_xfer_p(m) = deadstemc_storage_p(m) * bgtr_p(m) + livecrootc_storage_to_xfer_p(m) = livecrootc_storage_p(m) * bgtr_p(m) + deadcrootc_storage_to_xfer_p(m) = deadcrootc_storage_p(m) * bgtr_p(m) + gresp_storage_to_xfer_p(m) = gresp_storage_p(m) * bgtr_p(m) + ENDIF + + ! set nitrogen fluxes for shifting storage pools to transfer pools + leafn_storage_to_xfer_p(m) = leafn_storage_p(m) * bgtr_p(m) + frootn_storage_to_xfer_p(m) = frootn_storage_p(m) * bgtr_p(m) + IF (woody(ivt) == 1) THEN + livestemn_storage_to_xfer_p(m) = livestemn_storage_p(m) * bgtr_p(m) + deadstemn_storage_to_xfer_p(m) = deadstemn_storage_p(m) * bgtr_p(m) + livecrootn_storage_to_xfer_p(m) = livecrootn_storage_p(m) * bgtr_p(m) + deadcrootn_storage_to_xfer_p(m) = deadcrootn_storage_p(m) * bgtr_p(m) + ENDIF + ENDIF + + ENDIF ! ENDIF stress deciduous + ENDDO !END pft loop + + END SUBROUTINE CNStressDecidPhenology + +#ifdef CROP + SUBROUTINE CropPhenology(i,ps,pe,idate,h,deltim,dayspyr,npcropmin) + +! !DESCRIPTION: +! GPAM crop phenology and code from CN to +! handle CN fluxes during the phenological onset & offset periods. +! +! ORIGINAL: The Community Land Model version 5.0 (CLM5.0) +! +! REVISION: F. Li, 2022, implemented GPAM in CoLM. + + integer, intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: idate(1:3)! current date (year, day of the year, second of the day) + integer ,intent(in) :: h ! hemisphere indicator: 1 for north hemisphere; 2 for south hemisphere + real(r8),intent(in) :: deltim ! timestep in seconds + real(r8),intent(in) :: dayspyr ! days per year + integer ,intent(in) :: npcropmin ! first crop pft index + + ! LOCAL VARAIBLES: + integer kyr ! current year + integer kmo ! month of year (1, ..., 12) + integer kda ! day of month (1, ..., 31) + integer mcsec + integer jday + integer fp,m ! patch indices + integer c ! column indices + integer g ! gridcell indices + integer idpp ! number of days past planting + real(r8) ndays_on ! number of days to fertilize + integer :: jdayyrstart(2) + real(r8) :: initial_seed_at_planting = 3._r8 ! Initial seed at planting + integer ivt + + !------------------------------------------------------------------------ + + jdayyrstart(1) = 1 + jdayyrstart(2) = 182 + + jday = idate(2) + mcsec = idate(3) + ! get time info + + ndays_on = 20._r8 ! number of days to fertilize + + ! background litterfall and transfer rates; long growing season factor + DO m = ps, pe + ivt = pftclass(m) + IF(ivt >= npcropmin)THEN + bglfr_p(m) = 0._r8 ! this value changes later in a crop's life CYCLE + bgtr_p(m) = 0._r8 + lgsf_p(m) = 0._r8 + + + ! plantdate is read in + ! determine IF the cft is planted in this time step + IF ( (.not. croplive_p(m)) .and. (.not. cropplant_p(m)) ) THEN + IF (jday == int(plantdate_p(m))) THEN + cumvd_p(m) = 0._r8 + vf_p(m) = 0._r8 + croplive_p(m) = .true. + cropplant_p(m) = .true. + idop_p(m) = jday + harvdate_p(m) = NOT_Harvested + leafc_xfer_p(m) = initial_seed_at_planting + leafn_xfer_p(m) = leafc_xfer_p(m) / leafcn(ivt) ! with onset + crop_seedc_to_leaf_p(m) = leafc_xfer_p(m)/deltim + crop_seedn_to_leaf_p(m) = leafn_xfer_p(m)/deltim + ENDIF + ENDIF + ! calculate gddmaturity + IF(croplive_p(m))THEN + IF (ivt == nwwheat .or. ivt == nirrig_wwheat)THEN + gddmaturity_p(m) = 0.42_r8 * gdd1020_p(m) + 440._r8 + ENDIF + IF ( ivt == ntmp_soybean .or. ivt == nirrig_tmp_soybean .or. & + ivt == ntrp_soybean .or. ivt == nirrig_trp_soybean) THEN + gddmaturity_p(m) = 0.30_r8 * gdd1020_p(m) + 710._r8 + ENDIF + IF (ivt == ntmp_corn .or. ivt == nirrig_tmp_corn .or. & + ivt == ntrp_corn .or. ivt == nirrig_trp_corn .or. & + ivt == nsugarcane .or. ivt == nirrig_sugarcane .or. & + ivt == nmiscanthus .or. ivt == nirrig_miscanthus .or. & + ivt == nswitchgrass .or. ivt == nirrig_switchgrass) THEN + gddmaturity_p(m) = 0.30_r8 * gdd820_p(m) + 816._r8 + ENDIF + IF (ivt == nswheat .or. ivt == nirrig_swheat .or. & + ivt == ncotton .or. ivt == nirrig_cotton)THEN + gddmaturity_p(m) = 0.24_r8 * gdd020_p(m) + 1349._r8 + ENDIF + IF (ivt == nrice .or. ivt == nirrig_rice) THEN + gddmaturity_p(m) = 0.35_r8 * gdd020_p(m) + 587._r8 + ENDIF + hui_p(m)=gddplant_p(m)/gddmaturity_p(m) + ENDIF + + ! all of the phenology changes are based on hui + + ! Phase 1: Planting to leaf emergence + ! Phase 2: Leaf emergence to beginning of grain fill (LAI increase) + ! Phase 3: Grain fill to physiological maturity and harvest (LAI decline) + ! Harvest: IF gdd past grain fill initiation exceeds limit + ! or number of days past planting reaches a maximum, the crop has + ! reached physiological maturity and plant is harvested; + ! --- --- --- + + onset_flag_p(m) = 0._r8 ! CN terminology to trigger certain + offset_flag_p(m) = 0._r8 ! carbon and nitrogen transfers + + IF (croplive_p(m)) THEN + cphase_p(m) = 1._r8 + ! days past planting may determine harvest + + IF (jday >= idop_p(m)) THEN + idpp = jday - idop_p(m) + ELSE + idpp = int(dayspyr) + jday - idop_p(m) + ENDIF + + ! onset_counter initialized to zero when .not. croplive + ! offset_counter relevant only at time step of harvest + + onset_counter_p(m) = onset_counter_p(m) - deltim + + ! enter phase 2 onset for one time step: + ! transfer seed carbon to leaf emergence + + ! IF (peaklai_p(m) >= 1) THEN + ! hui_p(m) = max(hui_p(m),grnfill(ivt)) + ! ENDIF + + IF (hui_p(m) >= lfemerg(ivt) .and. hui_p(m) < grnfill(ivt) .and. idpp < mxmat(ivt)) THEN + cphase_p(m) = 2._r8 + ! CALL vernalization IF winter temperate cereal planted, living, and the + ! vernalization factor is not 1; + ! vf affects the calculation of gddplant + IF ( vf_p(m) /= 1._r8 .and. (ivt == nwwheat .or. ivt == nirrig_wwheat) .and. hui_p(m) < 0.8_r8 * grnfill(ivt)) THEN + CALL vernalization(i,m,deltim) + ENDIF + + !fertilization + + IF (abs(onset_counter_p(m)) > 1.e-6_r8) THEN + onset_flag_p(m) = 1._r8 + onset_counter_p(m) = deltim + fert_counter_p(m) = ndays_on * 86400. + IF (ndays_on .gt. 0) THEN + IF(DEF_USE_FERT)THEN + fert_p(m) = (manunitro_p(m) + fertnitro_p(m))/ fert_counter_p(m) + ELSE + fert_p(m) = 0._r8 + ENDIF + ELSE + fert_p(m) = 0._r8 + ENDIF + ELSE + ! this ensures no re-entry to onset of phase2 + ! b/c onset_counter(p) = onset_counter(p) - deltim + ! at every time step + + onset_counter_p(m) = deltim + ENDIF + + ! enter harvest for one time step: + ! - transfer live biomass to litter and to crop yield + ! - send xsmrpool to the atmosphere + ! IF onset and harvest needed to last longer than one timestep + ! the onset_counter would change from dt and you'd need to make + ! changes to the offset SUBROUTINE below + + ELSE IF (hui_p(m) >= 1._r8 .or. idpp >= mxmat(ivt)) THEN + IF (harvdate_p(m) >= NOT_Harvested) harvdate_p(m) = jday + croplive_p(m) = .false. ! no re-entry in greater IF-block + cropplant_p(m)=.false. + cphase_p(m) = 4._r8 + hui_p(m)=0._r8 + IF (tlai_p(m) > 0._r8) THEN ! plant had emerged before harvest + offset_flag_p(m) = 1._r8 + offset_counter_p(m) = deltim + ELSE ! plant never emerged from the ground + ! Revert planting transfers; this will replenish the crop seed deficit. + ! We subtract from any existing value in crop_seedc_to_leaf / + ! crop_seedn_to_leaf in the unlikely event that we enter this block of + ! code in the same time step WHERE the planting transfer originally + ! occurred. + crop_seedc_to_leaf_p(m) = crop_seedc_to_leaf_p(m) - leafc_xfer_p(m)/deltim + crop_seedn_to_leaf_p(m) = crop_seedn_to_leaf_p(m) - leafn_xfer_p(m)/deltim + leafc_xfer_p(m) = 0._r8 + leafn_xfer_p(m) = leafc_xfer_p(m) / leafcn(ivt) + ENDIF + + ! enter phase 3 WHILE previous criteria fail and next is true; + ! in terms of order, phase 3 occurs before harvest, but when + ! harvest *can* occur, we want it to have first priority. + ! AgroIBIS uses a complex formula for lai decline. + ! USE CN's simple formula at least as a place holder (slevis) + + ELSE IF (hui_p(m) >= grnfill(ivt)) THEN + cphase_p(m) = 3._r8 + bglfr_p(m) = 1._r8/(leaf_long(ivt)*dayspyr*86400.) + ENDIF + + ! continue fertilizer application WHILE in phase 2; + ! assumes that onset of phase 2 took one time step only + + IF (fert_counter_p(m) <= 0._r8) THEN + fert_p(m) = 0._r8 + ELSE ! continue same fert application every timestep + fert_counter_p(m) = fert_counter_p(m) - deltim + ENDIF + + ELSE ! crop not live + ! next 2 lines conserve mass IF leaf*_xfer > 0 due to interpinic. + ! We subtract from any existing value in crop_seedc_to_leaf / + ! crop_seedn_to_leaf in the unlikely event that we enter this block of + ! code in the same time step WHERE the planting transfer originally + ! occurred. + crop_seedc_to_leaf_p(m) = crop_seedc_to_leaf_p(m) - leafc_xfer_p(m)/deltim + crop_seedn_to_leaf_p(m) = crop_seedn_to_leaf_p(m) - leafn_xfer_p(m)/deltim + onset_counter_p(m) = 0._r8 + leafc_xfer_p(m) = 0._r8 + leafn_xfer_p(m) = leafc_xfer_p(m) / leafcn(ivt) + IF(DEF_USE_FERT)THEN + fert_p(m) = 0._r8 + ENDIF + ENDIF ! croplive + ELSE + fert_p(m) = 0._r8 + ENDIF + ENDDO ! prognostic crops loop + + END SUBROUTINE CropPhenology +#endif + + !--------------------------------------------------------- + SUBROUTINE CNOnsetGrowth(i,ps,pe,deltim) + +! !DESCRIPTION: +! Calculates flux from transfer CN to display CN during onset period. +! Transfer CN -> DISPLAY CN + +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + + ! !LOCAL VARIABLES: + real(r8):: t1 ! temporary variable + integer :: ivt, m + + ! only calculate these fluxes during onset period + + DO m = ps, pe + ivt = pftclass(m) + IF (onset_flag_p(m) == 1._r8) THEN + + ! The transfer rate is a linearly decreasing FUNCTION of time, + ! going to zero on the last timestep of the onset period + + IF (onset_counter_p(m) == deltim) THEN + t1 = 1.0_r8 / deltim + ELSE + t1 = 2.0_r8 / (onset_counter_p(m)) + ENDIF + leafc_xfer_to_leafc_p(m) = t1 * leafc_xfer_p(m) + frootc_xfer_to_frootc_p(m) = t1 * frootc_xfer_p(m) + leafn_xfer_to_leafn_p(m) = t1 * leafn_xfer_p(m) + frootn_xfer_to_frootn_p(m) = t1 * frootn_xfer_p(m) + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = t1 * livestemc_xfer_p(m) + deadstemc_xfer_to_deadstemc_p(m) = t1 * deadstemc_xfer_p(m) + livecrootc_xfer_to_livecrootc_p(m) = t1 * livecrootc_xfer_p(m) + deadcrootc_xfer_to_deadcrootc_p(m) = t1 * deadcrootc_xfer_p(m) + livestemn_xfer_to_livestemn_p(m) = t1 * livestemn_xfer_p(m) + deadstemn_xfer_to_deadstemn_p(m) = t1 * deadstemn_xfer_p(m) + livecrootn_xfer_to_livecrootn_p(m) = t1 * livecrootn_xfer_p(m) + deadcrootn_xfer_to_deadcrootn_p(m) = t1 * deadcrootn_xfer_p(m) + ENDIF + + ENDIF ! ENDIF onset period + + ! calculate the background rate of transfer growth (used for stress + ! deciduous algorithm). in this CASE, all of the mass in the transfer + ! pools should be moved to displayed growth in each timestep. + + IF (bgtr_p(m) > 0._r8) THEN + leafc_xfer_to_leafc_p(m) = leafc_xfer_p(m) / deltim + frootc_xfer_to_frootc_p(m) = frootc_xfer_p(m) / deltim + leafn_xfer_to_leafn_p(m) = leafn_xfer_p(m) / deltim + frootn_xfer_to_frootn_p(m) = frootn_xfer_p(m) / deltim + IF (woody(ivt) == 1) THEN + livestemc_xfer_to_livestemc_p(m) = livestemc_xfer_p(m) / deltim + deadstemc_xfer_to_deadstemc_p(m) = deadstemc_xfer_p(m) / deltim + livecrootc_xfer_to_livecrootc_p(m) = livecrootc_xfer_p(m) / deltim + deadcrootc_xfer_to_deadcrootc_p(m) = deadcrootc_xfer_p(m) / deltim + livestemn_xfer_to_livestemn_p(m) = livestemn_xfer_p(m) / deltim + deadstemn_xfer_to_deadstemn_p(m) = deadstemn_xfer_p(m) / deltim + livecrootn_xfer_to_livecrootn_p(m) = livecrootn_xfer_p(m) / deltim + deadcrootn_xfer_to_deadcrootn_p(m) = deadcrootn_xfer_p(m) / deltim + ENDIF + ENDIF ! ENDIF bgtr + ENDDO + + END SUBROUTINE CNOnsetGrowth + + SUBROUTINE CNOffsetLitterfall(i,ps,pe,deltim,npcropmin) +! !DESCRIPTION: +! Calculates flux from display CN to litter CN during offset period. +! DISPLAY CN -> litter CN + +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: npcropmin ! first crop pft index + + real(r8) :: t1 ! temporary variable + real(r8) :: denom ! temporary variable for divisor + real(r8) :: ntovr_leaf + real(r8) :: fr_leafn_to_litter ! fraction of the nitrogen turnover that goes to litter; remaining fraction is retranslocated + integer :: ivt, m + + DO m = ps, pe + ivt = pftclass(m) + ! only calculate fluxes during offset period + IF (offset_flag_p(m) == 1._r8) THEN + + IF (offset_counter_p(m) == deltim) THEN + t1 = 1.0_r8 / deltim + leafc_to_litter_p(m) = t1 * leafc_p(m) + cpool_to_leafc_p(m) + frootc_to_litter_p(m) = t1 * frootc_p(m) + cpool_to_frootc_p(m) + ! this assumes that offset_counter == dt for crops + ! IF this were ever changed, we'd need to add code to the "ELSE" + IF (ivt >= npcropmin) THEN + ! Replenish the seed deficits from grain, IF there is enough + ! available grain. (IF there is not enough available grain, the seed + ! deficits will accumulate until there is eventually enough grain to + ! replenish them.) + grainc_to_seed_p(m) = t1 * min(-cropseedc_deficit_p(m), grainc_p(m)) + grainn_to_seed_p(m) = t1 * min(-cropseedn_deficit_p(m), grainn_p(m)) + ! Send the remaining grain to the food product pool + grainc_to_food_p(m) = t1 * grainc_p(m) + cpool_to_grainc_p(m) - grainc_to_seed_p(m) + grainn_to_food_p(m) = t1 * grainn_p(m) + npool_to_grainn_p(m) - grainn_to_seed_p(m) + + livestemc_to_litter_p(m) = t1 * livestemc_p(m) + cpool_to_livestemc_p(m) + ENDIF + ELSE + t1 = deltim * 2.0_r8 / (offset_counter_p(m) * offset_counter_p(m)) + leafc_to_litter_p(m) = prev_leafc_to_litter_p(m) + t1*(leafc_p(m) - prev_leafc_to_litter_p(m)*offset_counter_p(m)) + frootc_to_litter_p(m) = prev_frootc_to_litter_p(m) + t1*(frootc_p(m) - prev_frootc_to_litter_p(m)*offset_counter_p(m)) + + ENDIF + + leafn_to_litter_p(m) = leafc_to_litter_p(m) / lflitcn(ivt) + leafn_to_retransn_p(m) = (leafc_to_litter_p(m) / leafcn(ivt)) - leafn_to_litter_p(m) + + + ! calculate fine root N litterfall (no retranslocation of fine root N) + frootn_to_litter_p(m) = frootc_to_litter_p(m) / frootcn(ivt) + + IF (ivt >= npcropmin) THEN + ! NOTE(slevis, 2014-12) results in -ve livestemn and -ve totpftn + !X! livestemn_to_litter(p) = livestemc_to_litter(p) / livewdcn(ivt(p)) + ! NOTE(slevis, 2014-12) Beth Drewniak suggested this instead + livestemn_to_litter_p(m) = livestemn_p(m) / deltim + ENDIF + + ! SAVE the current litterfall fluxes + prev_leafc_to_litter_p(m) = leafc_to_litter_p(m) + prev_frootc_to_litter_p(m) = frootc_to_litter_p(m) + + ENDIF ! ENDIF offset period + ENDDO + + END SUBROUTINE CNOffsetLitterfall + + SUBROUTINE CNBackgroundLitterfall(i,ps,pe) + +! !DESCRIPTION: +! Calculate leaf and fine root background turnover. +! DISPLAY -> litter +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + + ! !LOCAL VARIABLES: + real(r8) :: fr_leafn_to_litter ! fraction of the nitrogen turnover that goes to litter; remaining fraction is retranslocated + real(r8) :: ntovr_leaf + real(r8) :: denom + integer :: ivt, m + !----------------------------------------------------------------------- + + DO m = ps , pe + ! only calculate these fluxes IF the background litterfall rate is non-zero + ivt = pftclass(m) + IF (bglfr_p(m) > 0._r8) THEN + ! units for bglfr are already 1/s + leafc_to_litter_p(m) = bglfr_p(m) * leafc_p(m) + frootc_to_litter_p(m) = bglfr_p(m) * frootc_p(m) + ! calculate the leaf N litterfall and retranslocation + leafn_to_litter_p(m) = leafc_to_litter_p(m) / lflitcn(ivt) + leafn_to_retransn_p(m) = (leafc_to_litter_p(m) / leafcn(ivt)) - leafn_to_litter_p(m) + + frootn_to_litter_p(m) = frootc_to_litter_p(m) / frootcn(ivt) + ENDIF + ENDDO + + END SUBROUTINE CNBackgroundLitterfall + + SUBROUTINE CNLivewoodTurnover(i,ps,pe) + +! !DESCRIPTION: +! Livewood transfer to deadwood each year +! +! !ORIGINAL: +! Community Land Model Version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2022, Revise the code to be compatible with CoLM code structure. + + integer, intent(in) :: i ! patch index + integer, intent(in) :: ps ! start pft index + integer, intent(in) :: pe ! END pft index + + ! !LOCAL VARIABLES: + real(r8):: ctovr ! temporary variable for carbon turnover + real(r8):: ntovr ! temporary variable for nitrogen turnover + integer :: ivt, m + !----------------------------------------------------------------------- + + DO m = ps, pe + ! only calculate these fluxes for woody types + ivt = pftclass(m) + IF (woody(ivt) > 0._r8) THEN + + ! live stem to dead stem turnover + + ctovr = livestemc_p(m) * lwtop + ntovr = ctovr / livewdcn(ivt) + livestemc_to_deadstemc_p(m) = ctovr + livestemn_to_deadstemn_p(m) = ctovr / deadwdcn(ivt) + + livestemn_to_retransn_p(m) = ntovr - livestemn_to_deadstemn_p(m) + !matrix for livestemn_to_retransn will be added in allocation SUBROUTINE + + ! live coarse root to dead coarse root turnover + + ctovr = livecrootc_p(m) * lwtop + ntovr = ctovr / livewdcn(ivt) + livecrootc_to_deadcrootc_p(m) = ctovr + livecrootn_to_deadcrootn_p(m) = ctovr / deadwdcn(ivt) + + livecrootn_to_retransn_p(m) = ntovr - livecrootn_to_deadcrootn_p(m) + ENDIF + ENDDO ! END pft loop + + END SUBROUTINE CNLivewoodTurnover + + SUBROUTINE CNGrainToProductPools(i,ps,pe) +! !DESCRIPTION: +! Summary crop production C & N from pft to patch +! +! !ORIGINAL: +! Community Land Model Version 5.0 (CLM5) +! +! !REVISION: +! Xingjie Lu, 2022, revised the code to be compatible with CoLM code structure + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + + integer m + real(r8) wtcol + + DO m = ps, pe + wtcol = pftfrac(m) + grainc_to_cropprodc(i) = grainc_to_cropprodc(i) + grainc_to_food_p(m) * wtcol + grainn_to_cropprodn(i) = grainn_to_cropprodn(i) + grainn_to_food_p(m) * wtcol + ENDDO + + END SUBROUTINE CNGrainToProductPools + + SUBROUTINE CNLitterToColumn(i,ps,pe,nl_soil,npcropmin) + +! !DESCRIPTION: +! Calculate column level litterfall flux from pft level litterfall. + +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code sturcture. + + integer ,intent(in) :: i ! patch index + integer ,intent(in) :: nl_soil ! number of total soil layers + integer ,intent(in) :: ps ! start pft index + integer ,intent(in) :: pe ! END pft index + integer ,intent(in) :: npcropmin ! first crop pft index + + integer j + integer ivt,m + real(r8):: wtcol + + DO j = 1, nl_soil + DO m = ps,pe + ivt = pftclass(m) + wtcol = pftfrac(m) + ! leaf litter carbon fluxes + phenology_to_met_c(j,i) = phenology_to_met_c(j,i) & + + leafc_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_cel_c(j,i) = phenology_to_cel_c(j,i) & + + leafc_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_lig_c(j,i) = phenology_to_lig_c(j,i) & + + leafc_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! leaf litter nitrogen fluxes + phenology_to_met_n(j,i) = phenology_to_met_n(j,i) & + + leafn_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_cel_n(j,i) = phenology_to_cel_n(j,i) & + + leafn_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_lig_n(j,i) = phenology_to_lig_n(j,i) & + + leafn_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! fine root litter carbon fluxes + phenology_to_met_c(j,i) = phenology_to_met_c(j,i) & + + frootc_to_litter_p(m) * fr_flab(ivt) * wtcol * froot_prof_p(j,m) + phenology_to_cel_c(j,i) = phenology_to_cel_c(j,i) & + + frootc_to_litter_p(m) * fr_fcel(ivt) * wtcol * froot_prof_p(j,m) + phenology_to_lig_c(j,i) = phenology_to_lig_c(j,i) & + + frootc_to_litter_p(m) * fr_flig(ivt) * wtcol * froot_prof_p(j,m) + + ! fine root litter nitrogen fluxes + phenology_to_met_n(j,i) = phenology_to_met_n(j,i) & + + frootn_to_litter_p(m) * fr_flab(ivt) * wtcol * froot_prof_p(j,m) + phenology_to_cel_n(j,i) = phenology_to_cel_n(j,i) & + + frootn_to_litter_p(m) * fr_fcel(ivt) * wtcol * froot_prof_p(j,m) + phenology_to_lig_n(j,i) = phenology_to_lig_n(j,i) & + + frootn_to_litter_p(m) * fr_flig(ivt) * wtcol * froot_prof_p(j,m) + + ! agroibis puts crop stem litter together with leaf litter + ! so I've used the leaf lf_f* parameters instead of making + ! new ones for now (slevis) + ! also for simplicity I've put "food" into the litter pools + + IF (ivt >= npcropmin) THEN ! add livestemc to litter + ! stem litter carbon fluxes + phenology_to_met_c(j,i) = phenology_to_met_c(j,i) & + + livestemc_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_cel_c(j,i) = phenology_to_cel_c(j,i) & + + livestemc_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_lig_c(j,i) = phenology_to_lig_c(j,i) & + + livestemc_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ! stem litter nitrogen fluxes + phenology_to_met_n(j,i) = phenology_to_met_n(j,i) & + + livestemn_to_litter_p(m) * lf_flab(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_cel_n(j,i) = phenology_to_cel_n(j,i) & + + livestemn_to_litter_p(m) * lf_fcel(ivt) * wtcol * leaf_prof_p(j,m) + phenology_to_lig_n(j,i) = phenology_to_lig_n(j,i) & + + livestemn_to_litter_p(m) * lf_flig(ivt) * wtcol * leaf_prof_p(j,m) + + ENDIF + ENDDO !END pft loop + ENDDO! END soil level loop + + END SUBROUTINE CNLitterToColumn + +#ifdef CROP + SUBROUTINE vernalization(i,m,deltim) +! !DESCRIPTION +! vernalizatoin for winter wheat. + +! ORITINAL: F. Li's GPAM model + integer, intent(in) :: i ! patch index + integer, intent(in) :: m ! pft index + real(r8),intent(in) :: deltim ! time step in seconds + ! LOCAL VARAIBLES: + real(r8) vtmin,vtopt,vtmax ! vernalization minimum, optimum, maximum temperature + real(r8) alpha ! parameter in calculating vernalization rate + real(r8) tc ! t_ref2m in degree C + real(r8) dt ! convert dtime from sec to hour + + +! for all equations - temperatures must be in degrees (C) +! calculate temperature of crown of crop (e.g., 3 cm soil temperature) +! snow depth in centimeters + + vtmin=-1.3_r8 + vtopt=4.9_r8 + vtmax=15.7_r8 + dt=deltim/3600.0_r8 !dt is the time step in hour + alpha=log(2._r8)/log((vtmax-vtmin)/(vtopt-vtmin)) + + tc = tref_p(m)-tfrz + IF(tc >=vtmin .and. tc <= vtmax) THEN + cumvd_p(m)=cumvd_p(m) + (2._r8*((tc-vtmin)**alpha)*(vtopt-vtmin)**alpha & + - (tc-vtmin)**(2._r8*alpha))/(vtopt-vtmin)**(2._r8*alpha)*(dt/24._r8) + ENDIF + + vf_p(m)=(cumvd_p(m)**5._r8)/(22.5_r8**5._r8+cumvd_p(m)**5._r8) + + END SUBROUTINE vernalization +#endif + +END MODULE MOD_BGC_Veg_CNPhenology +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 new file mode 100644 index 0000000000..5ad9767291 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_CNVegStructUpdate.F90 @@ -0,0 +1,159 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_CNVegStructUpdate + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! On the radiation time step, USE C state variables and epc to diagnose +! vegetation structure (LAI, SAI, height) +! +! ORIGINAL: +! The Community Land Model version 5.0 (CLM5) +! +! REVISION: +! Xingjie Lu, 2021, revised the CLM5 code to be compatible with CoLM code structure. +! + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_LAIFEEDBACK, DEF_USE_Fire + USE MOD_Vars_Global, only: nc3crop, nc3irrig, nbrdlf_evr_shrub, nbrdlf_dcd_brl_shrub, & + npcropmin, ntmp_corn, nirrig_tmp_corn, ntrp_corn, nirrig_trp_corn, & + nsugarcane, nirrig_sugarcane, nmiscanthus, nirrig_miscanthus, & + nswitchgrass, nirrig_switchgrass, noveg + + USE MOD_Vars_PFTimeVariables, only: lai_p, tlai_p, tsai_p, leafc_p, deadstemc_p, harvdate_p + USE MOD_Vars_TimeVariables, only: lai, tlai +#ifdef CROP + USE MOD_BGC_Vars_PFTimeVariables, only: peaklai_p +#endif + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + USE MOD_BGC_Vars_TimeVariables, only: farea_burned + USE MOD_Const_PFT, only: dsladlai, slatop, laimx, woody + + !CLM5 + PUBLIC :: CNVegStructUpdate + !----------------------------------------------------------------------- + +CONTAINS + + !----------------------------------------------------------------------- + SUBROUTINE CNVegStructUpdate(i,ps,pe,deltim,npcropmin) + + integer,intent(in) :: i ! patch index + integer,intent(in) :: ps ! start pft index + integer,intent(in) :: pe ! END pft index + real(r8),intent(in) :: deltim ! time step in seconds + integer,intent(in) :: npcropmin ! first crop pft index + + ! !LOCAL VARIABLES: + integer :: p,c,g ! indices + integer :: fp ! lake filter indices + real(r8) :: stocking ! #stems / ha (stocking density) + real(r8) :: ol ! thickness of canopy layer covered by snow (m) + real(r8) :: fb ! fraction of canopy layer covered by snow + real(r8) :: tlai_old ! for USE in Zeng tsai formula + real(r8) :: tsai_old ! for USE in Zeng tsai formula + real(r8) :: tsai_min ! PATCH derived minimum tsai + real(r8) :: tsai_alpha ! monthly decay rate of tsai + real(r8) :: frac_sno_adjusted ! frac_sno adjusted per frac_sno_threshold + + real(r8), parameter :: dtsmonth = 2592000._r8 ! number of seconds in a 30 day month (60x60x24x30) + real(r8), parameter :: frac_sno_threshold = 0.999_r8 ! frac_sno values greater than this are treated as 1 + real(r8), parameter :: natlaimx = 8._r8 + real(r8), parameter :: theta = 0.8_r8 + integer m, ivt +!----------------------------------------------------------------------- +! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835 +! +! tsai(m) = max( tsai_alpha(ivt(m))*tsai_old + max(tlai_old-tlai(m),0_r8), tsai_min(ivt(m)) ) +! notes: +! * RHS tsai & tlai are from previous timestep +! * should create tsai_alpha(ivt(m)) & tsai_min(ivt(m)) in pftconMod.F90 - slevis +! * all non-crop patches USE same values: +! crop tsai_alpha,tsai_min = 0.0,0.1 +! noncrop tsai_alpha,tsai_min = 0.5,1.0 (includes bare soil and urban) +!------------------------------------------------------------------------------- + + ! patch loop + + lai (i) = 0._r8 + DO m = ps, pe + ivt = pftclass(m) + IF (ivt /= noveg) THEN + + tlai_old = tlai_p(m) ! n-1 value + tsai_old = tsai_p(m) ! n-1 value + + IF(DEF_USE_LAIFEEDBACK)THEN + tlai_p(m) = ((natlaimx + slatop(ivt) * leafc_p(m)) & + - sqrt((natlaimx + slatop(ivt) * leafc_p(m))**2 & + - 4 * theta * natlaimx * slatop(ivt) * leafc_p(m)))/ (2*theta) + tlai_p(m) = max(0._r8, tlai_p(m)) + lai_p (m) = tlai_p(m) + ENDIF + + ! update the stem area index and height based on LAI, stem mass, and veg type. + ! With the exception of htop for woody vegetation, this follows the DGVM logic. + + ! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835 (see notes) + ! Assumes doalb time step .eq. CLM time step, SAI min and monthly decay factor + ! alpha are set by PFT, and alpha is scaled to CLM time step by multiplying by + ! deltim and dividing by dtsmonth (seconds in average 30 day month) + ! tsai_min scaled by 0.5 to match MODIS satellite derived values + IF (ivt == nc3crop .or. ivt == nc3irrig) THEN ! generic crops + + tsai_alpha = 1.0_r8-1.0_r8*deltim/dtsmonth + tsai_min = 0.1_r8 + ELSE + tsai_alpha = 1.0_r8-0.5_r8*deltim/dtsmonth + tsai_min = 1.0_r8 + ENDIF + tsai_min = tsai_min * 0.5_r8 + tsai_p(m) = max(tsai_alpha*tsai_old+max(tlai_old-tlai_p(m),0._r8),tsai_min) + + ! calculate vegetation physiological parameters used in biomass heat storage + ! + IF (woody(ivt) == 1._r8) THEN + + ! trees and shrubs for now have a very simple allometry, with hard-wired + ! stem taper (height:radius) and nstem from PFT parameter file + ELSE IF (ivt >= npcropmin) THEN ! prognostic crops +#ifdef CROP + IF (tlai_p(m) >= laimx(ivt)) peaklai_p(m) = 1 ! used in CNAllocation + + IF (ivt == ntmp_corn .or. ivt == nirrig_tmp_corn .or. & + ivt == ntrp_corn .or. ivt == nirrig_trp_corn .or. & + ivt == nsugarcane .or. ivt == nirrig_sugarcane .or. & + ivt == nmiscanthus .or. ivt == nirrig_miscanthus .or. & + ivt == nswitchgrass .or. ivt == nirrig_switchgrass) THEN + tsai_p(m) = 0.1_r8 * tlai_p(m) + ELSE + tsai_p(m) = 0.2_r8 * tlai_p(m) + ENDIF + + ! "stubble" after harvest + IF (harvdate_p(m) < 999 .and. tlai_p(m) == 0._r8) THEN + peaklai_p(m) = 0 + IF(DEF_USE_Fire)THEN + tsai_p(m) = 0.25_r8*(1._r8-farea_burned(i)*0.90_r8) !changed by F. Li and S. Levis + ENDIF + ENDIF +#endif + ENDIF + + ENDIF + +! adjust lai and sai for burying by snow. +! snow burial fraction for short vegetation (e.g. grasses, crops) changes with vegetation height +! accounts for a 20% bending factor, as used in Lombardozzi et al. (2018) GRL 45(18), 9889-9897 + +! NOTE: The following snow burial code is duplicated in SatellitePhenologyMod. +! Changes in one place should be accompanied by similar changes in the other. + lai(i) = lai(i) + lai_p(m) * pftfrac(m) + ENDDO + tlai(i) = lai(i) + + END SUBROUTINE CNVegStructUpdate + +END MODULE MOD_BGC_Veg_CNVegStructUpdate +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_NutrientCompetition.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_NutrientCompetition.F90 new file mode 100644 index 0000000000..3dba43ad97 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Veg_NutrientCompetition.F90 @@ -0,0 +1,539 @@ +#include +#ifdef BGC +MODULE MOD_BGC_Veg_NutrientCompetition + +!---------------------------------------------------------------------------------------------------- +! !DESCRIPTION +! This MODULE simulates the plant growth with regard to the available soil mineral nitrogen. +! Allocation of NPP and N uptake to different vegetation CN pools uses allocation scheme from CLM4.5. +! CALL sequence is: calc_plant_nutrient_demand_CLM45_default => calc_plant_nutrient_competition_CLM45_default +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. +! Fang Li, 2022, add GPAM C allocation scheme for crop. + + ! + USE MOD_Precision + USE MOD_Const_PFT, only: & + woody, leafcn, frootcn, livewdcn, deadwdcn, graincn, & + froot_leaf, croot_stem, stem_leaf, flivewd, grperc, grpnow, fcur2, & +! crop variables + astemf, arooti, arootf, fleafi, bfact, declfact, allconss, allconsl, fleafcn, fstemcn, ffrootcn, & + lfemerg, grnfill + + USE MOD_Vars_PFTimeInvariants, only: pftclass, pftfrac + + USE MOD_BGC_Vars_PFTimeVariables, only: & + xsmrpool_p, retransn_p, tempsum_npp_p, & + tempsum_potential_gpp_p, tempmax_retransn_p, annmax_retransn_p, annsum_potential_gpp_p, & +! crop variables +#ifdef CROP + croplive_p, hui_p, peaklai_p, & + aroot_p, astem_p, arepr_p, aleaf_p, astemi_p, aleafi_p, vf_p, & +#endif + c_allometry_p, n_allometry_p, downreg_p, grain_flag_p, annsum_npp_p, & + leafc_p, livestemc_p, frootc_p + USE MOD_Vars_Global, only: nwwheat, nirrig_wwheat + + USE MOD_BGC_Vars_TimeVariables, only: fpg + USE MOD_Vars_Global, only: ntmp_soybean, ntrp_soybean, nirrig_tmp_soybean, nirrig_trp_soybean + + USE MOD_Vars_1DPFTFluxes, only: assim_p + + USE MOD_BGC_Vars_1DPFTFluxes, only: & + leaf_xsmr_p, froot_xsmr_p, livestem_xsmr_p, livecroot_xsmr_p, grain_xsmr_p, cpool_to_xsmrpool_p, & + leaf_mr_p, froot_mr_p, livestem_mr_p, livecroot_mr_p, grain_mr_p, & + plant_ndemand_p, retransn_to_npool_p, cpool_to_leafc_p, cpool_to_leafc_storage_p, & + cpool_to_frootc_p, cpool_to_frootc_storage_p, cpool_to_livestemc_p, cpool_to_livestemc_storage_p, & + cpool_to_deadstemc_p, cpool_to_deadstemc_storage_p, cpool_to_livecrootc_p, cpool_to_livecrootc_storage_p, & + cpool_to_deadcrootc_p, cpool_to_deadcrootc_storage_p, cpool_to_grainc_p, cpool_to_grainc_storage_p, & + cpool_to_gresp_storage_p, npool_to_leafn_p, npool_to_leafn_storage_p, & + npool_to_frootn_p, npool_to_frootn_storage_p, npool_to_livestemn_p, npool_to_livestemn_storage_p, & + npool_to_deadstemn_p, npool_to_deadstemn_storage_p, npool_to_livecrootn_p, npool_to_livecrootn_storage_p, & + npool_to_deadcrootn_p, npool_to_deadcrootn_storage_p, npool_to_grainn_p, npool_to_grainn_storage_p, & + leafn_to_retransn_p, livestemn_to_retransn_p, frootn_to_retransn_p, & + plant_calloc_p, plant_nalloc_p, leaf_curmr_p, froot_curmr_p, livestem_curmr_p, livecroot_curmr_p, grain_curmr_p, & + psn_to_cpool_p, gpp_p, availc_p, avail_retransn_p, xsmrpool_recover_p, sminn_to_npool_p, excess_cflux_p + + IMPLICIT NONE + + PUBLIC calc_plant_nutrient_competition_CLM45_default + PUBLIC calc_plant_nutrient_demand_CLM45_default + +CONTAINS + + SUBROUTINE calc_plant_nutrient_competition_CLM45_default(i,ps,pe,npcropmin) + +!---------------------------------------------------------------------------- +! !DESCRIPTION +! Calulate the nitrogen limitation on the plant growth based on the available +! nitrogen and nitrogen demand from "calc_plant_nutrient_demand_CLM45_default". +! +! !Original: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. +! Fang Li, 2022, add GPAM C allocation scheme for crop. + + integer ,intent(in) :: i + integer ,intent(in) :: ps + integer ,intent(in) :: pe + integer ,intent(in) :: npcropmin + + ! !LOCAL VARIABLES: + real(r8):: f1,f2,f3,f4,g1,g2 ! allocation parameters + real(r8):: cnl,cnfr,cnlw,cndw ! C:N ratios for leaf, fine root, and wood + real(r8):: fcur ! fraction of current psn displayed as growth + real(r8):: gresp_storage ! temporary variable for growth resp to storage + real(r8):: nlc ! temporary variable for total new leaf carbon allocation + real(r8):: f5 ! grain allocation parameter + real(r8):: cng ! C:N ratio for grain (= cnlw for now; slevis) + integer :: ivt, m + + DO m = ps, pe + ivt = pftclass(m) + ! set some local allocation variables + f1 = froot_leaf(ivt) + f2 = croot_stem(ivt) + + ! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0, + ! constrained so that it does not go lower than 0.2 (under negative annsum_npp) + ! There was an error in this formula in previous version, WHERE the coefficient + ! was 0.004 instead of 0.0025. + ! This variable allocation is only for trees. Shrubs have a constant + ! allocation as specified in the pft-physiology file. The value is also used + ! as a trigger here: -1.0 means to USE the dynamic allocation (trees). + IF (stem_leaf(ivt) == -1._r8) THEN + f3 = (2.7/(1.0+exp(-0.004*(annsum_npp_p(m) - 300.0)))) - 0.4 + ELSE + f3 = stem_leaf(ivt) + ENDIF + + f4 = flivewd(ivt) + g1 = grperc(ivt) + g2 = grpnow(ivt) + cnl = leafcn(ivt) + cnfr = frootcn(ivt) + cnlw = livewdcn(ivt) + cndw = deadwdcn(ivt) + fcur = fcur2(ivt) + +#ifdef CROP + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + IF (croplive_p(m)) THEN + f1 = aroot_p(m) / aleaf_p(m) + f3 = astem_p(m) / aleaf_p(m) + f5 = arepr_p(m) / aleaf_p(m) + g1 = grperc(ivt) + ELSE + f1 = 0._r8 + f3 = 0._r8 + f5 = 0._r8 + g1 = grperc(ivt) + ENDIF + ENDIF +#endif + + sminn_to_npool_p(m) = plant_ndemand_p(m) * fpg(i) + + plant_nalloc_p(m) = sminn_to_npool_p(m) + retransn_to_npool_p(m) + plant_calloc_p(m) = plant_nalloc_p(m) * (c_allometry_p(m)/n_allometry_p(m)) + + + excess_cflux_p(m) = availc_p(m) - plant_calloc_p(m) + ! reduce gpp fluxes due to N limitation + IF (gpp_p(m) > 0.0_r8) THEN + downreg_p(m) = excess_cflux_p(m)/gpp_p(m) + psn_to_cpool_p(m) = psn_to_cpool_p(m) * (1._r8 - downreg_p(m)) + ELSE + downreg_p(m) = 0._r8 + ENDIF + + ! calculate the amount of new leaf C dictated by these allocation + ! decisions, and calculate the daily fluxes of C and N to current + ! growth and storage pools + + ! fcur is the proportion of this day's growth that is displayed now, + ! the remainder going into storage for display next year through the + ! transfer pools + + nlc = plant_calloc_p(m) / c_allometry_p(m) + cpool_to_leafc_p(m) = nlc * fcur + cpool_to_leafc_storage_p(m) = nlc * (1._r8 - fcur) + cpool_to_frootc_p(m) = nlc * f1 * fcur + cpool_to_frootc_storage_p(m) = nlc * f1 * (1._r8 - fcur) + IF (woody(ivt) == 1._r8) THEN + cpool_to_livestemc_p(m) = nlc * f3 * f4 * fcur + cpool_to_livestemc_storage_p(m) = nlc * f3 * f4 * (1._r8 - fcur) + cpool_to_deadstemc_p(m) = nlc * f3 * (1._r8 - f4) * fcur + cpool_to_deadstemc_storage_p(m) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_livecrootc_p(m) = nlc * f2 * f3 * f4 * fcur + cpool_to_livecrootc_storage_p(m) = nlc * f2 * f3 * f4 * (1._r8 - fcur) + cpool_to_deadcrootc_p(m) = nlc * f2 * f3 * (1._r8 - f4) * fcur + cpool_to_deadcrootc_storage_p(m) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + ENDIF +#ifdef CROP + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + cpool_to_livestemc_p(m) = nlc * f3 * f4 * fcur + cpool_to_livestemc_storage_p(m) = nlc * f3 * f4 * (1._r8 - fcur) + cpool_to_deadstemc_p(m) = nlc * f3 * (1._r8 - f4) * fcur + cpool_to_deadstemc_storage_p(m) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_livecrootc_p(m) = nlc * f2 * f3 * f4 * fcur + cpool_to_livecrootc_storage_p(m) = nlc * f2 * f3 * f4 * (1._r8 - fcur) + cpool_to_deadcrootc_p(m) = nlc * f2 * f3 * (1._r8 - f4) * fcur + cpool_to_deadcrootc_storage_p(m) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur) + cpool_to_grainc_p(m) = nlc * f5 * fcur + cpool_to_grainc_storage_p(m) = nlc * f5 * (1._r8 -fcur) + ENDIF +#endif + + ! corresponding N fluxes + npool_to_leafn_p(m) = (nlc / cnl) * fcur + npool_to_leafn_storage_p(m) = (nlc / cnl) * (1._r8 - fcur) + npool_to_frootn_p(m) = (nlc * f1 / cnfr) * fcur + npool_to_frootn_storage_p(m) = (nlc * f1 / cnfr) * (1._r8 - fcur) + IF (woody(ivt) == 1._r8) THEN + npool_to_livestemn_p(m) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage_p(m) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn_p(m) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage_p(m) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn_p(m) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage_p(m) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn_p(m) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage_p(m) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + ENDIF +#ifdef CROP + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + cng = graincn(ivt) + npool_to_livestemn_p(m) = (nlc * f3 * f4 / cnlw) * fcur + npool_to_livestemn_storage_p(m) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadstemn_p(m) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadstemn_storage_p(m) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_livecrootn_p(m) = (nlc * f2 * f3 * f4 / cnlw) * fcur + npool_to_livecrootn_storage_p(m) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur) + npool_to_deadcrootn_p(m) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur + npool_to_deadcrootn_storage_p(m) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur) + npool_to_grainn_p(m) = (nlc * f5 / cng) * fcur + npool_to_grainn_storage_p(m) = (nlc * f5 / cng) * (1._r8 -fcur) + ENDIF +#endif + + ! Calculate the amount of carbon that needs to go into growth + ! respiration storage to satisfy all of the storage growth demands. + ! Allows for the fraction of growth respiration that is released at the + ! time of fixation, versus the remaining fraction that is stored for + ! release at the time of display. Note that all the growth respiration + ! fluxes that get released on a given timestep are calculated in growth_resp(), + ! but that the storage of C for growth resp during display of transferred + ! growth is assigned here. + + gresp_storage = cpool_to_leafc_storage_p(m) + cpool_to_frootc_storage_p(m) + IF (woody(ivt) == 1._r8) THEN + gresp_storage = gresp_storage + cpool_to_livestemc_storage_p(m) + gresp_storage = gresp_storage + cpool_to_deadstemc_storage_p(m) + + gresp_storage = gresp_storage + cpool_to_livecrootc_storage_p(m) + gresp_storage = gresp_storage + cpool_to_deadcrootc_storage_p(m) + ENDIF + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + gresp_storage = gresp_storage + cpool_to_livestemc_storage_p(m) + gresp_storage = gresp_storage + cpool_to_grainc_storage_p(m) + ENDIF + cpool_to_gresp_storage_p(m) = gresp_storage * g1 * (1._r8 - g2) + + tempsum_npp_p(m) = tempsum_npp_p(m) + plant_calloc_p(m) + + + ENDDO ! END patch loop + + END SUBROUTINE calc_plant_nutrient_competition_CLM45_default + + SUBROUTINE calc_plant_nutrient_demand_CLM45_default(i,ps,pe,deltim,npcropmin) + +!---------------------------------------------------------------------------- +! !DESCRIPTION +! Calculate allocation fraction and plant nitrogen demand. +! +! !Original: +! The Community Land Model version 5.0 (CLM5.0) + +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. +! Fang Li, 2022, add GPAM C allocation scheme for crop. + + + integer ,intent(in) :: i + integer ,intent(in) :: ps + integer ,intent(in) :: pe + real(r8),intent(in) :: deltim + integer ,intent(in) :: npcropmin + + ! !LOCAL VARIABLES: + integer :: j ! indices + real(r8):: mr ! maintenance respiration (gC/m2/s) + real(r8):: f1,f2,f3,f4,g1,g2 ! allocation parameters + real(r8):: cnl,cnfr,cnlw,cndw ! C:N ratios for leaf, fine root, and wood + real(r8):: curmr, curmr_ratio ! xsmrpool temporary variables + real(r8):: f5 ! grain allocation parameter + real(r8):: cng ! C:N ratio for grain (= cnlw for now; slevis) + real(r8):: fleaf ! fraction allocated to leaf + real(r8):: t1 ! temporary variable + real(r8):: dayscrecover ! number of days to recover negative cpool + integer :: ivt, m + dayscrecover = 30._r8 + + DO m = ps, pe + ivt = pftclass(m) + psn_to_cpool_p(m) = assim_p(m) * 12.011_r8 + + gpp_p(m) = psn_to_cpool_p(m) + + ! get the time step total maintenance respiration + ! These fluxes should already be in gC/m2/s + + mr = leaf_mr_p(m) + froot_mr_p(m) + IF (woody(ivt) == 1.0_r8) THEN + mr = mr + livestem_mr_p(m) + livecroot_mr_p(m) + ELSE IF (ivt >= npcropmin) THEN +#ifdef CROP + IF (croplive_p(m)) mr = mr + livestem_mr_p(m) + grain_mr_p(m) +#endif + ENDIF + + ! carbon flux available for allocation + availc_p(m) = gpp_p(m) - mr + + ! new code added for isotope calculations, 7/1/05, PET + ! IF mr > gpp, THEN some mr comes from gpp, the rest comes from + ! cpool (xsmr) + IF (mr > 0._r8 .and. availc_p(m) < 0._r8) THEN + curmr = gpp_p(m) + curmr_ratio = curmr / mr + ELSE + curmr_ratio = 1._r8 + ENDIF + leaf_curmr_p(m) = leaf_mr_p(m) * curmr_ratio + leaf_xsmr_p(m) = leaf_mr_p(m) - leaf_curmr_p(m) + froot_curmr_p(m) = froot_mr_p(m) * curmr_ratio + froot_xsmr_p(m) = froot_mr_p(m) - froot_curmr_p(m) + livestem_curmr_p(m) = livestem_mr_p(m) * curmr_ratio + livestem_xsmr_p(m) = livestem_mr_p(m) - livestem_curmr_p(m) + livecroot_curmr_p(m) = livecroot_mr_p(m) * curmr_ratio + livecroot_xsmr_p(m) = livecroot_mr_p(m) - livecroot_curmr_p(m) + grain_curmr_p(m) = grain_mr_p(m) * curmr_ratio + grain_xsmr_p(m) = grain_mr_p(m) - grain_curmr_p(m) + + ! no allocation when available c is negative + availc_p(m) = max(availc_p(m),0.0_r8) + + ! test for an xsmrpool deficit + IF (xsmrpool_p(m) < 0.0_r8) THEN + ! Running a deficit in the xsmrpool, so the first priority is to let + ! some availc from this timestep accumulate in xsmrpool. + ! Determine rate of recovery for xsmrpool deficit + + xsmrpool_recover_p(m) = -xsmrpool_p(m)/(dayscrecover*86400._r8) + IF (xsmrpool_recover_p(m) < availc_p(m)) THEN + ! available carbon reduced by amount for xsmrpool recovery + availc_p(m) = availc_p(m) - xsmrpool_recover_p(m) + ELSE + ! all of the available carbon goes to xsmrpool recovery + xsmrpool_recover_p(m) = availc_p(m) + availc_p(m) = 0.0_r8 + ENDIF + cpool_to_xsmrpool_p(m) = xsmrpool_recover_p(m) + ENDIF + + f1 = froot_leaf(ivt) + f2 = croot_stem(ivt) + + ! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0, + ! constrained so that it does not go lower than 0.2 (under negative annsum_npp) + ! This variable allocation is only for trees. Shrubs have a constant + ! allocation as specified in the pft-physiologfy file. The value is also used + ! as a trigger here: -1.0 means to USE the dynamic allocation (trees). + + IF (stem_leaf(ivt) == -1._r8) THEN + f3 = (2.7/(1.0+exp(-0.004*(annsum_npp_p(m) - 300.0)))) - 0.4 + ELSE + f3 = stem_leaf(ivt) + ENDIF + + f4 = flivewd(ivt) + g1 = grperc(ivt) + g2 = grpnow(ivt) + cnl = leafcn(ivt) + cnfr = frootcn(ivt) + cnlw = livewdcn(ivt) + cndw = deadwdcn(ivt) + + ! calculate f1 to f5 for prog crops following AgroIBIS subr phenocrop + + f5 = 0._r8 ! continued intializations from above +#ifdef CROP + IF (ivt >= npcropmin) THEN ! skip 2 generic crops + + IF (croplive_p(m)) THEN + ! same phases appear in SUBROUTINE CropPhenology + + ! Phase 1 completed: + ! ================== + ! Next phase: leaf emergence to start of leaf decline + + IF (hui_p(m) >= lfemerg(ivt) .and. hui_p(m) < grnfill(ivt)) THEN + ! allocation rules for crops based on maturity and linear decrease + ! of amount allocated to roots over course of the growing season + + IF (peaklai_p(m) == 1) THEN ! lai at maximum allowed + arepr_p(m) = 0._r8 + aleaf_p(m) = 1.e-5_r8 + astem_p(m) = 0._r8 + aroot_p(m) = 1._r8 - arepr_p(m) - aleaf_p(m) - astem_p(m) + ELSE + arepr_p(m) = 0._r8 + aroot_p(m) = arooti(ivt) - (arooti(ivt) - arootf(ivt)) * hui_p(m) + fleaf = fleafi(ivt) * (exp(-bfact(ivt)) - & + exp(-bfact(ivt)*hui_p(m)/grnfill(ivt))) / & + (exp(-bfact(ivt))-1) ! fraction alloc to leaf (from J Norman alloc curve) + aleaf_p(m) = max(1.e-5_r8, (1._r8 - aroot_p(m)) * fleaf) + astem_p(m) = 1._r8 - arepr_p(m) - aleaf_p(m) - aroot_p(m) + ENDIF + ! AgroIBIS included here an immediate adjustment to aleaf & astem IF the + ! predicted lai from the above allocation coefficients exceeded laimx. + ! We have decided to live with lais slightly higher than laimx by + ! enforcing the cap in the following tstep through the peaklai logic above. + + astemi_p(m) = astem_p(m) ! SAVE for USE by equations after shift to reproductive + grain_flag_p(m) = 0._r8 ! phenology stage begins setting to 0 WHILE in phase 2 + + ! Phase 2 completed: + ! ================== + ! shift allocation either when enough hui are accumulated or maximum number + ! of days has elapsed since planting + + ELSE IF (hui_p(m) >= grnfill(ivt)) THEN + + aroot_p(m) = arooti(ivt) - (arooti(ivt) - arootf(ivt)) * min(1._r8, hui_p(m)) + astem_p(m) = max(astemf(ivt), astem_p(m) * max(0._r8, (1._r8-hui_p(m))/ & + (1._r8-grnfill(ivt)))**allconss(ivt)) + aleaf_p(m) = 1.e-5_r8 + + !Beth's retranslocation of leafn, stemn, rootn to organ + !Filter excess plant N to retransn pool for organ N + !only DO one time THEN hold grain_flag till onset next season + + IF (astem_p(m) == astemf(ivt) .or. & + (ivt /= ntmp_soybean .and. ivt /= nirrig_tmp_soybean .and.& + ivt /= ntrp_soybean .and. ivt /= nirrig_trp_soybean)) THEN + IF (grain_flag_p(m) == 0._r8)THEN + t1 = 1._r8 / deltim + leafn_to_retransn_p(m) = t1 * ((leafc_p(m) / leafcn(ivt)) - (leafc_p(m) / & + fleafcn(ivt))) + livestemn_to_retransn_p(m) = t1 * ((livestemc_p(m) / livewdcn(ivt)) - (livestemc_p(m) / & + fstemcn(ivt))) + frootn_to_retransn_p(m) = 0._r8 + IF (ffrootcn(ivt) > 0._r8) THEN + frootn_to_retransn_p(m) = t1 * ((frootc_p(m) / frootcn(ivt)) - (frootc_p(m) / & + ffrootcn(ivt))) + ENDIF + grain_flag_p(m) = 1._r8 + ENDIF + ENDIF + + arepr_p(m) = 1._r8 - aroot_p(m) - astem_p(m) - aleaf_p(m) + !F. Li for vernalization effect 2 + IF(ivt == nwwheat .or. ivt == nirrig_wwheat) THEN + arepr_p(m) = arepr_p(m)*vf_p(m) + aroot_p(m) = 1._r8 - aleaf_p(m) - astem_p(m) - arepr_p(m) + ENDIF + ELSE ! pre emergence + aleaf_p(m) = 1.e-5_r8 ! allocation coefficients should be irrelevant + astem_p(m) = 0._r8 ! because crops have no live carbon pools; + aroot_p(m) = 0._r8 ! this applies to this "ELSE" and to the "ELSE" + arepr_p(m) = 0._r8 ! a few lines down + ENDIF + + f1 = aroot_p(m) / aleaf_p(m) + f3 = astem_p(m) / aleaf_p(m) + f5 = arepr_p(m) / aleaf_p(m) + g1 = grperc(ivt) + + ELSE ! .not croplive + f1 = 0._r8 + f3 = 0._r8 + f5 = 0._r8 + g1 = grperc(ivt) + ENDIF + ENDIF +#endif + +! based on available C, USE constant allometric relationships to +! determine N requirements + +!RF. I removed the growth respiration from this, because it is used to calculate +!plantCN for N uptake and c_allometry for allocation. IF we add gresp to the +!allometry calculation THEN we allocate too much carbon since gresp is not allocated here. + IF (woody(ivt) == 1.0_r8) THEN + c_allometry_p(m) = (1._r8+g1)*(1._r8+f1+f3*(1._r8+f2)) + n_allometry_p(m) = 1._r8/cnl + f1/cnfr + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw + ELSE IF (ivt >= npcropmin) THEN ! skip generic crops +#ifdef CROP + cng = graincn(ivt) + c_allometry_p(m) = (1._r8+g1)*(1._r8+f1+f5+f3*(1._r8+f2)) + n_allometry_p(m) = 1._r8/cnl + f1/cnfr + f5/cng + (f3*f4*(1._r8+f2))/cnlw + & + (f3*(1._r8-f4)*(1._r8+f2))/cndw +#endif + ELSE + c_allometry_p(m) = 1._r8+g1+f1+f1*g1 + n_allometry_p(m) = 1._r8/cnl + f1/cnfr + ENDIF + + plant_ndemand_p(m) = availc_p(m)*(n_allometry_p(m)/c_allometry_p(m)) + + ! retranslocated N deployment depends on seasonal CYCLE of potential GPP + ! (requires one year run to accumulate demand) + + tempsum_potential_gpp_p(m) = tempsum_potential_gpp_p(m) + gpp_p(m) + + ! Adding the following line to carry max retransn info to CN Annual Update + tempmax_retransn_p(m) = max(tempmax_retransn_p(m),retransn_p(m)) + + ! Beth's code: crops pull from retransn pool only during grain fill; + ! retransn pool has N from leaves, stems, and roots for + ! retranslocation + + IF (ivt >= npcropmin .and. grain_flag_p(m) == 1._r8) THEN + avail_retransn_p(m) = plant_ndemand_p(m) + ELSE IF (ivt < npcropmin .and. annsum_potential_gpp_p(m) > 0._r8) THEN + avail_retransn_p(m) = (annmax_retransn_p(m)/2._r8)*(gpp_p(m)/annsum_potential_gpp_p(m))/deltim + ELSE + avail_retransn_p(m) = 0.0_r8 + ENDIF + + ! make sure available retrans N doesn't exceed storage + avail_retransn_p(m) = min(avail_retransn_p(m), retransn_p(m)/deltim) + + ! modify plant N demand according to the availability of + ! retranslocated N + ! take from retransn pool at most the flux required to meet + ! plant ndemand + + IF (plant_ndemand_p(m) > avail_retransn_p(m)) THEN + retransn_to_npool_p(m) = avail_retransn_p(m) + ELSE + retransn_to_npool_p(m) = plant_ndemand_p(m) + ENDIF + + plant_ndemand_p(m) = plant_ndemand_p(m) - retransn_to_npool_p(m) + + ENDDO ! END loop pft patch. + + END SUBROUTINE calc_plant_nutrient_demand_CLM45_default + +END MODULE MOD_BGC_Veg_NutrientCompetition +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_driver.F90 b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_driver.F90 new file mode 100644 index 0000000000..6f386687ef --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_driver.F90 @@ -0,0 +1,166 @@ +#include +#ifdef BGC + + SUBROUTINE bgc_driver (i,idate,deltim,dlat,dlon) + +!----------------------------------------------------------------------------------------------------------- +! !DESCRIPTION: +! The trunk subroutine of the CoLM biogeochemistry module. The bgc_driver link different bgc processes, and +! sequentially run each process step by step. bgc_driver was called by CoLMDRIVER includes vegetation +! and soil CN cycle processes. +! +! +! !ORIGINAL: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REFERENCES: +! Lawrence, D.M., Fisher, R.A., Koven, C.D., Oleson, K.W., Swenson, S.C., Bonan, G., Collier, N., +! Ghimire, B., van Kampenhout, L., Kennedy, D. and Kluzek, E., 2019. +! The Community Land Model version 5: Description of new features, benchmarking, +! and impact of forcing uncertainty. Journal of Advances in Modeling Earth Systems, 11(12), 4245-4287. +! +! !REVISION: +! Xingjie Lu, 2022, modify original CLM5 to be compatible with CoLM code structure. + + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SASU, DEF_USE_DiagMatrix, DEF_USE_NITRIF, DEF_USE_CNSOYFIXN, DEF_USE_FIRE, DEF_USE_IRRIGATION + USE MOD_Const_Physical, only: tfrz, denh2o, denice + USE MOD_Vars_PFTimeInvariants, only: pftfrac + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_BGC_Vars_1DFluxes, only: plant_ndemand, ndep_to_sminn + USE MOD_BGC_Vars_1DPFTFluxes, only: plant_ndemand_p, cpool_to_leafc_p, crop_seedc_to_leaf_p + USE MOD_BGC_Veg_CNMResp, only: CNMResp + USE MOD_BGC_Soil_BiogeochemDecompCascadeBGC, only: decomp_rate_constants_bgc + USE MOD_BGC_Soil_BiogeochemPotential, only: SoilBiogeochemPotential + USE MOD_BGC_Soil_BiogeochemVerticalProfile, only: SoilBiogeochemVerticalProfile + USE MOD_BGC_Veg_NutrientCompetition, only: calc_plant_nutrient_demand_CLM45_default,& + calc_plant_nutrient_competition_CLM45_default + USE MOD_BGC_Soil_BiogeochemNitrifDenitrif, only: SoilBiogeochemNitrifDenitrif + + USE MOD_BGC_Soil_BiogeochemCompetition, only: SoilBiogeochemCompetition + USE MOD_BGC_Soil_BiogeochemDecomp, only: SoilBiogeochemDecomp + USE MOD_BGC_Veg_CNPhenology, only: CNPhenology + USE MOD_BGC_Veg_CNGResp, only: CNGResp + USE MOD_BGC_CNCStateUpdate1, only: CStateUpdate1 + USE MOD_BGC_CNNStateUpdate1, only: NStateUpdate1 + USE MOD_BGC_Soil_BiogeochemNStateUpdate1, only: SoilBiogeochemNStateUpdate1 + USE MOD_BGC_Soil_BiogeochemLittVertTransp, only: SoilBiogeochemLittVertTransp + USE MOD_BGC_Veg_CNGapMortality, only: CNGapMortality + USE MOD_BGC_CNCStateUpdate2, only: CStateUpdate2 + USE MOD_BGC_CNNStateUpdate2, only: NStateUpdate2 + USE MOD_BGC_CNCStateUpdate3, only: CStateUpdate3 + USE MOD_BGC_Soil_BiogeochemNLeaching, only: SoilBiogeochemNLeaching + USE MOD_BGC_CNNStateUpdate3, only: NstateUpdate3 + USE MOD_BGC_CNSummary, only: CNDriverSummarizeStates, CNDriverSummarizeFluxes + USE MOD_BGC_CNAnnualUpdate, only: CNAnnualUpdate + USE MOD_BGC_CNZeroFluxes, only: CNZeroFluxes + USE MOD_BGC_Veg_CNVegStructUpdate, only: CNVegStructUpdate + USE MOD_BGC_CNBalanceCheck, only: BeginCNBalance, CBalanceCheck, NBalanceCheck + USE MOD_BGC_CNSASU, only: CNSASU + USE MOD_BGC_Veg_CNNDynamics, only: CNNFixation +#ifdef CROP + USE MOD_BGC_Veg_CNNDynamics, only: CNNFert, CNSoyfix + USE MOD_Irrigation, only: CalIrrigationNeeded +#endif + USE MOD_TimeManager + USE MOD_Vars_Global, only: nl_soil, nl_soil_full, ndecomp_pools, ndecomp_pools_vr, ndecomp_transitions, npcropmin, & + z_soi,dz_soi,zi_soi,nbedrock,zmin_bedrock + + USE MOD_BGC_Vars_TimeVariables, only: sminn_vr, col_begnb, skip_balance_check, decomp_cpools_vr + USE MOD_BGC_Veg_CNFireBase, only: CNFireFluxes + USE MOD_BGC_Veg_CNFireLi2016, only: CNFireArea + + IMPLICIT NONE + + integer ,intent(in) :: i ! patch index + real(r8),intent(in) :: deltim ! time step in seconds + integer ,intent(in) :: idate(3) ! current date (year, day of the year, seconds of the day) + real(r8),intent(in) :: dlat ! latitude (degrees) + real(r8),intent(in) :: dlon ! longitude (degrees) + + integer :: ps, pe + integer j + ps = patch_pft_s(i) + pe = patch_pft_e(i) + CALL BeginCNBalance(i) + CALL CNZeroFluxes(i, ps, pe, nl_soil, ndecomp_pools, ndecomp_transitions) + CALL CNNFixation(i,idate) + CALL CNMResp(i, ps, pe, nl_soil, npcropmin) + CALL decomp_rate_constants_bgc(i, nl_soil, z_soi) + CALL SoilBiogeochemPotential(i,nl_soil,ndecomp_pools,ndecomp_transitions) + CALL SoilBiogeochemVerticalProfile(i,ps,pe,nl_soil,nl_soil_full,nbedrock,zmin_bedrock,z_soi,dz_soi) + IF(DEF_USE_NITRIF)THEN + CALL SoilBiogeochemNitrifDenitrif(i,nl_soil,dz_soi) + ENDIF + CALL calc_plant_nutrient_demand_CLM45_default(i,ps,pe,deltim,npcropmin) + + plant_ndemand(i) = sum( plant_ndemand_p(ps:pe)*pftfrac(ps:pe) ) + + CALL SoilBiogeochemCompetition(i,deltim,nl_soil,dz_soi) + CALL calc_plant_nutrient_competition_CLM45_default(i,ps,pe,npcropmin) +#ifdef CROP + IF(DEF_USE_CNSOYFIXN)THEN + CALL CNSoyfix (i, ps, pe, nl_soil) + ENDIF +#endif + + CALL SoilBiogeochemDecomp(i,nl_soil,ndecomp_pools,ndecomp_transitions, dz_soi) + CALL CNPhenology(i,ps,pe,nl_soil,idate(1:3),dz_soi,deltim,dlat,npcropmin,phase=1) + CALL CNPhenology(i,ps,pe,nl_soil,idate(1:3),dz_soi,deltim,dlat,npcropmin,phase=2) +#ifdef CROP + CALL CNNFert(i, ps, pe) +#endif + CALL CNGResp(i, ps, pe, npcropmin) +#ifdef CROP + IF(DEF_USE_IRRIGATION)THEN + CALL CalIrrigationNeeded(i,idate,nl_soil,nbedrock,z_soi,zi_soi,dz_soi,deltim,dlon,npcropmin) + ENDIF +#endif + ! update vegetation pools from phenology, allocation and nitrogen uptake + ! update soil N pools from decomposition and nitrogen competition + CALL CStateUpdate1(i, ps, pe, deltim, nl_soil, ndecomp_transitions, npcropmin) + CALL NStateUpdate1(i, ps, pe, deltim, nl_soil, ndecomp_transitions, npcropmin,dz_soi) + CALL SoilBiogeochemNStateUpdate1(i,deltim,nl_soil,ndecomp_transitions,dz_soi) + + ! update soil pools from soil vertical mixing + CALL SoilBiogeochemLittVertTransp(i,deltim,nl_soil,nl_soil_full,ndecomp_pools,nbedrock,z_soi,zi_soi,dz_soi) + + ! update vegetation pools from gap mortality + CALL CNGapMortality(i, ps, pe, nl_soil, npcropmin) + CALL CStateUpdate2(i, ps, pe, deltim, nl_soil) + CALL NStateUpdate2(i, ps, pe, deltim, nl_soil, dz_soi) + + IF(DEF_USE_FIRE)THEN + ! update vegetation and fire pools from fire + CALL CNFireArea(i,ps,pe,dlat,nl_soil,idate,dz_soi) + CALL CNFireFluxes(i,ps,pe,dlat,nl_soil,ndecomp_pools) + ENDIF + CALL CStateUpdate3(i,ps,pe,deltim, nl_soil, ndecomp_pools) + CALL CNAnnualUpdate(i,ps,pe,deltim,idate(1:3)) + + ! update soil mineral nitrogen pools leaching + CALL SoilBiogeochemNLeaching(i,deltim,nl_soil,zi_soi,dz_soi) + CALL NstateUpdate3(i, ps, pe, deltim, nl_soil, ndecomp_pools,dz_soi) + + IF(DEF_USE_SASU .or. DEF_USE_DiagMatrix)THEN + CALL CNSASU(i,ps,pe,deltim,idate(1:3),nl_soil,ndecomp_transitions,ndecomp_pools,ndecomp_pools_vr)! only for spin up + ENDIF + + CALL CNDriverSummarizeStates(i,ps,pe,nl_soil,dz_soi,ndecomp_pools, .false.) + CALL CNDriverSummarizeFluxes(i,ps,pe,nl_soil,dz_soi,ndecomp_transitions,ndecomp_pools,deltim) + + IF( .not. skip_balance_check(i) )THEN + CALL CBalanceCheck(i,ps,pe,nl_soil,dz_soi,deltim,dlat,dlon) + CALL NBalanceCheck(i,ps,pe,deltim,dlat,dlon) + + + ELSE + skip_balance_check(i) = .false. + ENDIF + + CALL CNVegStructUpdate(i,ps,pe,deltim,npcropmin) + + END SUBROUTINE bgc_driver + +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 b/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 new file mode 100644 index 0000000000..db9902d382 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90 @@ -0,0 +1,344 @@ +#include + +SUBROUTINE CoLMDRIVER (idate,deltim,dolai,doalb,dosst,oro) + + +!======================================================================= +! +! CoLM MODEL DRIVER +! +! Initial : Yongjiu Dai, 1999-2014 +! Revised : Hua Yuan, Shupeng Zhang, Nan Wei, Xingjie Lu, Zhongwang Wei, Yongjiu Dai +! 2014-2024 +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, rgas, vonkar + USE MOD_Const_LC + USE MOD_Vars_Global + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + USE MOD_Vars_1DForcing + USE MOD_Vars_1DFluxes + USE MOD_LandPatch, only: numpatch,landpatch + USE MOD_LandUrban, only: patch2urban + USE MOD_Namelist, only: DEF_URBAN_RUN +#ifdef HYPERSPECTRAL + USE MOD_HighRes_Parameters +#endif + IMPLICIT NONE + + integer, intent(in) :: idate(3) ! model calendar for next time step (year, julian day, seconds) + real(r8), intent(in) :: deltim ! seconds in a time-step + + logical, intent(in) :: dolai ! true if time for time-varying vegetation parameter + logical, intent(in) :: doalb ! true if time for surface albedo calculation + logical, intent(in) :: dosst ! true if time for update sst/ice/snow + + real(r8), intent(inout) :: oro(numpatch) ! ocean(0)/seaice(2)/ flag + + real(r8) :: deltim_phy + integer :: steps_in_one_deltim + integer :: i, m, u, k + +! ====================================================================== + +!$OMP PARALLEL DO & +!$OMP PRIVATE(i, m, u, k, steps_in_one_deltim, deltim_phy) & +!$OMP SCHEDULE(STATIC, 1) + + DO i = 1, numpatch + + ! Apply patch mask, but still run virtual 2m WMO patch (patch ipxstt=-1) + IF (DEF_Output_2mWMO) THEN + IF (.not. patchmask(i) .and. (landpatch%ipxstt(i)>0) ) CYCLE + ELSE + IF (.not. patchmask(i)) CYCLE + ENDIF + + m = patchclass(i) + + steps_in_one_deltim = 1 + ! deltim need to be within 1800s for water body with snow in order to avoid large + ! temperature fluctuations due to rapid snow heat conductance + IF(m == WATERBODY) steps_in_one_deltim = ceiling(deltim/1800.) + deltim_phy = deltim/steps_in_one_deltim + + ! For non urban patch or slab urban + IF (.not.DEF_URBAN_RUN .or. m.ne.URBAN) THEN + + DO k = 1, steps_in_one_deltim + ! ***** Call CoLM main program ***** + ! + CALL CoLMMAIN ( i,idate, coszen(i), deltim_phy, & + patchlonr(i), patchlatr(i), patchclass(i), patchtype(i), & + doalb, dolai, dosst, oro(i), & + + ! SOIL INFORMATION AND LAKE DEPTH + soil_s_v_alb(i), soil_d_v_alb(i), soil_s_n_alb(i), soil_d_n_alb(i), & + vf_quartz(1:,i), vf_gravels(1:,i),vf_om(1:,i), vf_sand(1:,i), & + wf_gravels(1:,i),wf_sand(1:,i), porsl(1:,i), psi0(1:,i), & + bsw(1:,i), theta_r(1:,i), fsatmax(i), fsatdcf(i), & + topoweti(i), alp_twi(i), chi_twi(i), mu_twi(i), & +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm(1:,i), n_vgm(1:,i), L_vgm(1:,i), & + sc_vgm(1:,i), fc_vgm(1:,i), & +#endif + hksati(1:,i), csol(1:,i), k_solids(1:,i), dksatu(1:,i), & + dksatf(1:,i), dkdry(1:,i), BA_alpha(1:,i), BA_beta(1:,i), & + rootfr(1:,m), lakedepth(i), dz_lake(1:,i), elvstd(i), & + BVIC(i), & + ! VEGETATION INFORMATION + htop(i), hbot(i), sqrtdi(m), & + effcon(m), vmax25(m), c3c4(m), & + kmax_sun(m), kmax_sha(m), kmax_xyl(m), kmax_root(m), & + psi50_sun(m), psi50_sha(m), psi50_xyl(m), psi50_root(m), & + ck(m), slti(m), hlti(m), shti(m), & + hhti(m), trda(m), trdm(m), trop(m), & + g1(m), g0(m), gradm(m), binter(m), & + extkn(m), chil(m), rho(1:,1:,m), tau(1:,1:,m), & +#ifdef HYPERSPECTRAL + ! variables for high spectral resolution + ! note that rho & tau are depend on wavelength + clr_frac, cld_frac, & + reflectance(0:,1:,1:), transmittance(0:,1:,1:), & + soil_alb(1:,i), kw(1:), nw(1:), & +#endif + + ! ATMOSPHERIC FORCING + forc_pco2m(i), forc_po2m(i), forc_us(i), forc_vs(i), & + forc_t(i), forc_q(i), forc_prc(i), forc_prl(i), & + forc_rain(i), forc_snow(i), forc_psrf(i), forc_pbot(i), & + forc_sols(i), forc_soll(i), forc_solsd(i), forc_solld(i), & + forc_frl(i), forc_hgt_u(i), forc_hgt_t(i), forc_hgt_q(i), & + forc_rhoair(i), & +#ifdef HYPERSPECTRAL + ! solar forcing + forc_solarin(i), & +#endif + ! CBL height forcing + forc_hpbl(i), & + ! Aerosol deposition + forc_aerdep(:,i), & + + ! LAND SURFACE VARIABLES REQUIRED FOR RESTART + z_sno(maxsnl+1:,i), dz_sno(maxsnl+1:,i), & + t_soisno(maxsnl+1:,i), wliq_soisno(maxsnl+1:,i), & + wice_soisno(maxsnl+1:,i), smp(1:,i), hk(1:,i), & + t_grnd(i), tleaf(i), ldew(i), ldew_rain(i), & + ldew_snow(i), fwet_snow(i), sag(i), scv(i), & + snowdp(i), fveg(i), fsno(i), sigf(i), & + green(i), lai(i), sai(i), alb(1:,1:,i), & + ssun(1:,1:,i), ssha(1:,1:,i), ssoi(:,:,i), ssno(:,:,i), & + thermk(i), extkb(i), extkd(i), vegwp(1:,i), & + gs0sun(i), gs0sha(i), & +#ifdef HYPERSPECTRAL + ! high-res variables + alb_hires(1:,1:,i), & + sol_dir_ln_hires(1:,i), sol_dif_ln_hires(1:,i) ,& + sr_dir_ln_hires(1:,i) , sr_dif_ln_hires (1:,i) ,& + reflectance_out(:,:,i), transmittance_out(:,:,i),& +#endif + ! Ozone Stress Variables + o3coefv_sun(i), o3coefv_sha(i), o3coefg_sun(i), o3coefg_sha(i), & + lai_old(i), o3uptakesun(i), o3uptakesha(i), forc_ozone(i), & + ! End ozone stress variables + ! WUE stomata model parameter + lambda(m), & + ! End WUE model parameter + zwt(i), wdsrf(i), wa(i), wetwat(i), & + t_lake(1:,i), lake_icefrac(1:,i), savedtke1(i), & + + ! SNICAR snow model related + snw_rds(:,i), ssno_lyr(:,:,:,i), & + mss_bcpho(:,i), mss_bcphi(:,i), mss_ocpho(:,i), mss_ocphi(:,i), & + mss_dst1(:,i), mss_dst2(:,i), mss_dst3(:,i), mss_dst4(:,i), & + + ! additional diagnostic variables for output + laisun(i), laisha(i), rootr(1:,i), rootflux(1:,i), & + rstfacsun_out(i),rstfacsha_out(i),gssun_out(i), gssha_out(i), & + assimsun_out(i), etrsun_out(i), assimsha_out(i), etrsha_out(i), & + h2osoi(1:,i), wat(i), rss(i), & + + ! FLUXES + taux(i), tauy(i), fsena(i), fevpa(i), & + lfevpa(i), fsenl(i), fevpl(i), etr(i), & + fseng(i), fevpg(i), olrg(i), fgrnd(i), & + trad(i), tref(i), qref(i), t2m_wmo(i), & + frcsat(i), rsur(i), rsur_se(i), rsur_ie(i), & + rsub(i), & + rnof(i), qintr(i), qinfl(i), qlayer(0:,i), & + lake_deficit(i), qdrip(i), rst(i), assim(i), & + respc(i), sabvsun(i), sabvsha(i), sabg(i), & + sr(i), solvd(i), solvi(i), solnd(i), & + solni(i), srvd(i), srvi(i), srnd(i), & + srni(i), solvdln(i), solviln(i), solndln(i), & + solniln(i), srvdln(i), srviln(i), srndln(i), & + srniln(i), qcharge(i), xerr(i), zerr(i), & + + ! TUNABLE modle constants + zlnd, zsno, csoilc, dewmx, & + ! 'wtfact' is updated to gridded 'fsatmax' data. + capr, cnfac, ssi, wimp, & + pondmx, smpmax, smpmin, trsmx0, & + tcrit, & + + ! additional variables required by coupling with WRF model + emis(i), z0m(i), zol(i), rib(i), & + ustar(i), qstar(i), tstar(i), & + fm(i), fh(i), fq(i) ) + + ENDDO + ENDIF + + +#if (defined BGC) + IF(patchtype(i) .eq. 0)THEN + ! + ! ***** Call CoLM BGC model ***** + ! + CALL bgc_driver (i,idate(1:3),deltim, patchlatr(i)*180/PI,patchlonr(i)*180/PI) + ENDIF +#endif + + +#ifdef URBAN_MODEL + ! For urban model and urban patches + IF (DEF_URBAN_RUN .and. m.eq.URBAN) THEN + + u = patch2urban(i) + ! + ! ***** Call CoLM urban model ***** + ! + CALL CoLMMAIN_Urban ( & + ! MODEL RUNNING PARAMETERS + i ,idate ,coszen(i) ,deltim ,& + patchlonr(i) ,patchlatr(i) ,patchclass(i) ,patchtype(i) ,& + + ! URBAN PARAMETERS + froof(u) ,flake(u) ,hroof(u) ,hlr(u) ,& + fgper(u) ,em_roof(u) ,em_wall(u) ,em_gimp(u) ,& + em_gper(u) ,cv_roof(:,u) ,cv_wall(:,u) ,cv_gimp(:,u) ,& + tk_roof(:,u) ,tk_wall(:,u) ,tk_gimp(:,u) ,z_roof(:,u) ,& + z_wall(:,u) ,dz_roof(:,u) ,dz_wall(:,u) ,lakedepth(i) ,& + dz_lake(1:,i) ,elvstd(i) ,BVIC(i) ,& + + ! LUCY INPUT PARAMETERS + fix_holiday(:,u),week_holiday(:,u),hum_prof(:,u) ,pop_den(u) ,& + vehicle(:,u) ,weh_prof(:,u) ,wdh_prof(:,u) ,& + + ! SOIL INFORMATION AND LAKE DEPTH + vf_quartz(1:,i) ,vf_gravels(1:,i),vf_om(1:,i) ,vf_sand(1:,i) ,& + wf_gravels(1:,i),wf_sand(1:,i) ,porsl(1:,i) ,psi0(1:,i) ,& + bsw(1:,i) ,theta_r(1:,i) ,fsatmax(i) ,fsatdcf(i) ,& +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm(1:,i) ,n_vgm(1:,i) ,L_vgm(1:,i) ,& + sc_vgm(1:,i) ,fc_vgm(1:,i) ,& +#endif + hksati(1:,i) ,csol(1:,i) ,k_solids(1:,i) ,dksatu(1:,i) ,& + dksatf(1:,i) ,dkdry(1:,i) ,BA_alpha(1:,i) ,BA_beta(1:,i) ,& + alb_roof(:,:,u) ,alb_wall(:,:,u) ,alb_gimp(:,:,u) ,alb_gper(:,:,u) ,& + + ! VEGETATION INFORMATION + htop(i) ,hbot(i) ,sqrtdi(m) ,chil(m) ,& + effcon(m) ,vmax25(m) ,c3c4(m) ,slti(m) ,hlti(m) ,& + shti(m) ,hhti(m) ,trda(m) ,trdm(m) ,& + trop(m) ,g1(m) ,g0(m) ,gradm(m) ,& + binter(m) ,extkn(m) ,rho(1:,1:,m) ,tau(1:,1:,m) ,& + rootfr(1:,m) ,& + ! WUE model parameter + lambda(m) ,& + ! END WUE model parameter + + ! ATMOSPHERIC FORCING + forc_pco2m(i) ,forc_po2m(i) ,forc_us(i) ,forc_vs(i) ,& + forc_t(i) ,forc_q(i) ,forc_prc(i) ,forc_prl(i) ,& + forc_rain(i) ,forc_snow(i) ,forc_psrf(i) ,forc_pbot(i) ,& + forc_sols(i) ,forc_soll(i) ,forc_solsd(i) ,forc_solld(i) ,& + forc_frl(i) ,forc_hgt_u(i) ,forc_hgt_t(i) ,forc_hgt_q(i) ,& + forc_rhoair(i) ,Fhac(u) ,Fwst(u) ,Fach(u) ,& + Fahe(u) ,Fhah(u) ,vehc(u) ,meta(u) ,& + + ! LAND SURFACE VARIABLES REQUIRED FOR RESTART + z_sno_roof (maxsnl+1:,u) ,z_sno_gimp (maxsnl+1:,u) ,& + z_sno_gper (maxsnl+1:,u) ,z_sno_lake (maxsnl+1:,u) ,& + dz_sno_roof (maxsnl+1:,u) ,dz_sno_gimp (maxsnl+1:,u) ,& + dz_sno_gper (maxsnl+1:,u) ,dz_sno_lake (maxsnl+1:,u) ,& + t_roofsno (maxsnl+1:,u) ,t_gimpsno (maxsnl+1:,u) ,& + t_gpersno (maxsnl+1:,u) ,t_lakesno (maxsnl+1:,u) ,& + wliq_roofsno(maxsnl+1:,u) ,wliq_gimpsno(maxsnl+1:,u) ,& + wliq_gpersno(maxsnl+1:,u) ,wliq_lakesno(maxsnl+1:,u) ,& + wice_roofsno(maxsnl+1:,u) ,wice_gimpsno(maxsnl+1:,u) ,& + wice_gpersno(maxsnl+1:,u) ,wice_lakesno(maxsnl+1:,u) ,& + z_sno (maxsnl+1:,i) ,dz_sno (maxsnl+1:,i) ,& + wliq_soisno (maxsnl+1:,i) ,wice_soisno (maxsnl+1:,i) ,& + t_soisno (maxsnl+1:,i) ,& + smp (1:,i) ,hk (1:,i) ,& + t_wallsun (1:,u) ,t_wallsha (1:,u) ,& + + lai(i) ,sai(i) ,fveg(i) ,sigf(i) ,& + green(i) ,tleaf(i) ,ldew(i) ,ldew_rain(i) ,& + ldew_snow(i) ,fwet_snow(i) ,t_grnd(i) ,& + + sag_roof(u) ,sag_gimp(u) ,sag_gper(u) ,sag_lake(u) ,& + scv_roof(u) ,scv_gimp(u) ,scv_gper(u) ,scv_lake(u) ,& + snowdp_roof(u) ,snowdp_gimp(u) ,snowdp_gper(u) ,snowdp_lake(u) ,& + fsno_roof(u) ,fsno_gimp(u) ,fsno_gper(u) ,fsno_lake(u) ,& + sag(i) ,scv(i) ,snowdp(i) ,fsno(i) ,& + extkd(i) ,alb(1:,1:,i) ,ssun(1:,1:,i) ,ssha(1:,1:,i) ,& + sroof(1:,1:,u) ,swsun(1:,1:,u) ,swsha(1:,1:,u) ,sgimp(1:,1:,u) ,& + sgper(1:,1:,u) ,slake(1:,1:,u) ,lwsun(u) ,lwsha(u) ,& + lgimp(u) ,lgper(u) ,lveg(u) ,fwsun(u) ,& + dfwsun(u) ,t_room(u) ,troof_inner(u) ,twsun_inner(u) ,& + twsha_inner(u) ,t_roommax(u) ,t_roommin(u) ,tafu(u) ,& + + zwt(i) ,wdsrf(i) ,wa(i) ,& + t_lake(1:,i) ,lake_icefrac(1:,i), savedtke1(i) ,& + + ! SNICAR snow model related + snw_rds(:,i) ,ssno_lyr(:,:,:,i) ,& + mss_bcpho(:,i) ,mss_bcphi(:,i) ,mss_ocpho(:,i) ,mss_ocphi(:,i) ,& + mss_dst1(:,i) ,mss_dst2(:,i) ,mss_dst3(:,i) ,mss_dst4(:,i) ,& + + ! additional diagnostic variables for output + laisun(i) ,laisha(i) ,rss(i) ,& + rstfacsun_out(i),h2osoi(1:,i) ,wat(i) ,& + + ! FLUXES + taux(i) ,tauy(i) ,fsena(i) ,fevpa(i) ,& + lfevpa(i) ,fsenl(i) ,fevpl(i) ,etr(i) ,& + fseng(i) ,fevpg(i) ,olrg(i) ,fgrnd(i) ,& + fsen_roof(u) ,fsen_wsun(u) ,fsen_wsha(u) ,fsen_gimp(u) ,& + fsen_gper(u) ,fsen_urbl(u) ,t_roof(u) ,t_wall(u) ,& + lfevp_roof(u) ,lfevp_gimp(u) ,lfevp_gper(u) ,lfevp_urbl(u) ,& + trad(i) ,tref(i) ,& + qref(i) ,rsur(i) ,rnof(i) ,qintr(i) ,& + qinfl(i) ,qdrip(i) ,rst(i) ,assim(i) ,& + respc(i) ,sabvsun(i) ,sabvsha(i) ,sabg(i) ,& + sr(i) ,solvd(i) ,solvi(i) ,solnd(i) ,& + solni(i) ,srvd(i) ,srvi(i) ,srnd(i) ,& + srni(i) ,solvdln(i) ,solviln(i) ,solndln(i) ,& + solniln(i) ,srvdln(i) ,srviln(i) ,srndln(i) ,& + srniln(i) ,qcharge(i) ,xerr(i) ,zerr(i) ,& + + ! TUNABLE model constants + zlnd ,zsno ,csoilc ,dewmx ,& + ! 'wtfact' is updated to gridded 'fsatmax' data. + capr ,cnfac ,ssi ,wimp ,& + pondmx ,smpmax ,smpmin ,trsmx0 ,& + tcrit ,& + + ! additional variables required by coupling with WRF model + emis(i) ,z0m(i) ,zol(i) ,rib(i) ,& + ustar(i) ,qstar(i) ,tstar(i) ,fm(i) ,& + fh(i) ,fq(i) ,forc_hpbl(i) ) + rsub(i) = rnof(i) - rsur(i) + ENDIF + +#endif + ENDDO +!$OMP END PARALLEL DO + +END SUBROUTINE CoLMDRIVER +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 b/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 new file mode 100644 index 0000000000..ba24a6f47f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/CoLMMAIN.F90 @@ -0,0 +1,1652 @@ +#include + +SUBROUTINE CoLMMAIN ( & + + ! model running information + ipatch, idate, coszen, deltim, & + patchlonr, patchlatr, patchclass, patchtype, & + doalb, dolai, dosst, oro, & + + ! soil information and lake depth + soil_s_v_alb, soil_d_v_alb, soil_s_n_alb, soil_d_n_alb, & + vf_quartz, vf_gravels, vf_om, vf_sand, & + wf_gravels, wf_sand, porsl, psi0, & + bsw, theta_r, fsatmax, fsatdcf, & + topoweti, alp_twi, chi_twi, mu_twi, & +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm, n_vgm, L_vgm, & + sc_vgm, fc_vgm, & +#endif + hksati, csol, k_solids, dksatu, & + dksatf, dkdry, BA_alpha, BA_beta, & + rootfr, lakedepth, dz_lake, elvstd, BVIC,& + + ! vegetation information + htop, hbot, sqrtdi, & + effcon, vmax25, c3c4, & + kmax_sun, kmax_sha, kmax_xyl, kmax_root, & + psi50_sun, psi50_sha, psi50_xyl, psi50_root, & + ck, slti, hlti, shti, & + hhti, trda, trdm, trop, & + g1, g0, gradm, binter, & + extkn, chil, rho, tau, & +#ifdef HYPERSPECTRAL + ! variables for hyperspectral scheme + clr_frac, cld_frac, & + reflectance, transmittance, & + soil_alb, kw, nw, & +#endif + + ! atmospheric forcing + forc_pco2m, forc_po2m, forc_us, forc_vs, & + forc_t, forc_q, forc_prc, forc_prl, & + forc_rain, forc_snow, forc_psrf, forc_pbot, & + forc_sols, forc_soll, forc_solsd, forc_solld, & + forc_frl, forc_hgt_u, forc_hgt_t, forc_hgt_q, & + forc_rhoair, & +#ifdef HYPERSPECTRAL + forc_solarin, & +#endif + + ! cbl forcing + forc_hpbl, & + ! aerosol deposition + forc_aerdep, & + + ! land surface variables required for restart + z_sno, dz_sno, t_soisno, wliq_soisno, & + wice_soisno, smp, hk, t_grnd, & + tleaf, ldew, ldew_rain, ldew_snow, & + fwet_snow, sag, scv, snowdp, & + fveg, fsno, sigf, green, & + lai, sai, alb, ssun, & + ssha, ssoi, ssno, thermk, & + extkb, extkd, vegwp, gs0sun, & + gs0sha, & +#ifdef HYPERSPECTRAL + alb_hires, & + sol_dir_ln_hires, sol_dif_ln_hires ,& + sr_dir_ln_hires , sr_dif_ln_hires ,& + reflectance_out , transmittance_out,& +#endif + !Ozone stress variables + o3coefv_sun, o3coefv_sha, o3coefg_sun, o3coefg_sha, & + lai_old, o3uptakesun, o3uptakesha, forc_ozone, & + !End ozone stress variables + !WUE stomata model parameter + lambda, & + !End WUE stomata model parameter + zwt, wdsrf, wa, wetwat, & + t_lake, lake_icefrac, savedtke1, & + + ! SNICAR snow model related + snw_rds, ssno_lyr, & + mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi, & + mss_dst1, mss_dst2, mss_dst3, mss_dst4, & + + ! additional diagnostic variables for output + laisun, laisha, rootr, rootflux, & + rstfacsun_out,rstfacsha_out,gssun_out, gssha_out, & + assimsun_out, etrsun_out, assimsha_out, etrsha_out, & + h2osoi, wat, rss, & + + ! FLUXES + taux, tauy, fsena, fevpa, & + lfevpa, fsenl, fevpl, etr, & + fseng, fevpg, olrg, fgrnd, & + trad, tref, qref, t2m_wmo, & + frcsat, rsur, rsur_se, rsur_ie, & + rsub, & + rnof, qintr, qinfl, qlayer, & + lake_deficit, qdrip, rst, assim, & + respc, sabvsun, sabvsha, sabg, & + sr, solvd, solvi, solnd, & + solni, srvd, srvi, srnd, & + srni, solvdln, solviln, solndln, & + solniln, srvdln, srviln, srndln, & + srniln, qcharge, xerr, zerr, & + + ! TUNABLE model constants + zlnd, zsno, csoilc, dewmx, & + ! 'wtfact' is updated to gridded 'fsatmax' data. + capr, cnfac, ssi, wimp, & + pondmx, smpmax, smpmin, trsmx0, & + tcrit, & + + ! additional variables required by coupling with WRF model + emis, z0m, zol, rib, & + ustar, qstar, tstar, fm, & + fh, fq ) + +!======================================================================= +! +! Main subroutine, advance time information +! +! Initial : Yongjiu Dai, 1999-2014 +! Revised : Hua Yuan, Shupeng Zhang, Nan Wei, Xingjie Lu, Zhongwang Wei, Yongjiu Dai +! 2014-2024 +! +! FLOW DIAGRAM FOR CoLMMAIN +! +! CoLMMAIN ===>netsolar |> all surface +! rain_snow_temp !> all surface +! +! LEAF_interception |] +! newsnow |] patchtype = 0 (soil ground) +! THERMAL |] = 1 (urban & built-up) +! WATER |] = 2 (wetland) +! snowcompaction |] = 3 (land ice) +! snowlayerscombine |] = 4 (lake) +! snowlayersdivide |] +! +! GLACIER_TEMP |] glacier model +! GLACIER_WATER |] +! +! newsnow_lake |] +! laketem |] lake scheme +! snowwater_lake |] +! +! SOCEAN |> ocean and sea ice +! +! orb_coszen |> all surface +! EcoModel (LAI_empirical) |> land - not actived +! snowfraction |> land +! albland |> land +! albocean |> ocean & sea ice +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz, denh2o, denice, cpliq, cpice + USE MOD_Vars_TimeVariables, only: tlai, tsai, waterstorage +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif + USE MOD_RainSnowTemp +#ifdef HYPERSPECTRAL + USE MOD_NetSolar_Hyper +#else + USE MOD_NetSolar +#endif + USE MOD_OrbCoszen + USE MOD_NewSnow + USE MOD_Thermal + USE MOD_SoilSnowHydrology + USE MOD_SnowFraction + USE MOD_SnowLayersCombineDivide + USE MOD_Glacier + USE MOD_Lake + USE MOD_SimpleOcean +#ifdef HYPERSPECTRAL + USE MOD_Albedo_hires + USE MOD_HighRes_Parameters, only: get_loc_params +#else + USE MOD_Albedo +#endif + USE MOD_LAIEmpirical + USE MOD_TimeManager + USE MOD_Namelist, only: DEF_Interception_scheme, DEF_USE_VariablySaturatedFlow, & + DEF_USE_PLANTHYDRAULICS, DEF_USE_IRRIGATION + USE MOD_LeafInterception +#ifdef CROP + USE MOD_Irrigation, only: CalIrrigationApplicationFluxes +#endif + USE MOD_MPAS_MPI + +#ifdef EXTERNAL_LAKE + USE MOD_Lake_Driver, only: external_lake +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: deltim !seconds in a time step [second] + logical, intent(in) :: doalb !true if time for surface albedo calculation + logical, intent(in) :: dolai !true if time for leaf area index calculation + logical, intent(in) :: dosst !true to update sst/ice/snow before calculation + + integer, intent(in) :: & + ipatch ! patch index + + real(r8), intent(in) :: & + patchlonr ,&! longitude in radians + patchlatr ! latitude in radians + + integer, intent(in) :: & + patchclass ,&! land patch class of USGS classification or others + patchtype ! land patch type (0=soil, 1=urban and built-up, + ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + + real(r8), intent(in) :: lakedepth ! lake depth (m) + real(r8), intent(inout) :: dz_lake(nl_lake) ! lake layer thickness (m) + + real(r8), intent(in) :: & + elvstd ,&! standard deviation of elevation (m) + BVIC ,&! vic model parameter b + + ! soil physical parameters and lake info + soil_s_v_alb ,&! albedo of visible of the saturated soil + soil_d_v_alb ,&! albedo of visible of the dry soil + soil_s_n_alb ,&! albedo of near infrared of the saturated soil + soil_d_n_alb ,&! albedo of near infrared of the dry soil + + vf_quartz (nl_soil) ,&! volumetric fraction of quartz within mineral soil + vf_gravels (nl_soil) ,&! volumetric fraction of gravels + vf_om (nl_soil) ,&! volumetric fraction of organic matter + vf_sand (nl_soil) ,&! volumetric fraction of sand + wf_gravels (nl_soil) ,&! gravimetric fraction of gravels + wf_sand (nl_soil) ,&! gravimetric fraction of sand + porsl (nl_soil) ,&! fraction of soil that is voids [-] + psi0 (nl_soil) ,&! minimum soil suction [mm] + bsw (nl_soil) ,&! clapp and hornberger "b" parameter [-] + theta_r (1:nl_soil) ,&! residual water content (cm3/cm3) + fsatmax ,&! maximum saturated area fraction [-] + fsatdcf ,&! decay factor in calculation of saturated area fraction [1/m] + topoweti ,&! mean topographic wetness index + alp_twi ,&! alpha in three parameter gamma distribution of twi + chi_twi ,&! chi in three parameter gamma distribution of twi + mu_twi ,&! mu in three parameter gamma distribution of twi +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm(1:nl_soil) ,&! parameter corresponding approximately to inverse of air-entry value + n_vgm (1:nl_soil) ,&! a shape parameter + L_vgm (1:nl_soil) ,&! pore-connectivity parameter + sc_vgm (1:nl_soil) ,&! saturation at air entry value in classical vanGenuchten model [-] + fc_vgm (1:nl_soil) ,&! a scaling factor by using air entry value in the Mualem model [-] +#endif + hksati (nl_soil) ,&! hydraulic conductivity at saturation [mm h2o/s] + csol (nl_soil) ,&! heat capacity of soil solids [J/(m3 K)] + k_solids (nl_soil) ,&! thermal conductivity of minerals soil [W/m-K] + dksatu (nl_soil) ,&! thermal conductivity of saturated unfrozen soil [W/m-K] + dksatf (nl_soil) ,&! thermal conductivity of saturated frozen soil [W/m-K] + dkdry (nl_soil) ,&! thermal conductivity for dry soil [J/(K s m)] + BA_alpha (nl_soil) ,&! alpha in Balland and Arp(2005) thermal conductivity scheme + BA_beta (nl_soil) ,&! beta in Balland and Arp(2005) thermal conductivity scheme + rootfr (nl_soil) ,&! fraction of roots in each soil layer + + ! vegetation static, dynamic, derived parameters + htop ,&! canopy top height [m] + hbot ,&! canopy bottom height [m] + sqrtdi ,&! inverse sqrt of leaf dimension [m**-0.5] + effcon ,&! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) + vmax25 ,&! maximum carboxylation rate at 25 C at canopy top + kmax_sun ,&! Plant Hydraulics Parameters + kmax_sha ,&! Plant Hydraulics Parameters + kmax_xyl ,&! Plant Hydraulics Parameters + kmax_root ,&! Plant Hydraulics Parameters + psi50_sun ,&! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha ,&! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl ,&! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root ,&! water potential at 50% loss of root tissue conductance (mmH2O) + ck ,&! shape-fitting parameter for vulnerability curve (-) + slti ,&! slope of low temperature inhibition function [s3] + hlti ,&! 1/2 point of low temperature inhibition function [s4] + shti ,&! slope of high temperature inhibition function [s1] + hhti ,&! 1/2 point of high temperature inhibition function [s2] + trda ,&! temperature coefficient in gs-a model [s5] + trdm ,&! temperature coefficient in gs-a model [s6] + trop ,&! temperature coefficient in gs-a model + g1 ,&! conductance-photosynthesis slope parameter for medlyn model + g0 ,&! conductance-photosynthesis intercept for medlyn model + gradm ,&! conductance-photosynthesis slope parameter + binter ,&! conductance-photosynthesis intercep + extkn ,&! coefficient of leaf nitrogen allocation + chil ,&! leaf angle distribution factor + rho(2,2) ,&! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ,&! leaf transmittance (iw=iband, il=life and dead) +#ifdef HYPERSPECTRAL + ! hyperspectral scheme parameters + clr_frac ( 211, 90, 5 ),& + cld_frac ( 211, 5 ) ,& + reflectance ( 0:15, 211, 2 ),& + transmittance( 0:15, 211, 2 ),& + soil_alb ( 211 ) ,& + kw ( 211 ) ,& + nw ( 211 ) ,& +#endif + + ! tunable parameters + zlnd ,&! roughness length for soil [m] + zsno ,&! roughness length for snow [m] + csoilc ,&! drag coefficient for soil under canopy [-] + dewmx ,&! maximum dew + ! wtfact ,&! (updated to gridded 'fsatmax') fraction of model area with high water table + capr ,&! tuning factor to turn first layer T into surface T + cnfac ,&! Crank Nicholson factor between 0 and 1 + ssi ,&! irreducible water saturation of snow + wimp ,&! water impermeable if porosity less than wimp + pondmx ,&! ponding depth (mm) + smpmax ,&! wilting point potential in mm + smpmin ,&! restriction for min of soil poten. (mm) + trsmx0 ,&! max transpiration for moist soil+100% veg. [mm/s] + tcrit ! critical temp. to determine rain or snow + + integer , intent(in) :: & + c3c4 ! 1 for C3, 2 for C4 + +#ifdef HYPERSPECTRAL + ! Urban hyperspectral albedo + REAL(r8), ALLOCATABLE :: urban_albedo( :, :, : ) ! (cluster_id, season wavelength) + REAL(r8), ALLOCATABLE :: mean_albedo ( :, : ) ! (season, wavelength) + REAL(r8), ALLOCATABLE :: lat_north ( : ) ! (cluster_id) + REAL(r8), ALLOCATABLE :: lat_south ( : ) ! (cluster_id) + REAL(r8), ALLOCATABLE :: lon_east ( : ) ! (cluster_id) + REAL(r8), ALLOCATABLE :: lon_west ( : ) ! (cluster_id) + +#endif + +! Forcing +!----------------------------------------------------------------------- + real(r8), intent(in) :: & + forc_pco2m ,&! partial pressure of CO2 at observational height [pa] + forc_po2m ,&! partial pressure of O2 at observational height [pa] + forc_us ,&! wind speed in eastward direction [m/s] + forc_vs ,&! wind speed in northward direction [m/s] + forc_t ,&! temperature at agcm reference height [kelvin] + forc_q ,&! specific humidity at agcm reference height [kg/kg] + forc_prc ,&! convective precipitation [mm/s] + forc_prl ,&! large scale precipitation [mm/s] + forc_psrf ,&! atmosphere pressure at the surface [pa] + forc_pbot ,&! atmosphere pressure at the bottom of the atmos. model level [pa] + forc_sols ,&! atm vis direct beam solar rad onto srf [W/m2] + forc_soll ,&! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd ,&! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ,&! atm nir diffuse solar rad onto srf [W/m2] +#ifdef HYPERSPECTRAL + forc_solarin,&! atm solar rad onto srf [W/m2] +#endif + forc_frl ,&! atmospheric infrared (longwave) radiation [W/m2] + forc_hgt_u ,&! observational height of wind [m] + forc_hgt_t ,&! observational height of temperature [m] + forc_hgt_q ,&! observational height of humidity [m] + forc_rhoair ,&! density air [kg/m3] + forc_hpbl ,&! atmospheric boundary layer height [m] + forc_aerdep(14)!atmospheric aerosol deposition data [kg/m/s] + +! Variables required for restart run +!----------------------------------------------------------------------- + integer, intent(in) :: & + idate(3) ! next time-step /year/julian day/second in a day/ + + real(r8), intent(inout) :: oro ! ocean(0)/seaice(2)/ flag + real(r8), intent(inout) :: & + z_sno (maxsnl+1:0) ,&! layer depth (m) + dz_sno (maxsnl+1:0) ,&! layer thickness (m) + t_soisno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + wliq_soisno(maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wice_soisno(maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + hk(1:nl_soil) ,&! hydraulic conductivity [mm h2o/s] + smp(1:nl_soil) ,&! soil matrix potential [mm] + + t_lake(nl_lake) ,&! lake temperature (kelvin) + lake_icefrac(nl_lake) ,&! lake mass fraction of lake layer that is frozen + savedtke1 ,&! top level eddy conductivity (W/m K) + vegwp(nvegwcs) ,&! ground surface temperature [k] + gs0sun ,&! working copy of sunlit stomata conductance + gs0sha ,&! working copy of shalit stomata conductance + !Ozone stress variables + lai_old ,&! lai in last time step + o3uptakesun ,&! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha ,&! Ozone does, shaded leaf (mmol O3/m^2) + forc_ozone ,& + o3coefv_sun ,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha ,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun ,&! Ozone stress factor for stomata on shaded leaf + o3coefg_sha ,&! Ozone stress factor for stomata on shaded leaf + !End ozone stress variables + !WUE stomata model parameter + lambda ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) + !WUE stomata model parameter + t_grnd ,&! ground surface temperature [k] + tleaf ,&! leaf temperature [K] + ldew ,&! depth of water on foliage [kg/m2/s] + ldew_rain ,&! depth of rain on foliage[kg/m2/s] + ldew_snow ,&! depth of snow on foliage[kg/m2/s] + fwet_snow ,&! vegetation canopy snow fractional cover [-] + sag ,&! non dimensional snow age [-] + scv ,&! snow mass (kg/m2) + snowdp ,&! snow depth (m) + zwt ,&! the depth to water table [m] + wdsrf ,&! depth of surface water [mm] + wa ,&! water storage in aquifer [mm] + wetwat ,&! water storage in wetland [mm] + + snw_rds ( maxsnl+1:0 ) ,&! effective grain radius (col,lyr) [microns, m-6] + mss_bcpho ( maxsnl+1:0 ) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi ( maxsnl+1:0 ) ,&! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho ( maxsnl+1:0 ) ,&! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi ( maxsnl+1:0 ) ,&! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 ( maxsnl+1:0 ) ,&! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 ( maxsnl+1:0 ) ,&! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 ( maxsnl+1:0 ) ,&! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 ( maxsnl+1:0 ) ,&! mass of dust species 4 in snow (col,lyr) [kg] + ssno_lyr (2,2,maxsnl+1:1) ,&! snow layer absorption [-] + + fveg ,&! fraction of vegetation cover + fsno ,&! fractional snow cover + sigf ,&! fraction of veg cover, excluding snow-covered veg [-] + green ,&! greenness + lai ,&! leaf area index + sai ,&! stem area index +#ifdef HYPERSPECTRAL + alb_hires(211, 2),& ! hyperspectral albedo +#endif + + coszen ,&! cosine of solar zenith angle + alb(2,2) ,&! averaged albedo [-] + ssun(2,2) ,&! sunlit canopy absorption for solar radiation + ssha(2,2) ,&! shaded canopy absorption for solar radiation + ssoi(2,2) ,&! ground soil absorption [-] + ssno(2,2) ,&! ground snow absorption [-] + thermk ,&! canopy gap fraction for tir radiation + extkb ,&! (k, g(mu)/mu) direct solar extinction coefficient + extkd ! diffuse and scattered diffuse PAR extinction coefficient + + +! additional diagnostic variables for output + real(r8), intent(out) :: & + laisun ,&! sunlit leaf area index + laisha ,&! shaded leaf area index + rstfacsun_out ,&! factor of soil water stress + rstfacsha_out ,&! factor of soil water stress + gssun_out ,&! sunlit stomata conductance + gssha_out ,&! shaded stomata conductance + wat ,&! total water storage + rss ,&! soil surface resistance [s/m] + rootr(nl_soil) ,&! water uptake fraction from different layers, all layers add to 1.0 + rootflux(nl_soil),&! water exchange between soil and root in different layers + ! Positive: soil->root[?] +#ifdef HYPERSPECTRAL + reflectance_out (211, 0:15) ,&! high resolution reflectance + transmittance_out(211, 0:15) ,&! high resolution transmittance +#endif + h2osoi(nl_soil) ,&! volumetric soil water in layers [m3/m3] + qlayer(0:nl_soil),&! water flux at between soil layer [mm h2o/s] + lake_deficit ! lake deficit due to evaporation (mm h2o/s) + + real(r8), intent(out) :: & + assimsun_out,& + etrsun_out ,& + assimsha_out,& + etrsha_out +! Fluxes +!----------------------------------------------------------------------- + real(r8), intent(out) :: & + taux ,&! wind stress: E-W [kg/m/s**2] + tauy ,&! wind stress: N-S [kg/m/s**2] + fsena ,&! sensible heat from canopy height to atmosphere [W/m2] + fevpa ,&! evapotranspiration from canopy height to atmosphere [mm/s] + lfevpa ,&! latent heat flux from canopy height to atmosphere [W/2] + fsenl ,&! sensible heat from leaves [W/m2] + fevpl ,&! evaporation+transpiration from leaves [mm/s] + etr ,&! transpiration rate [mm/s] + fseng ,&! sensible heat flux from ground [W/m2] + fevpg ,&! evaporation heat flux from ground [mm/s] + olrg ,&! outgoing long-wave radiation from ground+canopy + fgrnd ,&! ground heat flux [W/m2] + xerr ,&! water balance error at current time-step [mm/s] + zerr ,&! energy balance error at current time-step [W/m2] + + tref ,&! 2 m height air temperature [K] + qref ,&! 2 m height air specific humidity + t2m_wmo ,&! 2 m wmo std air temperature [K] + trad ,&! radiative temperature [K] + frcsat ,&! fraction of saturation area + rsur ,&! surface runoff (mm h2o/s) + rsur_se ,&! saturation excess surface runoff (mm h2o/s) + rsur_ie ,&! infiltration excess surface runoff (mm h2o/s) + rsub ,&! subsurface runoff (mm h2o/s) + rnof ,&! total runoff (mm h2o/s) + qintr ,&! interception (mm h2o/s) + qinfl ,&! infiltration (mm h2o/s) + qdrip ,&! throughfall (mm h2o/s) + qcharge ,&! groundwater recharge [mm/s] + + rst ,&! canopy stomatal resistance + assim ,&! canopy assimilation + respc ,&! canopy respiration + + sabvsun ,&! solar absorbed by sunlit vegetation [W/m2] + sabvsha ,&! solar absorbed by shaded vegetation [W/m2] + sabg ,&! solar absorbed by ground [W/m2] + sr ,&! total reflected solar radiation (W/m2) + solvd ,&! incident direct beam vis solar radiation (W/m2) + solvi ,&! incident diffuse beam vis solar radiation (W/m2) + solnd ,&! incident direct beam nir solar radiation (W/m2) + solni ,&! incident diffuse beam nir solar radiation (W/m2) + srvd ,&! reflected direct beam vis solar radiation (W/m2) + srvi ,&! reflected diffuse beam vis solar radiation (W/m2) + srnd ,&! reflected direct beam nir solar radiation (W/m2) + srni ,&! reflected diffuse beam nir solar radiation (W/m2) + solvdln ,&! incident direct beam vis solar radiation at local noon(W/m2) + solviln ,&! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln ,&! incident direct beam nir solar radiation at local noon(W/m2) + solniln ,&! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln ,&! reflected direct beam vis solar radiation at local noon(W/m2) + srviln ,&! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln ,&! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ,&! reflected diffuse beam nir solar radiation at local noon(W/m2) +#ifdef HYPERSPECTRAL + sol_dir_ln_hires(211) ,&! incident direct beam vis solar radiation at local noon(W/m2) + sol_dif_ln_hires(211) ,&! incident diffuse beam vis solar radiation at local noon(W/m2) + sr_dir_ln_hires(211) ,&! reflected direct beam nir solar radiation at local noon(W/m2) + sr_dif_ln_hires(211) ,&! reflected diffuse beam nir solar radiation at local noon(W/m2) +#endif + + forc_rain ,&! rain [mm/s] + forc_snow ,&! snow [mm/s] + + emis ,&! averaged bulk surface emissivity + z0m ,&! effective roughness [m] + zol ,&! dimensionless height (z/L) used in Monin-Obukhov theory + rib ,&! bulk Richardson number in surface layer + ustar ,&! u* in similarity theory [m/s] + qstar ,&! q* in similarity theory [kg/kg] + tstar ,&! t* in similarity theory [K] + fm ,&! integral of profile function for momentum + fh ,&! integral of profile function for heat + fq ! integral of profile function for moisture + +!-------------------------- Local Variables ---------------------------- + logical :: is_dry_lake + + real(r8) :: & + calday ,&! Julian cal day (1.xx to 365.xx) + endwb ,&! water mass at the end of time step + errore ,&! energy balance error (Wm-2) + errorw ,&! water balance error (mm) + fiold(maxsnl+1:nl_soil), &! fraction of ice relative to the total water + w_old ,&! liquid water mass of the column at the previous time step (mm) + + sabg_soil ,&! solar absorbed by soil fraction + sabg_snow ,&! solar absorbed by snow fraction + parsun ,&! PAR by sunlit leaves [W/m2] + parsha ,&! PAR by shaded leaves [W/m2] + qseva ,&! ground surface evaporation rate (mm h2o/s) + qsdew ,&! ground surface dew formation (mm h2o /s) [+] + qsubl ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros ,&! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil ,&! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil ,&! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil ,&! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow ,&! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow ,&! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow ,&! surface dew added to snow pack (mm h2o /s) [+] + scvold ,&! snow cover for previous time step [mm] + sm ,&! rate of snowmelt [kg/(m2 s)] + ssw ,&! water volumetric content of soil surface layer [m3/m3] + tssub(7) ,&! surface/sub-surface temperatures [K] + tssea ,&! sea surface temperature [K] + totwb ,&! water mass at the beginning of time step + wt ,&! fraction of vegetation buried (covered) by snow [-] + z_soisno (maxsnl+1:nl_soil), &! layer depth (m) + dz_soisno(maxsnl+1:nl_soil), &! layer thickness (m) + zi_soisno(maxsnl :nl_soil) ! interface level below a "z" level (m) + + real(r8) :: & + prc_rain ,&! convective rainfall [kg/(m2 s)] + prc_snow ,&! convective snowfall [kg/(m2 s)] + prl_rain ,&! large scale rainfall [kg/(m2 s)] + prl_snow ,&! large scale snowfall [kg/(m2 s)] + t_precip ,&! snowfall/rainfall temperature [kelvin] + bifall ,&! bulk density of newly fallen dry snow [kg/m3] + pg_rain ,&! rainfall onto ground including canopy runoff [kg/(m2 s)] + pg_snow ,&! snowfall onto ground including canopy runoff [kg/(m2 s)] + qintr_rain ,&! rainfall interception (mm h2o/s) + qintr_snow ! snowfall interception (mm h2o/s) + +#ifdef HYPERSPECTRAL + real(r8) :: & + dir_frac(211),&! direct beam fraction + dif_frac(211) ! diffuse beam fraction +#endif + + integer snl ,&! number of snow layers + imelt(maxsnl+1:nl_soil), &! flag for: melting=1, freezing=2, Nothing happened=0 + lb ,lbsn ,&! lower bound of arrays + j ! do looping index + + ! For SNICAR snow model + !---------------------------------------------------------------------- + integer snl_bef !number of snow layers + real(r8) forc_aer ( 14 ) !aerosol deposition from atmosphere (grd,aer) [kg m-1 s-1] + real(r8) snofrz (maxsnl+1:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + real(r8) t_soisno_ (maxsnl+1:1) !soil + snow layer temperature [K] + real(r8) dz_soisno_ (maxsnl+1:1) !layer thickness (m) + real(r8) sabg_snow_lyr(maxsnl+1:1) !snow layer absorption [W/m-2] + !---------------------------------------------------------------------- + ! For irrigation + !---------------------------------------------------------------------- + real(r8) :: qflx_irrig_drip ! drip irrigation rate [mm/s] + real(r8) :: qflx_irrig_sprinkler ! sprinkler irrigation rate [mm/s] + real(r8) :: qflx_irrig_flood ! flood irrigation rate [mm/s] + real(r8) :: qflx_irrig_paddy ! paddy irrigation rate [mm/s] + !---------------------------------------------------------------------- + real(r8) :: a, aa, gwat + real(r8) :: wextra, t_rain, t_snow + integer ps, pe, pc + +!----------------------------------------------------------------------- + + z_soisno (maxsnl+1:0) = z_sno (maxsnl+1:0) + z_soisno (1:nl_soil ) = z_soi (1:nl_soil ) + dz_soisno(maxsnl+1:0) = dz_sno(maxsnl+1:0) + dz_soisno(1:nl_soil ) = dz_soi(1:nl_soil ) + + ! SNICAR initialization + ! --------------------- + + ! snow freezing rate (col,lyr) [kg m-2 s-1] + snofrz(:) = 0. + + ! aerosol deposition value + IF (DEF_Aerosol_Readin) THEN + forc_aer(:) = forc_aerdep ! read from outside forcing file + ELSE + forc_aer(:) = 0. ! manual setting + ENDIF + + +!====================================================================== +! [1] Solar absorbed by vegetation and ground +! and precipitation information (rain/snow fall and precip temperature +!====================================================================== +#ifdef HYPERSPECTRAL + CALL get_loc_params(forc_solarin, idate, coszen, patchlatr, patchlonr, clr_frac, cld_frac, dir_frac, dif_frac) + + CALL netsolar_hyper (ipatch,idate,deltim,patchlonr,patchtype,& + forc_sols,forc_soll,forc_solsd,forc_solld,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,fsno,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + sr,solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln,& + ! new variables for hyperspectral scheme + dir_frac, dif_frac, alb_hires ,& + sol_dir_ln_hires,sol_dif_ln_hires,& + sr_dir_ln_hires ,sr_dif_ln_hires ) + +#else + CALL netsolar (ipatch,idate,deltim,patchlonr,patchtype,& + forc_sols,forc_soll,forc_solsd,forc_solld,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,fsno,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + sr,solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) +#endif + + CALL rain_snow_temp (patchtype, & + forc_t,forc_q,forc_psrf,forc_prc,forc_prl,forc_us,forc_vs,tcrit,& + prc_rain,prc_snow,prl_rain,prl_snow,t_precip,bifall) + +#ifdef MPAS_EMBEDDED_COLM + ! MPAS already provides hydrometeor phase; keep it while using CoLM for precipitation temperature. + prc_rain = max(0._r8, min(forc_prc, forc_rain)) + prc_snow = max(0._r8, forc_prc - prc_rain) + prl_rain = max(0._r8, forc_rain - prc_rain) + prl_snow = max(0._r8, forc_snow - prc_snow) +#else + forc_rain = prc_rain + prl_rain + forc_snow = prc_snow + prl_snow +#endif + +!====================================================================== + + is_dry_lake = DEF_USE_Dynamic_Lake .and. (patchtype == 4) .and. & + ((wdsrf < 100.) .or. (zwt > 0.)) + + + ! / SOIL GROUND (patchtype = 0) + IF ((patchtype <= 2) .or. is_dry_lake) THEN ! <=== is - URBAN and BUILT-UP (patchtype = 1) + ! \ WETLAND (patchtype = 2) + ! Dry Lake (patchtype = 4) + +! NOTE: PFT and PC are only for soil patches, i.e., patchtype=0. +!====================================================================== + ! initial set + scvold = scv ! snow mass at previous time step + + snl = 0 + DO j=maxsnl+1,0 + IF(wliq_soisno(j)+wice_soisno(j)>0.) snl=snl-1 + ENDDO + + zi_soisno(0)=0. + IF (snl < 0) THEN + DO j = -1, snl, -1 + zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) + ENDDO + ENDIF + DO j = 1,nl_soil + zi_soisno(j)=zi_soisno(j-1)+dz_soisno(j) + ENDDO + + totwb = ldew + scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + wa +#ifdef CROP + if(DEF_USE_IRRIGATION) totwb = totwb + waterstorage(ipatch) +#endif + totwb = totwb + wdsrf + IF (DEF_USE_VariablySaturatedFlow) THEN + IF (patchtype == 2) THEN + totwb = totwb + wetwat + ENDIF + ENDIF + + fiold(:) = 0.0 + IF (snl <0 ) THEN + fiold(snl+1:0)=wice_soisno(snl+1:0)/(wliq_soisno(snl+1:0)+wice_soisno(snl+1:0)) + ENDIF + +!---------------------------------------------------------------------- +! [2] Irrigation +!---------------------------------------------------------------------- + qflx_irrig_drip = 0._r8 + qflx_irrig_sprinkler = 0._r8 + qflx_irrig_flood = 0._r8 + qflx_irrig_paddy = 0._r8 +#ifdef CROP + IF (DEF_USE_IRRIGATION) THEN + IF (patchtype == 0) THEN + CALL CalIrrigationApplicationFluxes(ipatch,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy) + ENDIF + ENDIF +#endif +!---------------------------------------------------------------------- +! [3] Canopy interception and precipitation onto ground surface +!---------------------------------------------------------------------- + IF (patchtype == 0) THEN + +#if (defined LULC_USGS || defined LULC_IGBP) + CALL LEAF_interception_wrap (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,forc_t,& + tleaf,prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,forc_hgt_u,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,forc_hgt_u,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) +#endif + + ELSE + CALL LEAF_interception_wrap (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,forc_t,& + tleaf,prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,forc_hgt_u,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ENDIF + + qdrip = pg_rain + pg_snow + +!---------------------------------------------------------------------- +! [3] Initialize new snow nodes for snowfall / sleet +!---------------------------------------------------------------------- + + snl_bef = snl + + CALL newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& + t_precip,zi_soisno(:0),z_soisno(:0),dz_soisno(:0),t_soisno(:0),& + wliq_soisno(:0),wice_soisno(:0),fiold(:0),snl,sag,scv,snowdp,fsno,wetwat) + +!---------------------------------------------------------------------- +! [4] Energy and Water balance +!---------------------------------------------------------------------- + lb = snl + 1 !lower bound of array + lbsn = min(lb,0) + + CALL THERMAL (ipatch,patchtype,is_dry_lake,lb ,deltim ,& + trsmx0 ,zlnd ,zsno ,csoilc ,& + dewmx ,capr ,cnfac ,vf_quartz ,& + vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& + wf_sand ,csol ,porsl ,psi0 ,& +#ifdef Campbell_SOIL_MODEL + bsw ,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r ,alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm ,& +#endif + k_solids ,dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,lai ,laisun ,& + laisha ,sai ,htop ,hbot ,& + sqrtdi ,rootfr ,rstfacsun_out ,rstfacsha_out ,& + rss ,gssun_out ,gssha_out ,assimsun_out ,& + etrsun_out ,assimsha_out ,etrsha_out ,& + + effcon ,vmax25,c3c4 ,hksati ,smp ,hk ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& + psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,& + ck ,vegwp ,gs0sun ,gs0sha ,& + !Ozone stress variables + o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha ,& + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& + !End ozone stress variables + !WUE stomata model parameter + lambda ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) + !WUE stomata model parameter + slti ,hlti ,shti ,hhti ,& + trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_rhoair ,& + forc_psrf ,forc_pco2m ,forc_hpbl ,forc_po2m ,& + coszen ,parsun ,parsha ,sabvsun ,& + sabvsha ,sabg ,sabg_soil ,sabg_snow ,& + forc_frl ,extkb ,extkd ,thermk ,& + fsno ,sigf ,dz_soisno(lb:) ,z_soisno(lb:) ,& + zi_soisno(lb-1:) ,tleaf ,t_soisno(lb:) ,wice_soisno(lb:) ,& + wliq_soisno(lb:) ,ldew ,ldew_rain ,ldew_snow ,& + fwet_snow ,scv ,snowdp ,imelt(lb:) ,& + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + rootr ,rootflux ,qseva ,qsdew ,& + qsubl ,qfros ,qseva_soil ,qsdew_soil ,& + qsubl_soil ,qfros_soil ,qseva_snow ,qsdew_snow ,& + qsubl_snow ,qfros_snow ,sm ,tref ,& + qref ,trad ,rst ,assim ,& + respc ,errore ,emis ,z0m ,& + zol ,rib ,ustar ,qstar ,& + tstar ,fm ,fh ,fq ,& + pg_rain ,pg_snow ,t_precip ,qintr_rain ,& + qintr_snow ,snofrz(lbsn:0) ,sabg_snow_lyr(lb:1) ) + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + + CALL WATER_2014 (ipatch,patchtype ,lb ,nl_soil ,& + deltim ,z_soisno(lb:) ,dz_soisno(lb:) ,zi_soisno(lb-1:) ,& + bsw ,porsl ,psi0 ,hksati ,& + theta_r ,fsatmax ,fsatdcf ,elvstd ,& + BVIC ,rootr ,rootflux ,t_soisno(lb:) ,& + wliq_soisno(lb:) ,wice_soisno(lb:) ,smp ,hk ,& + pg_rain ,sm ,etr ,qseva ,& + qsdew ,qsubl ,qfros ,qseva_soil ,& + qsdew_soil ,qsubl_soil ,qfros_soil ,qseva_snow ,& + qsdew_snow ,qsubl_snow ,qfros_snow ,fsno ,& + rsur ,rnof ,qinfl ,pondmx ,& + ssi ,wimp ,smpmin ,zwt ,& + wdsrf ,wa ,qcharge ,& + +! SNICAR model variables + forc_aer ,& + mss_bcpho(lbsn:0) ,mss_bcphi(lbsn:0) ,mss_ocpho(lbsn:0) ,mss_ocphi(lbsn:0) ,& + mss_dst1(lbsn:0) ,mss_dst2(lbsn:0) ,mss_dst3(lbsn:0) ,mss_dst4(lbsn:0) ,& +! irrigation variables + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy) + rsub = rnof - rsur + ELSE + + CALL WATER_VSF (ipatch ,patchtype,is_dry_lake, lb ,nl_soil ,& + deltim ,z_soisno(lb:) ,dz_soisno(lb:) ,zi_soisno(lb-1:) ,& + bsw ,theta_r ,fsatmax ,fsatdcf ,& + topoweti ,alp_twi ,chi_twi ,mu_twi ,& + elvstd ,BVIC ,& +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm ,n_vgm ,L_vgm ,sc_vgm ,& + fc_vgm ,& +#endif + porsl ,psi0 ,hksati ,rootr ,& + rootflux ,t_soisno(lb:) ,wliq_soisno(lb:) ,wice_soisno(lb:) ,& + smp ,hk ,pg_rain ,sm ,& + etr ,qseva ,qsdew ,qsubl ,& + qfros ,qseva_soil ,qsdew_soil ,qsubl_soil ,& + qfros_soil ,qseva_snow ,qsdew_snow ,qsubl_snow ,& + qfros_snow ,fsno ,frcsat ,rsur ,& + rsur_se ,rsur_ie ,rsub ,rnof ,& + qinfl ,& + qlayer ,ssi ,pondmx ,wimp ,& + zwt ,wdsrf ,wa ,wetwat ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho(lbsn:0) ,mss_bcphi(lbsn:0) ,mss_ocpho(lbsn:0) ,mss_ocphi(lbsn:0) ,& + mss_dst1(lbsn:0) ,mss_dst2(lbsn:0) ,mss_dst3(lbsn:0) ,mss_dst4(lbsn:0) ,& +! irrigation variables + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy) + ENDIF + + IF (snl < 0) THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lb = snl + 1 !lower bound of array + CALL snowcompaction (lb,deltim,& + imelt(lb:0),fiold(lb:0),t_soisno(lb:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),forc_us,forc_vs,dz_soisno(lb:0)) + + ! Combine thin snow elements + lb = maxsnl + 1 + + IF (DEF_USE_SNICAR) THEN + CALL snowlayerscombine_snicar (lb,snl,& + z_soisno(lb:1),dz_soisno(lb:1),zi_soisno(lb-1:1),& + wliq_soisno(lb:1),wice_soisno(lb:1),t_soisno(lb:1),scv,snowdp,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ELSE + CALL snowlayerscombine (lb,snl,& + z_soisno(lb:1),dz_soisno(lb:1),zi_soisno(lb-1:1),& + wliq_soisno(lb:1),wice_soisno(lb:1),t_soisno(lb:1),scv,snowdp) + ENDIF + + ! Divide thick snow elements + IF(snl<0) THEN + IF (DEF_USE_SNICAR) THEN + CALL snowlayersdivide_snicar (lb,snl,& + z_soisno(lb:0),dz_soisno(lb:0),zi_soisno(lb-1:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),t_soisno(lb:0),& + mss_bcpho(lb:0),mss_bcphi(lb:0),mss_ocpho(lb:0),mss_ocphi(lb:0),& + mss_dst1(lb:0),mss_dst2(lb:0),mss_dst3(lb:0),mss_dst4(lb:0) ) + ELSE + CALL snowlayersdivide (lb,snl,& + z_soisno(lb:0),dz_soisno(lb:0),zi_soisno(lb-1:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),t_soisno(lb:0)) + ENDIF + ENDIF + ENDIF + + ! Set zero to the empty node + IF (snl > maxsnl) THEN + wice_soisno(maxsnl+1:snl) = 0. + wliq_soisno(maxsnl+1:snl) = 0. + t_soisno (maxsnl+1:snl) = 0. + z_soisno (maxsnl+1:snl) = 0. + dz_soisno (maxsnl+1:snl) = 0. + ENDIF + + lb = snl + 1 + t_grnd = t_soisno(lb) + + IF (is_dry_lake) THEN + dz_lake = wdsrf*1.e-3/nl_lake + t_lake = t_soisno(1) + IF (t_soisno(1) >= tfrz) THEN + lake_icefrac = 0. + ELSE + lake_icefrac = 1. + ENDIF + + IF (wdsrf >= 100.) THEN + CALL adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + ENDIF + ENDIF + + ! ---------------------------------------- + ! energy balance + ! ---------------------------------------- + zerr=errore +#if (defined CoLMDEBUG) + IF (abs(errore) > .5) THEN + write(6,*) 'Warning: energy balance violation ',errore,patchclass + ENDIF +#endif + + ! ---------------------------------------- + ! water balance + ! ---------------------------------------- + endwb=sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv + wa +#ifdef CROP + IF (DEF_USE_IRRIGATION) endwb = endwb + waterstorage(ipatch) +#endif + + endwb = endwb + wdsrf + IF (DEF_USE_VariablySaturatedFlow) THEN + IF (patchtype == 2) THEN + endwb = endwb + wetwat + ENDIF + ENDIF +#ifndef CatchLateralFlow + errorw=(endwb-totwb)-(forc_prc+forc_prl-fevpa-rnof)*deltim +#else + ! for lateral flow, "rsur" is considered in HYDRO/MOD_Hydro_SurfaceFlow.F90 + errorw=(endwb-totwb)-(forc_prc+forc_prl-fevpa)*deltim +#endif + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + IF (patchtype==2) errorw=0. !wetland + ENDIF + + xerr=errorw/deltim + +#if (defined CoLMDEBUG) + IF (abs(errorw) > 1.e-3) THEN + IF (patchtype == 0) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (soil) ', errorw + ELSEIF (patchtype == 1) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (urban) ', errorw + ELSEIF (patchtype == 2) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (wetland) ', errorw + ELSEIF (patchtype == 4) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (dry lake) ', errorw + ENDIF + CALL CoLM_stop () + ENDIF +#endif + +!====================================================================== + + ELSEIF (patchtype == 3) THEN ! <=== is LAND ICE (glacier/ice sheet) (patchtype = 3) + +!====================================================================== + ! initial set + scvold = scv ! snow mass at previous time step + + snl = 0 + DO j=maxsnl+1,0 + IF(wliq_soisno(j)+wice_soisno(j)>0.) snl=snl-1 + ENDDO + + zi_soisno(0)=0. + IF (snl < 0) THEN + DO j = -1, snl, -1 + zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) + ENDDO + ENDIF + DO j = 1,nl_soil + zi_soisno(j)=zi_soisno(j-1)+dz_soisno(j) + ENDDO + + totwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + IF (DEF_USE_VariablySaturatedFlow) THEN + totwb = wdsrf + totwb + ENDIF + + fiold(:) = 0.0 + IF (snl <0 ) THEN + fiold(snl+1:0)=wice_soisno(snl+1:0)/(wliq_soisno(snl+1:0)+wice_soisno(snl+1:0)) + ENDIF + + pg_rain = prc_rain + prl_rain + pg_snow = prc_snow + prl_snow + + t_rain = t_precip + IF (wliq_soisno(1) > dz_soisno(1)*denh2o) THEN + wextra = (wliq_soisno(1) - dz_soisno(1)*denh2o) / deltim + t_rain = (pg_rain*t_precip + wextra*t_soisno(1)) / (pg_rain + wextra) + pg_rain = pg_rain + wextra + wliq_soisno(1) = dz_soisno(1)*denh2o + totwb = totwb - wextra*deltim + ENDIF + + t_snow = t_precip + IF (wice_soisno(1) > dz_soisno(1)*denice) THEN + wextra = (wice_soisno(1) - dz_soisno(1)*denice) / deltim + t_snow = (pg_snow*t_precip + wextra*t_soisno(1)) / (pg_snow + wextra) + pg_snow = pg_snow + wextra + wice_soisno(1) = dz_soisno(1)*denice + totwb = totwb - wextra*deltim + ENDIF + + IF (pg_rain+pg_snow > 0) THEN + t_precip = (pg_rain*cpliq*t_rain + pg_snow*cpice*t_snow)/(pg_rain*cpliq+pg_snow*cpice) + ENDIF + + !---------------------------------------------------------------- + ! Initialize new snow nodes for snowfall / sleet + !---------------------------------------------------------------- + + snl_bef = snl + + CALL newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& + t_precip,zi_soisno(:0),z_soisno(:0),dz_soisno(:0),t_soisno(:0),& + wliq_soisno(:0),wice_soisno(:0),fiold(:0),snl,sag,scv,snowdp,fsno) + + !---------------------------------------------------------------- + ! Energy and Water balance + !---------------------------------------------------------------- + lb = snl + 1 !lower bound of array + lbsn = min(lb,0) + + CALL GLACIER_TEMP (patchtype,lb ,nl_soil ,deltim ,& + zlnd ,zsno ,capr ,cnfac ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_hpbl ,& + forc_rhoair ,forc_psrf ,coszen ,sabg ,& + forc_frl ,fsno ,dz_soisno(lb:) ,& + z_soisno(lb:),zi_soisno(lb-1:) ,& + t_soisno(lb:),wice_soisno(lb:),wliq_soisno(lb:) ,& + scv ,snowdp ,imelt(lb:) ,taux ,& + tauy ,fsena ,fevpa ,lfevpa ,& + fseng ,fevpg ,olrg ,fgrnd ,& + qseva ,qsdew ,qsubl ,qfros ,& + sm ,tref ,qref ,trad ,& + errore ,emis ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,pg_rain ,& + pg_snow ,t_precip ,& + snofrz(lbsn:0), sabg_snow_lyr(lb:1) ) + + + IF (DEF_USE_SNICAR) THEN + CALL GLACIER_WATER_snicar (nl_soil ,maxsnl ,deltim ,& + z_soisno ,dz_soisno ,zi_soisno ,t_soisno ,& + wliq_soisno ,wice_soisno ,pg_rain ,pg_snow ,& + sm ,scv ,snowdp ,imelt ,& + fiold ,snl ,qseva ,qsdew ,& + qsubl ,qfros ,gwat ,ssi ,& + wimp ,forc_us ,forc_vs ,& + ! SNICAR + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) + ELSE + CALL GLACIER_WATER ( nl_soil ,maxsnl ,deltim ,& + z_soisno ,dz_soisno ,zi_soisno ,t_soisno ,& + wliq_soisno ,wice_soisno ,pg_rain ,pg_snow ,& + sm ,scv ,snowdp ,imelt ,& + fiold ,snl ,qseva ,qsdew ,& + qsubl ,qfros ,gwat ,ssi ,& + wimp ,forc_us ,forc_vs ) + ENDIF + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + rsur = max(0.0,gwat) + rsub = 0. + rnof = rsur + ELSE + a = wdsrf + wliq_soisno(1) + gwat * deltim + IF (a > dz_soisno(1)*denh2o) THEN + wliq_soisno(1) = dz_soisno(1)*denh2o + wdsrf = a - wliq_soisno(1) + ELSE + wdsrf = 0. + wliq_soisno(1) = max(a, 1.e-8) + ENDIF +#ifndef CatchLateralFlow + IF (wdsrf > pondmx) THEN + rsur = (wdsrf - pondmx) / deltim + wdsrf = pondmx + ELSE + rsur = 0. + ENDIF + rsub = 0. + rnof = rsur + rsur_se = rsur + rsur_ie = 0. +#endif + ENDIF + + lb = snl + 1 + t_grnd = t_soisno(lb) + + ! ---------------------------------------- + ! energy and water balance check + ! ---------------------------------------- + zerr=errore + + endwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + IF (DEF_USE_VariablySaturatedFlow) THEN + endwb = wdsrf + endwb + ENDIF + +#ifndef CatchLateralFlow + errorw=(endwb-totwb)-(pg_rain+pg_snow-fevpa-rnof)*deltim +#else + errorw=(endwb-totwb)-(pg_rain+pg_snow-fevpa)*deltim +#endif + +#if (defined CoLMDEBUG) + IF (DEF_USE_VariablySaturatedFlow) THEN + IF (abs(errorw) > 1.e-3) THEN + write(6,*) 'Warning: water balance violation in CoLMMAIN (land ice) ', errorw + CALL CoLM_stop () + ENDIF + ENDIF +#endif + + IF (DEF_USE_VariablySaturatedFlow) THEN + xerr=errorw/deltim + ELSE + xerr = 0. + ENDIF + +!====================================================================== + + ELSEIF (patchtype == 4) THEN ! <=== is LAND WATER BODIES + ! (lake, reservoir and river) (patchtype = 4) + +!====================================================================== + + totwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + wa + IF (DEF_USE_Dynamic_Lake) THEN + totwb = totwb + wdsrf + ENDIF + + snl = 0 + DO j = maxsnl+1, 0 + IF (wliq_soisno(j)+wice_soisno(j) > 0.) THEN + snl=snl-1 + ENDIF + ENDDO + + zi_soisno(0) = 0. + IF (snl < 0) THEN + DO j = -1, snl, -1 + zi_soisno(j)=zi_soisno(j+1)-dz_soisno(j+1) + ENDDO + ENDIF + + DO j = 1,nl_soil + zi_soisno(j)=zi_soisno(j-1)+dz_soisno(j) + ENDDO + + scvold = scv !snow mass at previous time step + fiold(:) = 0.0 + IF (snl < 0) THEN + fiold(snl+1:0)=wice_soisno(snl+1:0)/(wliq_soisno(snl+1:0)+wice_soisno(snl+1:0)) + ENDIF + + w_old = sum(wliq_soisno(1:)) + sum(wice_soisno(1:)) + + pg_rain = prc_rain + prl_rain + pg_snow = prc_snow + prl_snow + +#ifndef EXTERNAL_LAKE + CALL newsnow_lake ( DEF_USE_Dynamic_Lake, & + ! "in" arguments + ! --------------- + maxsnl ,nl_lake ,deltim ,dz_lake ,& + pg_rain ,pg_snow ,t_precip ,bifall ,& + + ! "inout" arguments + ! ------------------ + t_lake ,zi_soisno(:0),z_soisno(:0) ,& + dz_soisno(:0),t_soisno(:0) ,wliq_soisno(:0) ,wice_soisno(:0) ,& + fiold(:0) ,snl ,sag ,scv ,& + snowdp ,lake_icefrac ) + + CALL laketem ( & + ! "in" laketem arguments + ! --------------------------- + patchtype ,maxsnl ,nl_soil ,nl_lake ,& + patchlatr ,deltim ,forc_hgt_u ,forc_hgt_t ,& + forc_hgt_q ,forc_us ,forc_vs ,forc_t ,& + forc_q ,forc_rhoair ,forc_psrf ,forc_sols ,& + forc_soll ,forc_solsd ,forc_solld ,sabg ,& + forc_frl ,dz_soisno ,z_soisno ,zi_soisno ,& + dz_lake ,lakedepth ,vf_quartz ,vf_gravels ,& + vf_om ,vf_sand ,wf_gravels ,wf_sand ,& + porsl ,csol ,k_solids ,& + dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,forc_hpbl ,& + + ! "inout" laketem arguments + ! --------------------------- + t_grnd ,scv ,snowdp ,t_soisno ,& + wliq_soisno ,wice_soisno ,imelt ,t_lake ,& + lake_icefrac ,savedtke1 ,& + +! SNICAR model variables + snofrz ,sabg_snow_lyr,& +! END SNICAR model variables + + ! "out" laketem arguments + ! --------------------------- + taux ,tauy ,fsena ,& + fevpa ,lfevpa ,fseng ,fevpg ,& + qseva ,qsubl ,qsdew ,qfros ,& + olrg ,fgrnd ,tref ,qref ,& + trad ,emis ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,sm ) + + CALL snowwater_lake ( DEF_USE_Dynamic_Lake, & + ! "in" snowater_lake arguments + ! --------------------------- + maxsnl ,nl_soil ,nl_lake ,deltim ,& + ssi ,wimp ,porsl ,pg_rain ,& + pg_snow ,dz_lake ,imelt(:0) ,fiold(:0) ,& + qseva ,qsubl ,qsdew ,qfros ,& + + ! "inout" snowater_lake arguments + ! --------------------------- + z_soisno ,dz_soisno ,zi_soisno ,t_soisno ,& + wice_soisno ,wliq_soisno ,t_lake ,lake_icefrac ,& + gwat ,& + fseng ,fgrnd ,snl ,scv ,& + snowdp ,sm ,forc_us ,forc_vs ,& + + ! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) + +#else + CALL external_lake( & + ! "in" arguments + ! ------------------- + deltim ,patchlatr ,patchlonr ,bifall ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_rhoair ,& + forc_psrf ,forc_frl ,sabg ,forc_hpbl ,& + forc_sols ,forc_soll ,forc_solsd ,forc_solld ,& + prc_rain ,prl_rain ,prc_snow ,prl_snow ,& + t_precip ,ipatch ,& + ! "inout" arguments + ! ------------------- + t_grnd ,t_lake ,t_soisno ,snl ,& + z_soisno ,zi_soisno ,dz_soisno ,scv ,& + savedtke1 ,sag ,snowdp ,lake_icefrac ,& + wliq_soisno ,wice_soisno ,gwat ,& +! SNICAR model variables + forc_aer ,sabg_snow_lyr ,snofrz ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! END SNICAR model variables + ! "out" arguments + ! ------------------- + fsena ,fevpa ,lfevpa ,fseng ,& + fevpg ,olrg ,fgrnd ,trad ,& + qseva ,qsubl ,qsdew ,qfros ,& + taux ,tauy ,ustar ,qstar ,& + tstar ,emis ,sm ,zol ,& + tref ,qref ,fm ,fq ,& + rib ,fh ,z0m ) +#endif + + IF (.not. DEF_USE_Dynamic_Lake) THEN + ! We assume the land water bodies have zero extra liquid water capacity + ! (i.e.,constant capacity), all excess liquid water are put into the runoff, + ! this unreasonable assumption should be updated in the future version + a = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+scv-w_old-scvold)/deltim + aa = qseva+qsubl-qsdew-qfros + rsur = max(0., pg_rain + pg_snow - aa - a) + rsub = 0. + rnof = rsur + rsur_se = rsur + rsur_ie = 0. + lake_deficit = - min(0., pg_rain + pg_snow - aa - a) + ELSE + + wdsrf = sum(dz_lake) * 1.e3 + +#ifndef CatchLateralFlow + IF (wdsrf > lakedepth*1.e3) THEN + rsur = (wdsrf - lakedepth*1.e3) / deltim + wdsrf = lakedepth*1.e3 + dz_lake = dz_lake * lakedepth/sum(dz_lake) + CALL adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + ELSE + rsur = 0. + ENDIF + rsub = 0. + rnof = rsur + rsur_se = rsur + rsur_ie = 0. +#endif + ENDIF + + endwb = scv + sum(wice_soisno(1:)+wliq_soisno(1:)) + wa + IF (DEF_USE_Dynamic_Lake) THEN + endwb = endwb + wdsrf + ELSE + endwb = endwb - lake_deficit * deltim + ENDIF + + errorw = (endwb-totwb) - (forc_prc+forc_prl-fevpa) * deltim +#ifndef CatchLateralFlow + errorw = errorw + rnof * deltim +#endif + +#if (defined CoLMDEBUG) + IF (abs(errorw) > 1.e-3) THEN + write(*,*) 'Warning: water balance violation in CoLMMAIN (lake) ', errorw + CALL CoLM_stop () + ENDIF +#endif + + IF (DEF_USE_Dynamic_Lake) THEN + xerr = errorw / deltim + ELSE + xerr = 0. + ENDIF + + ! Set zero to the empty node + IF (snl > maxsnl) THEN + wice_soisno(maxsnl+1:snl) = 0. + wliq_soisno(maxsnl+1:snl) = 0. + t_soisno (maxsnl+1:snl) = 0. + z_soisno (maxsnl+1:snl) = 0. + dz_soisno (maxsnl+1:snl) = 0. + ENDIF + +!====================================================================== + + ELSE ! <=== is OCEAN (patchtype >= 99) + +!====================================================================== +! simple ocean-sea ice model + + tssea = t_grnd + tssub (1:7) = t_soisno (1:7) + CALL SOCEAN (dosst,deltim,oro,forc_hgt_u,forc_hgt_t,forc_hgt_q,& + forc_us,forc_vs,forc_t,forc_t,forc_rhoair,forc_psrf,& + sabg,forc_frl,tssea,tssub(1:7),scv,& + taux,tauy,fsena,fevpa,lfevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,emis,olrg) + + ! null data for sea component + z_soisno (:) = 0.0 + dz_soisno (maxsnl+1:0) = 0. + t_soisno (:) = 0.0 + t_soisno (1:7) = tssub(1:7) + wliq_soisno(:) = 0.0 + wice_soisno(:) = 0.0 + t_grnd = tssea + snowdp = scv/1000.*20. + + trad = tssea + fgrnd = 0.0 + rsur = 0.0 + rsur_se = 0.0 + rsur_ie = 0.0 + rsub = 0.0 + rnof = 0.0 + xerr = 0.0 + +!====================================================================== + ENDIF + +!====================================================================== +! Preparation for the next time step +! 1) time-varying parameters for vegetation +! 2) fraction of snow cover +! 3) solar zenith angle and +! 4) albedos +!====================================================================== + + ! cosine of solar zenith angle + calday = calendarday(idate) + coszen = orb_coszen(calday,patchlonr,patchlatr) + + IF (patchtype <= 5) THEN !LAND +#if (defined DYN_PHENOLOGY) + ! need to update lai and sai, fveg, green, they are done once in a day only + IF (dolai) THEN + CALL LAI_empirical(patchclass,nl_soil,rootfr,t_soisno(1:),lai,sai,fveg,green) + ENDIF +#endif + +! only for soil patches +!NOTE: lai from remote sensing has already considered snow coverage + +!NOTE: IF account for snow on vegetation: +! 1) should use snow-free LAI data and 2) update LAI and SAI according to snowdp + + IF (patchtype == 0) THEN + +#if (defined LULC_USGS || defined LULC_IGBP) + CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + + !NOTE: use snow-free LAI by defining namelist DEF_VEG_SNOW + IF ( DEF_VEG_SNOW ) THEN + lai = tlai(ipatch) * sigf + ENDIF +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + CALL snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) + IF(DEF_USE_LAIFEEDBACK)THEN + lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) + ELSE + lai_p(ps:pe) = tlai_p(ps:pe) + lai = tlai(ipatch) + + !NOTE: use snow-free LAI by defining namelist DEF_VEG_SNOW + IF ( DEF_VEG_SNOW ) THEN + lai_p(ps:pe) = tlai_p(ps:pe)*sigf_p(ps:pe) + lai = sum(lai_p(ps:pe)*pftfrac(ps:pe)) + ENDIF + ENDIF + sai_p(ps:pe) = tsai_p(ps:pe) * sigf_p(ps:pe) + sai = sum(sai_p(ps:pe)*pftfrac(ps:pe)) +#endif + + ELSE + CALL snowfraction (tlai(ipatch),tsai(ipatch),z0m,zlnd,scv,snowdp,wt,sigf,fsno) + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + + !NOTE: use snow-free LAI by defining namelist DEF_VEG_SNOW + IF ( DEF_VEG_SNOW ) THEN + lai = tlai(ipatch) * sigf + ENDIF + ENDIF + + ! water volumetric content of soil surface layer [m3/m3] + ssw = min(1.,1.e-3*wliq_soisno(1)/dz_soisno(1)) + IF (patchtype >= 3) ssw = 1.0 + +! ============================================================================ +! Snow aging routine based on Flanner and Zender (2006), Linking snowpack +! microphysics and albedo evolution, JGR, and Brun (1989), Investigation of +! wet-snow metamorphism in respect of liquid-water content, Ann. Glacial. + + dz_soisno_(:1) = dz_soisno(:1) + t_soisno_ (:1) = t_soisno (:1) + + IF ((patchtype == 4) .and. (.not. is_dry_lake)) THEN + dz_soisno_(1) = dz_lake(1) + t_soisno_ (1) = t_lake (1) + ENDIF + +! ============================================================================ + ! albedos + ! we supposed CALL it every time-step, because + ! other vegetation related parameters are needed to create + IF (doalb) THEN +#ifdef HYPERSPECTRAL + CALL albland_HiRes (ipatch, patchtype,deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno_,dz_soisno_,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd,& + + ! new parameters for hyperspectral scheme + alb_hires ,& + dir_frac , dif_frac ,& + reflectance , transmittance ,& + soil_alb, kw, nw, porsl(1) ,& + reflectance_out, transmittance_out,& + idate(2), patchlatr, patchlonr ,& + urban_albedo, mean_albedo, lat_north, lat_south, lon_west, lon_east ) + +#else + CALL albland (ipatch,patchtype,deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno_,dz_soisno_,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) +#endif + ENDIF + + ELSE !OCEAN + sag = 0.0 + IF(doalb)THEN + CALL albocean (oro,scv,coszen,alb) + ENDIF + ENDIF + + ! zero-filling set for glacier/ice-sheet/land water bodies/ocean components + IF ((patchtype > 2) .and. (.not. is_dry_lake)) THEN + lai = 0.0 + sai = 0.0 + laisun = 0.0 + laisha = 0.0 + green = 0.0 + fveg = 0.0 + sigf = 0.0 + + ssun(:,:) = 0.0 + ssha(:,:) = 0.0 + thermk = 0.0 + extkb = 0.0 + extkd = 0.0 + + tleaf = forc_t + ldew_rain = 0.0 + ldew_snow = 0.0 + fwet_snow = 0.0 + ldew = 0.0 + fsenl = 0.0 + fevpl = 0.0 + etr = 0.0 + assim = 0.0 + respc = 0.0 + + zerr = 0. + + qinfl = 0. + qlayer = 0. + qdrip = forc_rain + forc_snow + qintr = 0. + frcsat = 1. + h2osoi = 0. + rstfacsun_out = 0. + rstfacsha_out = 0. + gssun_out = 0. + gssha_out = 0. + assimsun_out = 0. + etrsun_out = 0. + assimsha_out = 0. + etrsha_out = 0. + rootr = 0. + rootflux = 0. + zwt = 0. + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + wa = 4800. + ENDIF + + qcharge = 0. + IF (DEF_USE_PLANTHYDRAULICS)THEN + vegwp = -2.5e4 + ENDIF + ENDIF + + h2osoi = wliq_soisno(1:)/(dz_soisno(1:)*denh2o) + wice_soisno(1:)/(dz_soisno(1:)*denice) + + IF (DEF_USE_VariablySaturatedFlow) THEN + wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv+wetwat + ELSE + wat = sum(wice_soisno(1:)+wliq_soisno(1:))+ldew+scv + wa + ENDIF + + z_sno (maxsnl+1:0) = z_soisno (maxsnl+1:0) + dz_sno(maxsnl+1:0) = dz_soisno(maxsnl+1:0) + +END SUBROUTINE CoLMMAIN +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 new file mode 100644 index 0000000000..35bf99ce06 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90 @@ -0,0 +1,378 @@ +#include + +#ifdef GridRiverLakeFlow +MODULE MOD_Grid_Reservoir +!----------------------------------------------------------------------- +! DESCRIPTION: +! +! Reservoir module in gridded mesh. +! +! Created by Shupeng Zhang, Oct 2025 +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_DataType + + integer :: totalnumresv = 0 + integer :: numresv = 0 + integer, allocatable :: ucat2resv (:) + integer, allocatable :: resv_global_index(:) + type(pointer_int32_1d), allocatable :: resv_data_address (:) + + + ! parameters + integer, allocatable :: dam_GRAND_ID (:) ! GRAND dam ID + + integer, allocatable :: dam_build_year(:) ! year in which the dam/barrier was built + + real(r8), allocatable :: volresv_total (:) ! total reservoir volume [m^3] + real(r8), allocatable :: volresv_emerg (:) ! emergency reservoir volume [m^3] + real(r8), allocatable :: volresv_adjust(:) ! adjustment reservoir volume [m^3] + real(r8), allocatable :: volresv_normal(:) ! normal reservoir volume [m^3] + + real(r8), allocatable :: qresv_flood (:) ! flood reservoir outflow [m^3/s] + real(r8), allocatable :: qresv_adjust (:) ! adjustment reservoir outflow [m^3/s] + real(r8), allocatable :: qresv_normal (:) ! normal reservoir outflow [m^3/s] + + ! fluxes + real(r8), allocatable :: qresv_in (:) ! reservoir inflow [m^3/s] + real(r8), allocatable :: qresv_out (:) ! reservoir outflow [m^3/s] + + ! -- PUBLIC SUBROUTINEs -- + PUBLIC :: reservoir_init + PUBLIC :: reservoir_operation + PUBLIC :: reservoir_final + +CONTAINS + + ! ------- + SUBROUTINE reservoir_init ( ) + + USE MOD_MPAS_MPI + USE MOD_NetCDFSerial + USE MOD_Utils + USE MOD_Namelist, only: DEF_ReservoirPara_file + USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_ucid, lake_type + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + + IMPLICIT NONE + + ! Local variables + character(len=256) :: parafile + + integer, allocatable :: dam_seq(:), order(:), local_ucid(:) + real(r8), allocatable :: rcache (:) + integer, allocatable :: icache (:) + + integer, parameter :: dam_seq_chunk_size = 1048576 + integer :: i, iloc, irsv +#ifndef MPAS_EMBEDDED_COLM + integer :: nresv, irank +#endif + integer :: istart, iend, local_index, global_resv_index + + + parafile = DEF_ReservoirPara_file + +#ifndef MPAS_EMBEDDED_COLM + IF (mpas_is_root) THEN + CALL ncio_read_serial (parafile, 'dam_GRAND_ID', dam_GRAND_ID) + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_seq', dam_seq) + + totalnumresv = size(dam_seq) +#else + CALL ncio_inquire_length (parafile, 'dam_seq', totalnumresv) +#endif + + IF (.true.) THEN + + allocate (ucat2resv (numucat)) + ucat2resv = 0 + allocate (resv_global_index(numucat)) + + numresv = 0 + +#ifdef MPAS_EMBEDDED_COLM + IF (numucat > 0 .and. totalnumresv > 0) THEN + allocate (order (numucat)) + allocate (local_ucid (numucat)) + + order = (/(i, i = 1, numucat)/) + local_ucid = ucat_ucid + CALL quicksort (numucat, local_ucid, order) + + istart = 1 + DO WHILE (istart <= totalnumresv) + iend = min(istart + dam_seq_chunk_size - 1, totalnumresv) + CALL ncio_read_part_serial (parafile, 'dam_seq', istart, iend, dam_seq) + + DO i = lbound(dam_seq,1), ubound(dam_seq,1) + iloc = find_in_sorted_list1 (dam_seq(i), numucat, local_ucid) + IF (iloc > 0) THEN + local_index = order(iloc) + global_resv_index = istart + i - lbound(dam_seq,1) + IF (ucat2resv(local_index) /= 0) THEN + CALL CoLM_stop('Duplicate dam_seq entry for a local embedded CoLM unit catchment.') + ENDIF + numresv = numresv + 1 + lake_type(local_index) = 2 + ucat2resv(local_index) = numresv + resv_global_index(numresv) = global_resv_index + ENDIF + ENDDO + + deallocate (dam_seq) + istart = iend + 1 + ENDDO + ENDIF +#else + allocate (order (totalnumresv)) + order = (/(i, i = 1, totalnumresv)/) + + CALL quicksort (totalnumresv, dam_seq, order) + + DO i = 1, numucat + iloc = find_in_sorted_list1 (ucat_ucid(i), totalnumresv, dam_seq) + IF (iloc > 0) THEN + numresv = numresv + 1 + lake_type(i) = 2 + ucat2resv(i) = numresv + resv_global_index(numresv) = order(iloc) + ENDIF + ENDDO +#endif + + ENDIF + +#ifndef MPAS_EMBEDDED_COLM +#ifdef MPAS_MPI + IF (.not. allocated(resv_data_address)) allocate (resv_data_address (0:mpas_size-1)) + + IF (mpas_is_root) THEN + DO irank = 0, mpas_size-1 + + IF (irank == mpas_rank) THEN + nresv = numresv + ELSE + CALL mpi_recv (nresv, 1, MPI_INTEGER, & + irank, mpi_tag_mesg, mpas_comm, mpas_status, mpas_mpi_ierr) + ENDIF + + IF (nresv > 0) THEN + allocate (resv_data_address(irank)%val (nresv)) + IF (irank == mpas_rank) THEN + resv_data_address(irank)%val = resv_global_index(1:nresv) + ELSE + CALL mpi_recv (resv_data_address(irank)%val, nresv, MPI_INTEGER, & + irank, mpi_tag_data, mpas_comm, mpas_status, mpas_mpi_ierr) + ENDIF + ENDIF + ENDDO + + ENDIF + + IF (.true. .and. (.not. mpas_is_root)) THEN + + CALL mpi_send (numresv, 1, MPI_INTEGER, mpas_root, mpi_tag_mesg, mpas_comm, mpas_mpi_ierr) + + IF (numresv > 0) THEN + CALL mpi_send (resv_global_index(1:numresv), numresv, MPI_INTEGER, mpas_root, & + mpi_tag_data, mpas_comm, mpas_mpi_ierr) + ENDIF + + ENDIF +#else + IF (numresv > 0) THEN + allocate (resv_data_address (0:0)) + allocate (resv_data_address(0)%val (numresv)) + resv_data_address(0)%val = resv_global_index(1:numresv) + ENDIF +#endif +#endif + + IF (.true.) THEN + + IF (numresv > 0) THEN + + allocate (dam_build_year (numresv)) + + allocate (volresv_total (numresv)) + allocate (volresv_emerg (numresv)) + allocate (volresv_adjust (numresv)) + allocate (volresv_normal (numresv)) + + allocate (qresv_flood (numresv)) + allocate (qresv_adjust (numresv)) + allocate (qresv_normal (numresv)) + + allocate (qresv_in (numresv)) + allocate (qresv_out (numresv)) + qresv_in(:) = 0._r8 + qresv_out(:) = 0._r8 + + ENDIF + + ENDIF + +#ifdef MPAS_EMBEDDED_COLM + IF (.true. .and. (numresv > 0)) THEN + CALL ncio_read_indexed_serial (parafile, 'dam_year', resv_global_index(1:numresv), icache) + dam_build_year = icache + + CALL ncio_read_indexed_serial (parafile, 'dam_TotalVol_mcm', resv_global_index(1:numresv), rcache) + volresv_total = rcache*1.e6 + + CALL ncio_read_indexed_serial (parafile, 'dam_ConVol_mcm', resv_global_index(1:numresv), rcache) + volresv_normal = rcache*1.e6 + + CALL ncio_read_indexed_serial (parafile, 'dam_Qn', resv_global_index(1:numresv), rcache) + qresv_normal = rcache + + CALL ncio_read_indexed_serial (parafile, 'dam_Qf', resv_global_index(1:numresv), rcache) + qresv_flood = rcache + ENDIF +#else + CALL ncio_read_bcast_serial (parafile, 'dam_year', icache) + IF (.true. .and. (numresv > 0)) THEN + dam_build_year = icache(resv_global_index(1:numresv)) + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_TotalVol_mcm', rcache) + IF (.true. .and. (numresv > 0)) THEN + volresv_total = rcache(resv_global_index(1:numresv))*1.e6 + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_ConVol_mcm', rcache) + IF (.true. .and. (numresv > 0)) THEN + volresv_normal = rcache(resv_global_index(1:numresv))*1.e6 + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_Qn', rcache) + IF (.true. .and. (numresv > 0)) THEN + qresv_normal = rcache(resv_global_index(1:numresv)) + ENDIF + + CALL ncio_read_bcast_serial (parafile, 'dam_Qf', rcache) + IF (.true. .and. (numresv > 0)) THEN + qresv_flood = rcache(resv_global_index(1:numresv)) + ENDIF +#endif + + + IF (.true.) THEN + IF (numresv > 0) THEN + IF (any(resv_global_index(1:numresv) < 1) .or. & + any(resv_global_index(1:numresv) > totalnumresv)) THEN + CALL CoLM_stop('Embedded CoLM reservoir index is outside the parameter file.') + ENDIF + IF (.not. all(ieee_is_finite(volresv_total)) .or. & + .not. all(ieee_is_finite(volresv_normal)) .or. & + .not. all(ieee_is_finite(qresv_normal)) .or. & + .not. all(ieee_is_finite(qresv_flood))) THEN + CALL CoLM_stop('Embedded CoLM reservoir parameters contain non-finite values.') + ENDIF + IF (any(dam_build_year <= 0) .or. any(volresv_total <= 0._r8) .or. & + any(volresv_normal <= 0._r8) .or. any(volresv_normal > volresv_total) .or. & + any(qresv_normal < 0._r8) .or. any(qresv_flood < qresv_normal)) THEN + CALL CoLM_stop('Embedded CoLM reservoir parameters are outside their physical ranges.') + ENDIF + ENDIF + DO irsv = 1, numresv + volresv_emerg (irsv) = volresv_total(irsv) * 0.94 + volresv_adjust(irsv) = volresv_total(irsv) * 0.77 + volresv_normal(irsv) = min(volresv_total(irsv)*0.7, volresv_normal(irsv)) + qresv_adjust (irsv) = (qresv_normal(irsv) + qresv_flood(irsv)) * 0.5 + ENDDO + ENDIF + + IF (allocated(dam_seq)) deallocate(dam_seq) + IF (allocated(order )) deallocate(order ) + IF (allocated(local_ucid)) deallocate(local_ucid) + IF (allocated(rcache )) deallocate(rcache ) + IF (allocated(icache )) deallocate(icache ) + + END SUBROUTINE reservoir_init + + + SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout) + + USE MOD_MPAS_MPI, only: CoLM_stop + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + integer, intent(in) :: method + integer, intent(in) :: irsv + real(r8), intent(in) :: qin, vol + real(r8), intent(out) :: qout + + ! local variables + real(r8) :: q1 + + IF (irsv < 1 .or. irsv > numresv) THEN + CALL CoLM_stop('Embedded CoLM reservoir operation received an invalid local reservoir index.') + ENDIF + IF (.not. ieee_is_finite(qin) .or. .not. ieee_is_finite(vol) .or. vol < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM reservoir operation received invalid state or forcing.') + ENDIF + IF (method /= 1) THEN + CALL CoLM_stop('Unsupported embedded CoLM reservoir operation method.') + ENDIF + + IF (method == 1) THEN + ! *** Reference *** + ! [1] Mizuki Funato, Dai Yamazaki, Dung Trung Vu. + ! Development of an improved reservoir operation scheme for global flood modeling. + ! ESS Open Archive . October 24, 2024. + + IF (vol > volresv_emerg(irsv)) THEN + qout = max(qin, qresv_flood(irsv)) + ELSEIF (vol > volresv_adjust(irsv)) THEN + qout = qresv_adjust(irsv) + (qresv_flood(irsv)-qresv_adjust(irsv)) & + * ((vol-volresv_adjust(irsv))/(volresv_emerg(irsv)-volresv_adjust(irsv)))**0.1 + IF (qin > qresv_flood(irsv)) THEN + q1 = qresv_normal(irsv) + (qin-qresv_normal(irsv)) & + * (vol-volresv_normal(irsv))/(volresv_emerg(irsv)-volresv_normal(irsv)) + qout = max(q1, qout) + ENDIF + ELSEIF (vol > volresv_normal(irsv)) THEN + qout = qresv_normal(irsv) + (qresv_adjust(irsv)-qresv_normal(irsv)) & + * ((vol-volresv_normal(irsv))/(volresv_adjust(irsv)-volresv_normal(irsv)))**3. + ELSE + qout = (vol/volresv_normal(irsv))**0.5 * qresv_normal(irsv) + ENDIF + + ENDIF + + END SUBROUTINE reservoir_operation + + + SUBROUTINE reservoir_final () + + IMPLICIT NONE + + IF (allocated(ucat2resv )) deallocate (ucat2resv ) + IF (allocated(resv_global_index)) deallocate (resv_global_index) + IF (allocated(resv_data_address)) deallocate (resv_data_address) + + IF (allocated(dam_GRAND_ID )) deallocate (dam_GRAND_ID ) + IF (allocated(dam_build_year )) deallocate (dam_build_year ) + + IF (allocated(volresv_total )) deallocate (volresv_total ) + IF (allocated(volresv_emerg )) deallocate (volresv_emerg ) + IF (allocated(volresv_adjust )) deallocate (volresv_adjust ) + IF (allocated(volresv_normal )) deallocate (volresv_normal ) + + IF (allocated(qresv_flood )) deallocate (qresv_flood ) + IF (allocated(qresv_adjust )) deallocate (qresv_adjust ) + IF (allocated(qresv_normal )) deallocate (qresv_normal ) + + IF (allocated(qresv_in )) deallocate (qresv_in ) + IF (allocated(qresv_out )) deallocate (qresv_out ) + + totalnumresv = 0 + numresv = 0 + + END SUBROUTINE reservoir_final + +END MODULE MOD_Grid_Reservoir +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 new file mode 100644 index 0000000000..6172a6272a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90 @@ -0,0 +1,848 @@ +#include + +#ifdef GridRiverLakeFlow +MODULE MOD_Grid_RiverLakeFlow +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! River Lake flow. +! +!------------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Namelist + USE MOD_Grid_RiverLakeNetwork + USE MOD_Grid_RiverLakeTimeVars + USE MOD_Grid_Reservoir +#ifdef GridRiverLakeSediment + USE MOD_Grid_RiverLakeSediment, only: grid_sediment_init, grid_sediment_calc, & + grid_sediment_final, sediment_diag_accumulate, sediment_forcing_put, & + read_sediment_restart +#endif + IMPLICIT NONE + + real(r8), parameter :: RIVERMIN = 1.e-5_r8 + + real(r8), save :: acctime_rnof_max + + logical, allocatable :: filter_rnof (:) + +CONTAINS + + ! --------- + SUBROUTINE grid_riverlake_flow_init () + + USE MOD_LandPatch, only: numpatch + USE MOD_Vars_TimeInvariants, only: patchtype, patchmask + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + IF (.not. ieee_is_finite(DEF_GRIDBASED_ROUTING_MAX_DT) .or. & + DEF_GRIDBASED_ROUTING_MAX_DT <= 0._r8) THEN + CALL CoLM_stop('DEF_GRIDBASED_ROUTING_MAX_DT must be finite and positive.') + ENDIF + acctime_rnof_max = DEF_GRIDBASED_ROUTING_MAX_DT + + ! excluding (patchtype >= 99), virtual patches and those forcing missed + IF (.true.) THEN + IF (.not. allocated(wdsrf_ucat) .or. .not. allocated(veloc_riv) .or. & + .not. allocated(momen_riv) .or. .not. allocated(acc_rnof_uc)) THEN + CALL CoLM_stop('Embedded CoLM river state is not allocated.') + ENDIF + IF (size(wdsrf_ucat) /= numucat .or. size(veloc_riv) /= numucat .or. & + size(momen_riv) /= numucat .or. size(acc_rnof_uc) /= numucat) THEN + CALL CoLM_stop('Embedded CoLM river state dimensions do not match local unit catchments.') + ENDIF + IF (DEF_Reservoir_Method > 0) THEN + IF (.not. allocated(volresv)) THEN + CALL CoLM_stop('Embedded CoLM river state is missing local reservoir storage.') + ENDIF + IF (size(volresv) /= numresv) THEN + CALL CoLM_stop('Embedded CoLM reservoir state dimensions do not match local reservoirs.') + ENDIF + ENDIF + allocate (filter_rnof (numpatch)) + IF (numpatch > 0) THEN + filter_rnof = patchtype < 99 + filter_rnof = filter_rnof .and. patchmask + ENDIF + ENDIF + +#ifdef GridRiverLakeSediment + CALL grid_sediment_init() + IF (len_trim(gridriver_restart_file) > 0) THEN + CALL read_sediment_restart(gridriver_restart_file) + ENDIF +#endif + + END SUBROUTINE grid_riverlake_flow_init + + ! --------- + SUBROUTINE grid_riverlake_flow (year, deltime) + + USE MOD_Utils + USE MOD_Namelist, only: DEF_Reservoir_Method, DEF_USE_SEDIMENT + USE MOD_Vars_1DFluxes, only: rnof + USE MOD_LandPatch, only: elm_patch, numpatch + USE MOD_Const_Physical, only: grav + USE MOD_Vars_Global, only: spval +#ifdef GridRiverLakeSediment + USE MOD_Vars_1DForcing, only: forc_prc, forc_prl +#endif + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + integer, intent(in) :: year + real(r8), intent(in) :: deltime + + ! Local Variables + integer :: i, irsv, ntimestep + real(r8) :: dt_this + + real(r8), allocatable :: rnof_gd(:) + real(r8), allocatable :: rnof_uc(:) + +#ifdef GridRiverLakeSediment + real(r8), allocatable :: prcp_gd(:) + real(r8), allocatable :: prcp_uc(:) + real(r8), allocatable :: prcp_pch(:) + real(r8), allocatable :: floodarea_sed(:) +#endif + + logical, allocatable :: is_built_resv(:) + + real(r8), allocatable :: wdsrf_next(:) + real(r8), allocatable :: veloc_next(:) + + real(r8), allocatable :: hflux_fc(:) + real(r8), allocatable :: mflux_fc(:) + real(r8), allocatable :: zgrad_dn(:) + real(r8), allocatable :: acc_discharge(:) + + real(r8), allocatable :: hflux_resv(:) + real(r8), allocatable :: mflux_resv(:) + + real(r8), allocatable :: hflux_sumups(:) + real(r8), allocatable :: mflux_sumups(:) + real(r8), allocatable :: zgrad_sumups(:) + + real(r8), allocatable :: sum_hflux_riv(:) + real(r8), allocatable :: sum_mflux_riv(:) + real(r8), allocatable :: sum_zgrad_riv(:) + + real(r8) :: veloct_fc, height_fc + real(r8) :: bedelv_fc, height_up, height_dn + real(r8) :: vwave_up, vwave_dn, hflux_up, hflux_dn, mflux_up, mflux_dn + real(r8) :: volwater, friction + real(r8), allocatable :: dt_res(:), dt_all(:) + logical, allocatable :: ucatfilter(:) + real(r8) :: global_dt_remaining(1) +#ifdef CoLMDEBUG + real(r8) :: totalvol_bef, totalvol_aft, totalrnof, totaldis +#endif + + IF (.not. ieee_is_finite(deltime) .or. deltime <= 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing timestep must be finite and positive.') + ENDIF + IF (.not. ieee_is_finite(acctime_rnof) .or. acctime_rnof < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing accumulator time is invalid.') + ENDIF + + IF (.true.) THEN + + allocate (rnof_gd (numinpm)) + allocate (rnof_uc (numucat)) + + IF (numpatch > 0) THEN + IF (size(filter_rnof) < numpatch .or. size(rnof) < numpatch) THEN + CALL CoLM_stop('Embedded CoLM runoff arrays do not match the local patch count.') + ENDIF + IF (any(filter_rnof(1:numpatch) .and. .not. ieee_is_finite(rnof(1:numpatch)))) THEN + CALL CoLM_stop('Embedded CoLM runoff contains non-finite values on active patches.') + ENDIF + CALL compute_remap_data_pset2grid (remap_patch2inpm, rnof, rnof_gd, & + fillvalue = 0., filter = filter_rnof) + ELSE + rnof_gd = 0._r8 + ENDIF + + IF (numinpm > 0) THEN + WHERE (push_ucat2inpm%sum_area > 0) + rnof_gd = rnof_gd / push_ucat2inpm%sum_area + END WHERE + ENDIF + + CALL compute_push_data (push_inpm2ucat, rnof_gd, rnof_uc, & + fillvalue = 0., mode = 'sum') + + IF (numucat > 0) THEN + IF (.not. all(ieee_is_finite(rnof_uc))) THEN + CALL CoLM_stop('Embedded CoLM unit-catchment runoff contains non-finite values.') + ENDIF + acc_rnof_uc = acc_rnof_uc + rnof_uc*1.e-3*deltime + IF (.not. all(ieee_is_finite(acc_rnof_uc))) THEN + CALL CoLM_stop('Embedded CoLM accumulated runoff contains non-finite values.') + ENDIF + ENDIF + + deallocate(rnof_gd) + deallocate(rnof_uc) + +#ifdef GridRiverLakeSediment + IF (DEF_USE_SEDIMENT) THEN + ! Allocate zero-length arrays on empty ranks to avoid passing unallocated + ! arrays to assumed-shape dummy arguments in MPI communication routines. + IF (numpatch > 0) THEN + allocate (prcp_pch (numpatch)) + prcp_pch = forc_prc + forc_prl + ELSE + allocate (prcp_pch (0)) + ENDIF + IF (numinpm > 0) THEN + allocate (prcp_gd (numinpm)) + ELSE + allocate (prcp_gd (0)) + ENDIF + IF (numucat > 0) THEN + allocate (prcp_uc (numucat)) + ELSE + allocate (prcp_uc (0)) + ENDIF + + CALL compute_remap_data_pset2grid (remap_patch2inpm, prcp_pch, prcp_gd, & + fillvalue = 0., filter = filter_rnof) + + IF (numinpm > 0) THEN + WHERE (push_ucat2inpm%sum_area > 0) + prcp_gd = prcp_gd / push_ucat2inpm%sum_area + END WHERE + ENDIF + + CALL compute_push_data (push_inpm2ucat, prcp_gd, prcp_uc, & + fillvalue = 0., mode = 'sum') + + ! Convert from area-integrated [mm/s * m²] back to flux density [mm/s]. + ! push_data(mode='sum') produces area-integrated values (like rnof_uc), + ! but the sediment yield formula expects a rate and multiplies by area internally. + IF (numucat > 0) THEN + WHERE (topo_area > 0._r8) + prcp_uc = prcp_uc / topo_area + END WHERE + ENDIF + + CALL sediment_forcing_put(prcp_uc, deltime) + + deallocate(prcp_pch) + deallocate(prcp_gd) + deallocate(prcp_uc) + ENDIF +#endif + + ENDIF + + + acctime_rnof = acctime_rnof + deltime + IF (.not. ieee_is_finite(acctime_rnof)) THEN + CALL CoLM_stop('Embedded CoLM river routing accumulator time overflowed.') + ENDIF + + IF (acctime_rnof+0.01 < acctime_rnof_max) THEN + RETURN + ENDIF + + IF (.true.) THEN + + allocate (is_built_resv (numucat)) + allocate (wdsrf_next (numucat)) + allocate (veloc_next (numucat)) + allocate (hflux_fc (numucat)) + allocate (mflux_fc (numucat)) + allocate (zgrad_dn (numucat)) + allocate (acc_discharge (numucat)) + allocate (sum_hflux_riv (numucat)) + allocate (sum_mflux_riv (numucat)) + allocate (sum_zgrad_riv (numucat)) + allocate (ucatfilter (numucat)) + + allocate (hflux_sumups (numucat)) + allocate (mflux_sumups (numucat)) + allocate (zgrad_sumups (numucat)) + + IF (DEF_Reservoir_Method > 0) THEN + allocate (hflux_resv (numucat)) + allocate (mflux_resv (numucat)) + ENDIF + + allocate (dt_res (max(1,numrivsys))) + allocate (dt_all (max(1,numrivsys))) + + hflux_fc(:) = 0._r8 + mflux_fc(:) = 0._r8 + zgrad_dn(:) = 0._r8 + acc_discharge(:) = 0._r8 + sum_hflux_riv(:) = 0._r8 + sum_mflux_riv(:) = 0._r8 + sum_zgrad_riv(:) = 0._r8 + hflux_sumups(:) = 0._r8 + mflux_sumups(:) = 0._r8 + zgrad_sumups(:) = 0._r8 + IF (allocated(hflux_resv)) hflux_resv(:) = 0._r8 + IF (allocated(mflux_resv)) mflux_resv(:) = 0._r8 + +#ifdef CoLMDEBUG + totalrnof = sum(acc_rnof_uc) + totalvol_bef = 0. +#endif + + DO i = 1, numucat + + is_built_resv(i) = .false. + IF (lake_type(i) == 2) THEN + irsv = ucat2resv(i) + IF (year >= dam_build_year(irsv)) THEN + is_built_resv(i) = .true. + IF (.not. ieee_is_finite(volresv(irsv))) THEN + CALL CoLM_stop('Embedded CoLM river routing received a non-finite reservoir volume.') + ELSEIF (abs(volresv(irsv)) >= 0.5_r8 * abs(spval)) THEN + volresv(irsv) = floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + wdsrf_ucat(i) = floodplain_curve(i)%depth (volresv(irsv)) + ENDIF + ENDIF + ENDIF + + IF (.not. is_built_resv(i)) THEN + momen_riv(i) = wdsrf_ucat(i) * veloc_riv(i) + volwater = floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + ! water in reservoirs is assumued to be stationary. + momen_riv(i) = 0 + veloc_riv(i) = 0 + volwater = volresv(ucat2resv(i)) + ENDIF + +#ifdef CoLMDEBUG + totalvol_bef = totalvol_bef + volwater +#endif + + volwater = volwater + acc_rnof_uc(i) + + IF (.not. is_built_resv(i)) THEN + wdsrf_ucat(i) = floodplain_curve(i)%depth (volwater) + IF (wdsrf_ucat(i) > RIVERMIN) THEN + veloc_riv(i) = momen_riv(i) / wdsrf_ucat(i) + ELSE + veloc_riv(i) = 0. + ENDIF + ELSE + volresv(ucat2resv(i)) = volwater + ENDIF + + ENDDO + + + ntimestep = 0 +#ifdef CoLMDEBUG + totaldis = 0. +#endif + + dt_res(:) = 0._r8 + DO i = 1, numucat + dt_res(irivsys(i)) = acctime_rnof + ENDDO + + global_dt_remaining(1) = maxval(dt_res) +#ifdef MPAS_MPI + CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_stop('Embedded CoLM river routing failed to synchronize remaining time.') +#endif + IF (.not. ieee_is_finite(global_dt_remaining(1)) .or. global_dt_remaining(1) < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing has invalid remaining integration time.') + ENDIF + + DO WHILE (global_dt_remaining(1) > 0._r8) + + ntimestep = ntimestep + 1 + + CALL compute_push_data (push_next2ucat, wdsrf_ucat, wdsrf_next, fillvalue = spval) + ! velocity in ocean or inland depression is assumed to be 0. + CALL compute_push_data (push_next2ucat, veloc_riv, veloc_next, fillvalue = 0.) + + dt_all(:) = huge(1._r8) + WHERE (dt_res > 0._r8) + dt_all = min(dt_res, 60._r8) + END WHERE + + hflux_fc(:) = 0._r8 + mflux_fc(:) = 0._r8 + zgrad_dn(:) = 0._r8 + sum_hflux_riv(:) = 0._r8 + sum_mflux_riv(:) = 0._r8 + sum_zgrad_riv(:) = 0._r8 + IF (allocated(hflux_resv)) hflux_resv(:) = 0._r8 + IF (allocated(mflux_resv)) mflux_resv(:) = 0._r8 + + DO i = 1, numucat + + ucatfilter(i) = dt_res(irivsys(i)) > 0._r8 + + IF (.not. ucatfilter(i)) CYCLE + + ! reservoir + IF (is_built_resv(i)) THEN + hflux_fc(i) = 0. + mflux_fc(i) = 0. + zgrad_dn(i) = 0. + CYCLE + ENDIF + + IF ((ucat_next(i) > 0) .or. (ucat_next(i) == -9)) THEN + + IF (ucat_next(i) > 0) THEN + ! both rivers are dry. + IF ((wdsrf_ucat(i) < RIVERMIN) .and. (wdsrf_next(i) < RIVERMIN)) THEN + hflux_fc(i) = 0 + mflux_fc(i) = 0 + zgrad_dn(i) = 0 + CYCLE + ENDIF + ENDIF + + ! reconstruction of height of water near interface + IF (ucat_next(i) > 0) THEN + bedelv_fc = max(topo_rivelv(i), bedelv_next(i)) + height_up = max(0., wdsrf_ucat(i)+topo_rivelv(i)-bedelv_fc) + height_dn = max(0., wdsrf_next(i)+bedelv_next(i)-bedelv_fc) + ELSEIF (ucat_next(i) == -9) THEN ! for river mouth + bedelv_fc = topo_rivelv(i) + height_up = wdsrf_ucat (i) + ! sea level is assumed to be 0. and sea bed is assumed to be negative infinity. + height_dn = max(0., - bedelv_fc) + ENDIF + + ! velocity at river downstream face (middle region in Riemann problem) + veloct_fc = 0.5 * (veloc_riv(i) + veloc_next(i)) & + + sqrt(grav * height_up) - sqrt(grav * height_dn) + + ! height of water at downstream face (middle region in Riemann problem) + height_fc = 1/grav * (0.5*(sqrt(grav*height_up) + sqrt(grav*height_dn)) & + + 0.25 * (veloc_riv(i) - veloc_next(i))) ** 2 + + IF (height_up > 0) THEN + vwave_up = min(veloc_riv(i)-sqrt(grav*height_up), veloct_fc-sqrt(grav*height_fc)) + ELSE + vwave_up = veloc_next(i) - 2.0 * sqrt(grav*height_dn) + ENDIF + + IF (height_dn > 0) THEN + vwave_dn = max(veloc_next(i)+sqrt(grav*height_dn), veloct_fc+sqrt(grav*height_fc)) + ELSE + vwave_dn = veloc_riv(i) + 2.0 * sqrt(grav*height_up) + ENDIF + + hflux_up = veloc_riv(i) * height_up + hflux_dn = veloc_next(i) * height_dn + mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2 + mflux_dn = veloc_next(i)**2 * height_dn + 0.5*grav * height_dn**2 + + IF (vwave_up >= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_up + mflux_fc(i) = outletwth(i) * mflux_up + ELSEIF (vwave_dn <= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_dn + mflux_fc(i) = outletwth(i) * mflux_dn + ELSE + hflux_fc(i) = outletwth(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & + + vwave_up*vwave_dn*(height_dn-height_up)) / (vwave_dn-vwave_up) + mflux_fc(i) = outletwth(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & + + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) + ENDIF + + sum_zgrad_riv(i) = sum_zgrad_riv(i) + outletwth(i) * 0.5*grav * height_up**2 + + zgrad_dn(i) = outletwth(i) * 0.5*grav * height_dn**2 + + ELSEIF (ucat_next(i) == -99) THEN + ! downstream is not in model region. + ! assume: 1. downstream river bed is equal to this river bed. + ! 2. downstream water surface is equal to this river depth. + ! 3. downstream water velocity is equal to this velocity. + + veloc_riv(i) = max(veloc_riv(i), 0.) + + IF (wdsrf_ucat(i) > topo_rivhgt(i)) THEN + + ! reconstruction of height of water near interface + height_up = wdsrf_ucat (i) + height_dn = topo_rivhgt(i) + + veloct_fc = veloc_riv(i) + sqrt(grav * height_up) - sqrt(grav * height_dn) + height_fc = 1/grav * (0.5*(sqrt(grav*height_up) + sqrt(grav*height_dn))) ** 2 + + vwave_up = min(veloc_riv(i)-sqrt(grav*height_up), veloct_fc-sqrt(grav*height_fc)) + vwave_dn = max(veloc_riv(i)+sqrt(grav*height_dn), veloct_fc+sqrt(grav*height_fc)) + + hflux_up = veloc_riv(i) * height_up + hflux_dn = veloc_riv(i) * height_dn + mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2 + mflux_dn = veloc_riv(i)**2 * height_dn + 0.5*grav * height_dn**2 + + IF (vwave_up >= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_up + mflux_fc(i) = outletwth(i) * mflux_up + ELSEIF (vwave_dn <= 0.) THEN + hflux_fc(i) = outletwth(i) * hflux_dn + mflux_fc(i) = outletwth(i) * mflux_dn + ELSE + hflux_fc(i) = outletwth(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn & + + vwave_up*vwave_dn*(height_dn-height_up)) / (vwave_dn-vwave_up) + mflux_fc(i) = outletwth(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn & + + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up) + ENDIF + + sum_zgrad_riv(i) = sum_zgrad_riv(i) + outletwth(i) * 0.5*grav * height_up**2 + + ELSE + hflux_fc(i) = 0 + mflux_fc(i) = 0 + ENDIF + + ELSEIF (ucat_next(i) == -10) THEN ! inland depression + hflux_fc(i) = 0 + mflux_fc(i) = 0 + ENDIF + + sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i) + sum_mflux_riv(i) = sum_mflux_riv(i) + mflux_fc(i) + + ENDDO + + CALL compute_push_data (push_ups2ucat, hflux_fc, hflux_sumups, fillvalue = 0., mode = 'sum') + CALL compute_push_data (push_ups2ucat, mflux_fc, mflux_sumups, fillvalue = 0., mode = 'sum') + CALL compute_push_data (push_ups2ucat, zgrad_dn, zgrad_sumups, fillvalue = 0., mode = 'sum') + + IF (numucat > 0) THEN + WHERE (ucatfilter) + sum_hflux_riv = sum_hflux_riv - hflux_sumups + sum_mflux_riv = sum_mflux_riv - mflux_sumups + sum_zgrad_riv = sum_zgrad_riv - zgrad_sumups + END WHERE + ENDIF + + ! reservoir operation. + IF (DEF_Reservoir_Method > 0) THEN + + DO i = 1, numucat + + IF ((.not. ucatfilter(i)) .or. (ucat_next(i) == -10)) CYCLE + + hflux_resv(i) = 0. + mflux_resv(i) = 0. + + IF (is_built_resv(i)) THEN + + irsv = ucat2resv(i) + qresv_in(irsv) = - sum_hflux_riv(i) + + IF (volresv(irsv) > 1.e-4 * volresv_total(irsv)) THEN + CALL reservoir_operation (DEF_Reservoir_Method, & + irsv, qresv_in(irsv), volresv(irsv), qresv_out(irsv)) + ELSE + qresv_out (irsv) = 0. + ENDIF + + hflux_fc(i) = qresv_out(irsv) + mflux_fc(i) = qresv_out(irsv) * sqrt(2*grav*wdsrf_ucat(i)) + + sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i) + sum_mflux_riv(i) = sum_mflux_riv(i) + mflux_fc(i) + + hflux_resv(i) = hflux_fc(i) + mflux_resv(i) = mflux_fc(i) + ENDIF + + ENDDO + + CALL compute_push_data (push_ups2ucat, hflux_resv, hflux_sumups, fillvalue = 0., mode = 'sum') + CALL compute_push_data (push_ups2ucat, mflux_resv, mflux_sumups, fillvalue = 0., mode = 'sum') + + IF (numucat > 0) THEN + WHERE (ucatfilter) + sum_hflux_riv = sum_hflux_riv - hflux_sumups + sum_mflux_riv = sum_mflux_riv - mflux_sumups + END WHERE + ENDIF + + ENDIF + + IF (numucat > 0) THEN + IF (any(ucatfilter .and. (.not. ieee_is_finite(sum_hflux_riv) .or. & + .not. ieee_is_finite(sum_mflux_riv) .or. .not. ieee_is_finite(sum_zgrad_riv)))) THEN + CALL CoLM_stop('Embedded CoLM river routing produced non-finite fluxes.') + ENDIF + ENDIF + + DO i = 1, numucat + + IF (.not. ucatfilter(i)) CYCLE + + dt_this = dt_all(irivsys(i)) + + ! constraint 1: CFL condition (only for rivers) + IF (.not. is_built_resv(i)) THEN + IF ((abs(veloc_riv(i)) > 0._r8) .or. (wdsrf_ucat(i) > 0._r8)) THEN + dt_this = min(dt_this, topo_rivlen(i)/(abs(veloc_riv(i))+sqrt(grav*wdsrf_ucat(i)))*0.8) + ENDIF + ENDIF + + ! constraint 2: Avoid negative values of water + IF (sum_hflux_riv(i) > 0) THEN + IF (.not. is_built_resv(i)) THEN + ! for river or lake catchment + volwater = floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + ! for reservoir + volwater = volresv(ucat2resv(i)) + ENDIF + + dt_this = min(dt_this, volwater / sum_hflux_riv(i)) + + ENDIF + + ! constraint 3: Avoid change of flow direction (only for rivers) + ! IF (.not. is_built_resv(i)) THEN + ! IF ((abs(veloc_riv(i)) > 0.1) & + ! .and. (veloc_riv(i) * (sum_mflux_riv(i)-sum_zgrad_riv(i)) > 0)) THEN + ! dt_this = min(dt_this, & + ! abs(momen_riv(i) * topo_rivare(i) / (sum_mflux_riv(i)-sum_zgrad_riv(i)))) + ! ENDIF + ! ENDIF + + dt_all(irivsys(i)) = min(dt_this, dt_all(irivsys(i))) + + ENDDO + +#ifdef MPAS_MPI + CALL synchronize_river_system_min(dt_all) +#endif + + DO i = 1, numrivsys + IF (dt_res(i) > 0._r8) THEN + IF (.not. ieee_is_finite(dt_all(i)) .or. dt_all(i) <= 0._r8 .or. dt_all(i) > dt_res(i)) THEN + CALL CoLM_stop('Embedded CoLM river routing produced an invalid integration substep.') + ENDIF + IF (dt_all(i) < dt_res(i)) THEN + IF (dt_res(i) - dt_all(i) >= dt_res(i)) THEN + CALL CoLM_stop('Embedded CoLM river routing substep cannot advance floating-point time.') + ENDIF + ENDIF + ENDIF + ENDDO + + DO i = 1, numucat + + IF (.not. ucatfilter(i)) CYCLE + + IF (.not. is_built_resv(i)) THEN + volwater = floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + volwater = volresv(ucat2resv(i)) + ENDIF + + volwater = volwater - sum_hflux_riv(i) * dt_all(irivsys(i)) + volwater = max(volwater, 0.) + + ! for inland depression, remove excess water (to be optimized) + IF (ucat_next(i) == -10) THEN + IF (volwater > topo_rivstomax(i)) THEN + hflux_fc(i) = (volwater - topo_rivstomax(i)) / dt_all(irivsys(i)) + volwater = topo_rivstomax(i) + ENDIF + ENDIF + + wdsrf_ucat(i) = floodplain_curve(i)%depth (volwater) + + IF (is_built_resv(i)) THEN + volresv(ucat2resv(i)) = volwater + ENDIF + + IF ((.not. is_built_resv(i)) .and. (wdsrf_ucat(i) >= RIVERMIN)) THEN + friction = grav * topo_rivman(i)**2 / wdsrf_ucat(i)**(7.0/3.0) * abs(momen_riv(i)) + momen_riv(i) = (momen_riv(i) & + - (sum_mflux_riv(i) - sum_zgrad_riv(i)) / topo_rivare(i) * dt_all(irivsys(i))) & + / (1 + friction * dt_all(irivsys(i))) + veloc_riv(i) = momen_riv(i) / wdsrf_ucat(i) + ELSE + momen_riv(i) = 0 + veloc_riv(i) = 0 + ENDIF + + ! inland depression river + IF ((.not. is_built_resv(i)) .and. (ucat_next(i) == -10)) THEN + momen_riv(i) = min(0., momen_riv(i)) + veloc_riv(i) = min(0., veloc_riv(i)) + ENDIF + + veloc_riv(i) = min(veloc_riv(i), 20.) + veloc_riv(i) = max(veloc_riv(i), -20.) + momen_riv(i) = wdsrf_ucat(i) * veloc_riv(i) + + ENDDO + + DO i = 1, numucat + IF (ucatfilter(i)) THEN + acc_discharge(i) = acc_discharge(i) + hflux_fc(i) * dt_all(irivsys(i)) + +#ifdef CoLMDEBUG + IF (ucat_next(i) <= 0) THEN + totaldis = totaldis + hflux_fc(i)*dt_all(irivsys(i)) + ENDIF +#endif + + ENDIF + ENDDO + + WHERE (dt_res > 0._r8) + dt_res = max(0._r8, dt_res - dt_all) + END WHERE + + global_dt_remaining(1) = maxval(dt_res) +#ifdef MPAS_MPI + CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_stop('Embedded CoLM river routing failed to synchronize remaining time.') +#endif + IF (.not. ieee_is_finite(global_dt_remaining(1)) .or. global_dt_remaining(1) < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing has invalid remaining integration time.') + ENDIF + +#ifdef GridRiverLakeSediment + IF (DEF_USE_SEDIMENT) THEN + IF (numucat > 0) THEN + allocate(floodarea_sed(numucat)) + DO i = 1, numucat + IF (ucatfilter(i)) THEN + floodarea_sed(i) = floodplain_curve(i)%floodarea(wdsrf_ucat(i)) + ELSE + floodarea_sed(i) = 0._r8 + ENDIF + ENDDO + ELSE + allocate(floodarea_sed(0)) + ENDIF + CALL sediment_diag_accumulate(dt_all, irivsys, ucatfilter, & + veloc_riv, wdsrf_ucat, hflux_fc, floodarea_sed) + deallocate(floodarea_sed) + ENDIF +#endif + + ENDDO + +#ifdef CoLMDEBUG + totalvol_aft = 0. + DO i = 1, numucat + IF (.not. is_built_resv(i)) THEN + totalvol_aft = totalvol_aft + floodplain_curve(i)%volume (wdsrf_ucat(i)) + ELSE + totalvol_aft = totalvol_aft + volresv(ucat2resv(i)) + ENDIF + ENDDO +#endif + ENDIF + +#ifdef CoLMDEBUG +#ifdef MPAS_MPI + IF (.not. .true.) ntimestep = 0 + CALL mpi_allreduce (MPI_IN_PLACE, ntimestep, 1, MPI_INTEGER, MPI_MAX, mpas_comm, mpas_mpi_ierr) + + IF (.not. .true.) totalvol_bef = 0. + IF (.not. .true.) totalvol_aft = 0. + IF (.not. .true.) totalrnof = 0. + IF (.not. .true.) totaldis = 0. + + CALL mpi_allreduce (MPI_IN_PLACE, totalvol_bef, 1, MPI_REAL8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpi_allreduce (MPI_IN_PLACE, totalvol_aft, 1, MPI_REAL8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpi_allreduce (MPI_IN_PLACE, totalrnof, 1, MPI_REAL8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpi_allreduce (MPI_IN_PLACE, totaldis, 1, MPI_REAL8, MPI_SUM, mpas_comm, mpas_mpi_ierr) +#endif + IF (mpas_is_root) THEN + write(*,'(/,A)') 'Checking River Routing Flow ...' + write(*,'(A,F12.5,A)') 'River Lake Flow minimum average timestep: ', acctime_rnof/ntimestep, ' seconds' + write(*,'(A,ES8.1,A)') 'Total water before : ', totalvol_bef, ' m^3' + write(*,'(A,ES8.1,A)') 'Total runoff : ', totalrnof, ' m^3' + write(*,'(A,ES8.1,A)') 'Total discharge : ', totaldis, ' m^3' + write(*,'(A,ES8.1,A)') 'Total water change : ', totalvol_aft-totalvol_bef, ' m^3' + write(*,'(A,ES8.1,A)') 'Total water balance : ', totalvol_aft-totalvol_bef-totalrnof+totaldis, ' m^3' + ENDIF +#endif + +#ifdef GridRiverLakeSediment + IF (DEF_USE_SEDIMENT .and. .true.) THEN + ! All ranks must participate (MPI point-to-point inside push_data). + ! fldfrc is now computed inside grid_sediment_calc from per-routing-period + ! accumulators (sed_acc_floodarea), not from history-period averages. + CALL grid_sediment_calc(acctime_rnof) + ENDIF +#endif + + IF (.true.) THEN + IF (acctime_rnof <= 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river routing cannot form diagnostics over a non-positive period.') + ENDIF + IF (numucat > 0) THEN + discharge_riv = acc_discharge / acctime_rnof + IF (.not. all(ieee_is_finite(discharge_riv))) THEN + CALL CoLM_stop('Embedded CoLM river routing produced non-finite period-mean discharge.') + ENDIF + ENDIF + ENDIF + CALL update_GridRiverLakeElementDiagnostics() + + acctime_rnof = 0. + + IF (.true.) THEN + IF (numucat > 0) THEN + acc_rnof_uc = 0. + ENDIF + ENDIF + + IF (allocated(is_built_resv)) deallocate(is_built_resv) + IF (allocated(wdsrf_next )) deallocate(wdsrf_next ) + IF (allocated(veloc_next )) deallocate(veloc_next ) + IF (allocated(hflux_fc )) deallocate(hflux_fc ) + IF (allocated(mflux_fc )) deallocate(mflux_fc ) + IF (allocated(zgrad_dn )) deallocate(zgrad_dn ) + IF (allocated(acc_discharge)) deallocate(acc_discharge) + IF (allocated(hflux_resv )) deallocate(hflux_resv ) + IF (allocated(mflux_resv )) deallocate(mflux_resv ) + IF (allocated(hflux_sumups )) deallocate(hflux_sumups ) + IF (allocated(mflux_sumups )) deallocate(mflux_sumups ) + IF (allocated(zgrad_sumups )) deallocate(zgrad_sumups ) + IF (allocated(sum_hflux_riv)) deallocate(sum_hflux_riv) + IF (allocated(sum_mflux_riv)) deallocate(sum_mflux_riv) + IF (allocated(sum_zgrad_riv)) deallocate(sum_zgrad_riv) + IF (allocated(ucatfilter )) deallocate(ucatfilter ) + IF (allocated(dt_res )) deallocate(dt_res ) + IF (allocated(dt_all )) deallocate(dt_all ) + + END SUBROUTINE grid_riverlake_flow + + ! --------- + SUBROUTINE grid_riverlake_flow_final () + + CALL riverlake_network_final () + + IF (DEF_Reservoir_Method > 0) THEN + CALL reservoir_final () + ENDIF + +#ifdef GridRiverLakeSediment + CALL grid_sediment_final() +#endif + + IF (allocated(filter_rnof)) deallocate(filter_rnof) + + END SUBROUTINE grid_riverlake_flow_final + +END MODULE MOD_Grid_RiverLakeFlow +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 new file mode 100644 index 0000000000..b2fe9cd54b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90 @@ -0,0 +1,1355 @@ +#include + +#ifdef GridRiverLakeFlow +MODULE MOD_Grid_RiverLakeNetwork +!-------------------------------------------------------------------------------- +! DESCRIPTION: +!-------------------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_ComputePushData + IMPLICIT NONE + + ! ----- River Lake network ----- + + type(grid_type) :: griducat + + integer :: totalnumucat = 0 + integer :: numucat = 0 + integer, allocatable :: ucat_ucid (:) ! index in unit catchment numbering + + ! ----- Part 1: between runoff input elements and unit catchments ----- + integer :: numinpm = 0 + integer, allocatable :: inpm_gdid (:) + + integer :: inpn = 0 + integer, allocatable :: idmap_gd2uc (:,:) + real(r8), allocatable :: area_gd2uc (:,:) + + integer :: nucpart = 0 + integer, allocatable :: idmap_uc2gd (:,:) + real(r8), allocatable :: area_uc2gd (:,:) + + type(compute_remapdata_type) :: remap_patch2inpm + type(compute_pushdata_type) :: push_inpm2ucat + type(compute_pushdata_type) :: push_ucat2inpm + + ! ----- Part 2: between upstream and downstream unit catchments ----- + integer, allocatable :: ucat_next (:) ! next unit catchment + integer :: upnmax = 0 + integer, allocatable :: ucat_ups (:,:) ! upstream unit catchments + real(r8), allocatable :: wts_ups (:,:) + + type(compute_pushdata_type) :: push_next2ucat + type(compute_pushdata_type) :: push_ups2ucat + + ! ----- Part 3: river systems ----- + integer :: numrivsys = 0 + integer, allocatable :: irivsys (:) +#ifdef MPAS_MPI + integer :: num_owned_rivsys = 0 + integer, allocatable :: rivsys_send_counts (:) + integer, allocatable :: rivsys_send_displs (:) + integer, allocatable :: rivsys_recv_counts (:) + integer, allocatable :: rivsys_recv_displs (:) + integer, allocatable :: rivsys_send_local (:) + integer, allocatable :: rivsys_recv_owner (:) +#endif + + + ! ----- Parameters for River and Lake ----- + + integer, allocatable :: lake_type (:) ! 0: river; 2: reservoir. + + real(r8), allocatable :: topo_rivelv (:) ! river bed elevation [m] + real(r8), allocatable :: topo_rivhgt (:) ! river channel depth [m] + real(r8), allocatable :: topo_rivlen (:) ! river channel length [m] + real(r8), allocatable :: topo_rivman (:) ! river manning coefficient [m] + real(r8), allocatable :: topo_rivwth (:) ! river channel width [m] + real(r8), allocatable :: topo_rivare (:) ! river channel area [m^2] + real(r8), allocatable :: topo_rivstomax (:) ! max river channel storage [m^3] + + real(r8), allocatable :: topo_area (:) ! floodplain area [m^2] + real(r8), allocatable :: topo_fldhgt (:,:) ! floodplain height profile [m] + + real(r8), allocatable :: bedelv_next (:) ! downstream river bed elevation [m] + real(r8), allocatable :: outletwth (:) ! river outlet width [m] + + type :: vol_dep_curve_type + integer :: nlfp + real(r8) :: rivhgt + real(r8) :: rivare + real(r8) :: rivstomax + real(r8), allocatable :: flphgt (:) ! floodplain height profile [m] + real(r8), allocatable :: flparea (:) ! flood plain area [m^2] + real(r8), allocatable :: flpaccare (:) ! flood plain accumulated area [m^2] + real(r8), allocatable :: flpstomax (:) ! max flood plain storage [m^3] + CONTAINS + procedure, PUBLIC :: depth => retrieve_depth_from_volume + procedure, PUBLIC :: volume => retrieve_volume_from_depth + procedure, PUBLIC :: floodarea => retrieve_area_from_depth + final :: vol_depth_curve_free_mem + END type vol_dep_curve_type + + type(vol_dep_curve_type), allocatable :: floodplain_curve (:) + + +CONTAINS + + ! ---------- + SUBROUTINE build_riverlake_network () + + USE MOD_MPAS_MPI, only: mpas_comm, mpas_mpi_ierr, mpas_mpi_check + IMPLICIT NONE + + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network construction entry') + CALL build_riverlake_network_mpas_embedded() + + END SUBROUTINE build_riverlake_network + +#ifdef MPAS_EMBEDDED_COLM + ! --------- + SUBROUTINE build_riverlake_network_mpas_embedded () + + USE MOD_MPAS_MPI + USE MOD_Namelist + USE MOD_NetCDFSerial + USE MOD_Mesh + USE MOD_LandPatch + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + character(len=256) :: parafile + integer, allocatable :: varsize(:) + integer, allocatable :: idmap_x(:,:), idmap_y(:,:) + integer :: nlat_ucat, nlon_ucat + integer :: i, j + + parafile = DEF_UnitCatchment_file + + CALL ncio_inquire_length (parafile, 'seq_next', totalnumucat) + CALL ncio_inquire_length (parafile, 'lon', nlon_ucat) + CALL ncio_inquire_length (parafile, 'lat', nlat_ucat) + + CALL griducat%define_by_ndims (nlon_ucat, nlat_ucat) + CALL build_compute_remapdata (landpatch, griducat, remap_patch2inpm) + + IF (.true.) THEN + numinpm = remap_patch2inpm%num_grid + IF (numinpm > 0) THEN + allocate (inpm_gdid (numinpm)) + inpm_gdid = remap_patch2inpm%ids_me + ELSE + allocate (inpm_gdid (0)) + ENDIF + ENDIF + + CALL build_mpas_embedded_local_ucats (parafile, nlon_ucat, nlat_ucat, numinpm, inpm_gdid) + + CALL ncio_inquire_varsize (parafile, 'inpmat_x', varsize) + IF (size(varsize) /= 2 .or. varsize(1) < 1 .or. varsize(2) /= totalnumucat) THEN + CALL CoLM_Stop ('ERROR: invalid inpmat_x dimensions in the embedded CoLM unit-catchment file.') + ENDIF + inpn = varsize(1) + deallocate (varsize) + + IF (.true.) THEN + IF (numucat > 0) THEN + CALL ncio_read_indexed_serial (parafile, 'inpmat_x', ucat_ucid, idmap_x) + CALL ncio_read_indexed_serial (parafile, 'inpmat_y', ucat_ucid, idmap_y) + CALL ncio_read_indexed_serial (parafile, 'inpmat_area', ucat_ucid, area_gd2uc) + CALL validate_mpas_embedded_inpmat (idmap_x, idmap_y, area_gd2uc, inpn, nlon_ucat, nlat_ucat) + + allocate (idmap_gd2uc (inpn,numucat)) + idmap_gd2uc = (idmap_y-1)*nlon_ucat + idmap_x + + WHERE ((area_gd2uc <= 0._r8) .or. (idmap_gd2uc <= 0)) + idmap_gd2uc = 0 + area_gd2uc = 0._r8 + END WHERE + + deallocate (idmap_x) + deallocate (idmap_y) + ELSE + allocate (idmap_gd2uc (inpn,0)) + allocate (area_gd2uc (inpn,0)) + ENDIF + + CALL build_mpas_embedded_uc2gd (parafile, nlon_ucat, nlat_ucat, inpn, numinpm, inpm_gdid, & + nucpart, idmap_uc2gd, area_uc2gd) + ENDIF + + IF (.true.) THEN + CALL build_compute_pushdata (numinpm, inpm_gdid, numucat, idmap_gd2uc, area_gd2uc, push_inpm2ucat) + CALL build_compute_pushdata (numucat, ucat_ucid, numinpm, idmap_uc2gd, area_uc2gd, push_ucat2inpm) + ENDIF + + CALL build_mpas_embedded_local_topology (parafile) + + IF (.true.) THEN + allocate (wts_ups (upnmax,numucat)) + IF (numucat > 0) wts_ups(:,:) = 1._r8 + + CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_next, push_next2ucat) + CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat ) + CALL check_mpas_embedded_topology_ownership () + ENDIF + + CALL build_mpas_embedded_river_systems (parafile) + + CALL readin_riverlake_parameter (parafile, 'topo_rivelv', rdata1d = topo_rivelv ) + CALL readin_riverlake_parameter (parafile, 'topo_rivhgt', rdata1d = topo_rivhgt ) + CALL readin_riverlake_parameter (parafile, 'topo_rivlen', rdata1d = topo_rivlen ) + CALL readin_riverlake_parameter (parafile, 'topo_rivman', rdata1d = topo_rivman ) + CALL readin_riverlake_parameter (parafile, 'topo_rivwth', rdata1d = topo_rivwth ) + CALL readin_riverlake_parameter (parafile, 'topo_rivstomax', rdata1d = topo_rivstomax) + CALL readin_riverlake_parameter (parafile, 'topo_area', rdata1d = topo_area ) + CALL readin_riverlake_parameter (parafile, 'topo_fldhgt', rdata2d = topo_fldhgt ) + CALL validate_mpas_embedded_river_parameters () + + IF (.true.) THEN + IF (numucat > 0) THEN + allocate (lake_type (numucat)) + lake_type(:) = 0 + + allocate (topo_rivare (numucat)) + topo_rivare = topo_rivstomax / topo_rivhgt + + allocate (floodplain_curve (numucat)) + DO i = 1, numucat + floodplain_curve(i)%nlfp = size(topo_fldhgt,1) + floodplain_curve(i)%rivhgt = topo_rivhgt(i) + floodplain_curve(i)%rivstomax = topo_rivstomax(i) + floodplain_curve(i)%rivare = topo_rivare(i) + + allocate (floodplain_curve(i)%flphgt (0:floodplain_curve(i)%nlfp)) + allocate (floodplain_curve(i)%flparea (0:floodplain_curve(i)%nlfp)) + allocate (floodplain_curve(i)%flpaccare (0:floodplain_curve(i)%nlfp)) + allocate (floodplain_curve(i)%flpstomax (0:floodplain_curve(i)%nlfp)) + + floodplain_curve(i)%flphgt(0) = 0._r8 + floodplain_curve(i)%flphgt(1:) = topo_fldhgt(:,i) + + floodplain_curve(i)%flparea(0) = 0._r8 + floodplain_curve(i)%flparea(1:) = topo_area(i) / real(floodplain_curve(i)%nlfp, r8) + + floodplain_curve(i)%flpaccare(0) = 0._r8 + DO j = 1, floodplain_curve(i)%nlfp + floodplain_curve(i)%flpaccare(j) = & + floodplain_curve(i)%flpaccare(j-1) + floodplain_curve(i)%flparea(j) + ENDDO + + floodplain_curve(i)%flpstomax(0) = 0._r8 + DO j = 1, floodplain_curve(i)%nlfp + floodplain_curve(i)%flpstomax(j) = floodplain_curve(i)%flpstomax(j-1) & + + 0.5_r8 * (floodplain_curve(i)%flparea(j) + floodplain_curve(i)%flparea(j-1)) & + * (floodplain_curve(i)%flphgt(j) - floodplain_curve(i)%flphgt(j-1)) + ENDDO + ENDDO + + allocate (bedelv_next (numucat)) + allocate (outletwth (numucat)) + ELSE + allocate (bedelv_next (0)) + allocate (outletwth (0)) + ENDIF + ENDIF + + CALL compute_push_data (push_next2ucat, topo_rivelv, bedelv_next, fillvalue = spval) + CALL compute_push_data (push_next2ucat, topo_rivwth, outletwth , fillvalue = spval) + + IF (.true.) THEN + IF (numucat > 0) THEN + WHERE (ucat_next > 0) + outletwth = (outletwth + topo_rivwth) * 0.5_r8 + ELSEWHERE + outletwth = topo_rivwth + END WHERE + ENDIF + + ENDIF + + END SUBROUTINE build_riverlake_network_mpas_embedded + + ! --------- + SUBROUTINE build_mpas_embedded_river_systems (parafile) + + USE MOD_MPAS_MPI + USE MOD_NetCDFSerial + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + + integer, allocatable :: mouth_id(:), next_id(:) + integer, allocatable :: request(:), request_order(:), request_next(:) + integer, allocatable :: local_mouths(:) + integer :: i, iloc, nactive, niter, nlocal_mouths + logical :: is_new + + IF (.not. .true.) RETURN + + allocate (irivsys (numucat)) + allocate (mouth_id (numucat)) + allocate (local_mouths (max(1,numucat))) + mouth_id(:) = 0 + + IF (numucat > 0) THEN + allocate (next_id (numucat)) + next_id = ucat_next + + DO i = 1, numucat + IF (next_id(i) <= 0) mouth_id(i) = ucat_ucid(i) + ENDDO + + nactive = count(next_id > 0) + niter = 0 + DO WHILE (nactive > 0) + niter = niter + 1 + IF (niter > totalnumucat) THEN + CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river network has a downstream cycle.') + ENDIF + + allocate (request (nactive)) + allocate (request_order (nactive)) + iloc = 0 + DO i = 1, numucat + IF (next_id(i) > 0) THEN + iloc = iloc + 1 + request(iloc) = next_id(i) + request_order(iloc) = i + ENDIF + ENDDO + + CALL quicksort (nactive, request, request_order) + CALL ncio_read_indexed_serial (parafile, 'seq_next', request, request_next) + + nactive = 0 + DO iloc = 1, size(request) + i = request_order(iloc) + IF (request_next(iloc) > 0) THEN + next_id(i) = request_next(iloc) + nactive = nactive + 1 + ELSE + mouth_id(i) = request(iloc) + next_id(i) = 0 + ENDIF + ENDDO + + deallocate (request) + deallocate (request_order) + deallocate (request_next) + ENDDO + + deallocate (next_id) + ENDIF + + nlocal_mouths = 0 + DO i = 1, numucat + CALL insert_into_sorted_list1 (mouth_id(i), nlocal_mouths, local_mouths, iloc, is_new) + ENDDO + + numrivsys = nlocal_mouths +#ifdef MPAS_MPI + CALL build_river_system_min_exchange(local_mouths(1:numrivsys)) +#endif + + DO i = 1, numucat + irivsys(i) = find_in_sorted_list1 (mouth_id(i), numrivsys, local_mouths(1:numrivsys)) + IF (irivsys(i) <= 0) CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river-system map is incomplete.') + ENDDO + + deallocate (mouth_id) + deallocate (local_mouths) + + END SUBROUTINE build_mpas_embedded_river_systems + +#ifdef MPAS_MPI + ! --------- + SUBROUTINE build_river_system_min_exchange(local_system_id) + + USE MOD_MPAS_MPI + USE MOD_Utils, only: quicksort + IMPLICIT NONE + + integer, intent(in) :: local_system_id(:) + + integer, allocatable :: next_position(:) + integer, allocatable :: recv_system_id(:) + integer, allocatable :: send_system_id(:) + integer, allocatable :: sorted_order(:) + integer, allocatable :: sorted_system_id(:) + integer :: i + integer :: irank + integer :: nrecv + integer :: owner + integer :: position + + IF (size(local_system_id) /= numrivsys) THEN + CALL CoLM_Stop('ERROR: local embedded CoLM river-system count is inconsistent.') + ENDIF + IF (numrivsys > 0) THEN + IF (any(local_system_id <= 0)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system IDs must be positive.') + ENDIF + IF (numrivsys > 1) THEN + IF (any(local_system_id(2:numrivsys) <= local_system_id(1:numrivsys-1))) THEN + CALL CoLM_Stop('ERROR: local embedded CoLM river-system IDs must be sorted and unique.') + ENDIF + ENDIF + ENDIF + IF (allocated(rivsys_send_counts) .or. allocated(rivsys_send_displs) .or. & + allocated(rivsys_recv_counts) .or. allocated(rivsys_recv_displs) .or. & + allocated(rivsys_send_local) .or. allocated(rivsys_recv_owner)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system exchange was initialized more than once.') + ENDIF + + allocate(rivsys_send_counts(0:mpas_size-1), rivsys_send_displs(0:mpas_size-1)) + allocate(rivsys_recv_counts(0:mpas_size-1), rivsys_recv_displs(0:mpas_size-1)) + rivsys_send_counts = 0 + DO i = 1, numrivsys + owner = modulo(local_system_id(i) - 1, mpas_size) + rivsys_send_counts(owner) = rivsys_send_counts(owner) + 1 + ENDDO + + rivsys_send_displs(0) = 0 + DO irank = 1, mpas_size-1 + rivsys_send_displs(irank) = rivsys_send_displs(irank-1) + rivsys_send_counts(irank-1) + ENDDO + + allocate(next_position(0:mpas_size-1)) + next_position = rivsys_send_displs + allocate(rivsys_send_local(numrivsys)) + allocate(send_system_id(max(1,numrivsys))) + DO i = 1, numrivsys + owner = modulo(local_system_id(i) - 1, mpas_size) + position = next_position(owner) + 1 + next_position(owner) = position + rivsys_send_local(position) = i + send_system_id(position) = local_system_id(i) + ENDDO + + CALL mpi_alltoall(rivsys_send_counts, 1, MPI_INTEGER, rivsys_recv_counts, 1, MPI_INTEGER, & + mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_Stop('ERROR: embedded CoLM river-system count exchange failed.') + + rivsys_recv_displs(0) = 0 + DO irank = 1, mpas_size-1 + rivsys_recv_displs(irank) = rivsys_recv_displs(irank-1) + rivsys_recv_counts(irank-1) + ENDDO + nrecv = sum(rivsys_recv_counts) + allocate(recv_system_id(max(1,nrecv))) + + CALL mpi_alltoallv(send_system_id, rivsys_send_counts, rivsys_send_displs, MPI_INTEGER, & + recv_system_id, rivsys_recv_counts, rivsys_recv_displs, MPI_INTEGER, & + mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_Stop('ERROR: embedded CoLM river-system ID exchange failed.') + + allocate(rivsys_recv_owner(nrecv)) + num_owned_rivsys = 0 + IF (nrecv > 0) THEN + IF (any(recv_system_id(1:nrecv) <= 0)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM received an invalid river-system ID.') + ENDIF + DO i = 1, nrecv + IF (modulo(recv_system_id(i) - 1, mpas_size) /= mpas_rank) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system request reached the wrong owner rank.') + ENDIF + ENDDO + + allocate(sorted_system_id(nrecv), sorted_order(nrecv)) + sorted_system_id = recv_system_id(1:nrecv) + sorted_order = (/(i, i = 1, nrecv)/) + IF (nrecv > 1) CALL quicksort(nrecv, sorted_system_id, sorted_order) + + DO i = 1, nrecv + IF (i == 1) THEN + num_owned_rivsys = num_owned_rivsys + 1 + ELSEIF (sorted_system_id(i) /= sorted_system_id(i-1)) THEN + num_owned_rivsys = num_owned_rivsys + 1 + ENDIF + rivsys_recv_owner(sorted_order(i)) = num_owned_rivsys + ENDDO + deallocate(sorted_system_id, sorted_order) + ENDIF + + deallocate(next_position, recv_system_id, send_system_id) + + END SUBROUTINE build_river_system_min_exchange + + ! --------- + SUBROUTINE synchronize_river_system_min(system_value) + + USE MOD_MPAS_MPI + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + real(r8), intent(inout) :: system_value(:) + + real(r8), allocatable :: owner_min(:) + real(r8), allocatable :: recv_value(:) + real(r8), allocatable :: return_value(:) + real(r8), allocatable :: send_value(:) + real(r8), allocatable :: synced_value(:) + integer :: i + integer :: nrecv + integer :: owner_index + + IF (size(system_value) < max(1,numrivsys)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system timestep array is too small.') + ENDIF + IF (.not. allocated(rivsys_send_counts) .or. .not. allocated(rivsys_send_displs) .or. & + .not. allocated(rivsys_recv_counts) .or. .not. allocated(rivsys_recv_displs) .or. & + .not. allocated(rivsys_send_local) .or. .not. allocated(rivsys_recv_owner)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system exchange is not initialized.') + ENDIF + IF (numrivsys > 0) THEN + IF (.not. all(ieee_is_finite(system_value(1:numrivsys))) .or. & + any(system_value(1:numrivsys) < 0._r8)) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system exchange received an invalid timestep.') + ENDIF + ENDIF + + nrecv = sum(rivsys_recv_counts) + allocate(send_value(max(1,numrivsys)), synced_value(max(1,numrivsys))) + allocate(recv_value(max(1,nrecv)), return_value(max(1,nrecv))) + allocate(owner_min(max(1,num_owned_rivsys))) + + DO i = 1, numrivsys + send_value(i) = system_value(rivsys_send_local(i)) + ENDDO + CALL mpi_alltoallv(send_value, rivsys_send_counts, rivsys_send_displs, MPI_REAL8, & + recv_value, rivsys_recv_counts, rivsys_recv_displs, MPI_REAL8, & + mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_Stop('ERROR: embedded CoLM river-system timestep exchange failed.') + + owner_min = huge(1._r8) + DO i = 1, nrecv + owner_index = rivsys_recv_owner(i) + IF (owner_index < 1 .or. owner_index > num_owned_rivsys) THEN + CALL CoLM_Stop('ERROR: embedded CoLM river-system owner address is invalid.') + ENDIF + owner_min(owner_index) = min(owner_min(owner_index), recv_value(i)) + ENDDO + DO i = 1, nrecv + return_value(i) = owner_min(rivsys_recv_owner(i)) + ENDDO + + CALL mpi_alltoallv(return_value, rivsys_recv_counts, rivsys_recv_displs, MPI_REAL8, & + synced_value, rivsys_send_counts, rivsys_send_displs, MPI_REAL8, & + mpas_comm, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_Stop('ERROR: embedded CoLM river-system timestep return exchange failed.') + + DO i = 1, numrivsys + system_value(rivsys_send_local(i)) = synced_value(i) + ENDDO + + deallocate(owner_min, recv_value, return_value, send_value, synced_value) + + END SUBROUTINE synchronize_river_system_min +#endif + + ! --------- + SUBROUTINE build_mpas_embedded_local_ucats (parafile, nlon_ucat, nlat_ucat, numinpm, inpm_gdid) + + USE MOD_MPAS_MPI + USE MOD_NetCDFSerial + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + integer, intent(in) :: nlon_ucat, nlat_ucat + integer, intent(in) :: numinpm + integer, intent(in) :: inpm_gdid(:) + + integer, parameter :: ucat_chunk_size = 131072 + integer, allocatable :: inpm_sorted(:), inpm_order(:) + integer, allocatable :: seq_x_blk(:), seq_y_blk(:) + integer, allocatable :: local_owner_blk(:), owner_blk(:) + integer :: istart, iend, iucat, iblk, iloc, grid_id, nfound + integer :: covered_count, global_owned + + IF (.not. .true.) RETURN + + IF (numinpm > 0) THEN + allocate (inpm_sorted (numinpm)) + allocate (inpm_order (numinpm)) + inpm_sorted = inpm_gdid + inpm_order = (/(iucat, iucat = 1, numinpm)/) + CALL quicksort (numinpm, inpm_sorted, inpm_order) + IF (any(inpm_sorted < 1) .or. any(inpm_sorted > nlon_ucat*nlat_ucat)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM runoff input grid contains an out-of-range grid ID.') + ENDIF + IF (numinpm > 1) THEN + IF (any(inpm_sorted(2:) == inpm_sorted(:numinpm-1))) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM runoff input grid contains duplicate local grid IDs.') + ENDIF + ENDIF + ENDIF + + nfound = 0 + covered_count = 0 + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_x', istart, iend, seq_x_blk) + CALL ncio_read_part_serial (parafile, 'seq_y', istart, iend, seq_y_blk) + IF (size(seq_x_blk) /= size(seq_y_blk)) THEN + CALL CoLM_Stop ('ERROR: seq_x and seq_y lengths differ in the embedded CoLM river network.') + ENDIF + IF (any(seq_x_blk < 1) .or. any(seq_x_blk > nlon_ucat) .or. & + any(seq_y_blk < 1) .or. any(seq_y_blk > nlat_ucat)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM unit-catchment coordinates are outside the runoff input grid.') + ENDIF + + allocate (local_owner_blk (size(seq_x_blk))) + allocate (owner_blk (size(seq_x_blk))) + local_owner_blk(:) = huge(1) + + DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) + iblk = iucat - lbound(seq_x_blk,1) + 1 + IF (numinpm > 0 .and. seq_x_blk(iucat) > 0 .and. seq_y_blk(iucat) > 0) THEN + grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) local_owner_blk(iblk) = mpas_rank + ENDIF + ENDDO + +#ifdef MPAS_MPI + CALL mpi_allreduce (local_owner_blk, owner_blk, size(local_owner_blk), MPI_INTEGER, & + MPI_MIN, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network first-pass ownership reduction') +#else + owner_blk = local_owner_blk +#endif + + covered_count = covered_count + count(owner_blk < huge(1)) + nfound = nfound + count(owner_blk == mpas_rank) + + deallocate (seq_x_blk) + deallocate (seq_y_blk) + deallocate (local_owner_blk) + deallocate (owner_blk) + istart = iend + 1 + ENDDO + +#ifdef MPAS_MPI + CALL mpi_allreduce (nfound, global_owned, 1, MPI_INTEGER, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network ownership-count reduction') +#else + global_owned = nfound +#endif + + IF (global_owned /= covered_count) THEN + IF (mpas_is_root) THEN + write(*,'(A,I0,A,I0)') 'ERROR: MPAS embedded CoLM river network covered ', covered_count, & + ' unit-catchment(s), but assigned ', global_owned + ENDIF + CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river network ownership partition is inconsistent.') + ENDIF + + numucat = nfound + allocate (ucat_ucid (numucat)) + + nfound = 0 + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_x', istart, iend, seq_x_blk) + CALL ncio_read_part_serial (parafile, 'seq_y', istart, iend, seq_y_blk) + IF (size(seq_x_blk) /= size(seq_y_blk)) THEN + CALL CoLM_Stop ('ERROR: seq_x and seq_y lengths differ in the embedded CoLM river network.') + ENDIF + IF (any(seq_x_blk < 1) .or. any(seq_x_blk > nlon_ucat) .or. & + any(seq_y_blk < 1) .or. any(seq_y_blk > nlat_ucat)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM unit-catchment coordinates are outside the runoff input grid.') + ENDIF + + allocate (local_owner_blk (size(seq_x_blk))) + allocate (owner_blk (size(seq_x_blk))) + local_owner_blk(:) = huge(1) + + DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) + iblk = iucat - lbound(seq_x_blk,1) + 1 + IF (numinpm > 0 .and. seq_x_blk(iucat) > 0 .and. seq_y_blk(iucat) > 0) THEN + grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) local_owner_blk(iblk) = mpas_rank + ENDIF + ENDDO + +#ifdef MPAS_MPI + CALL mpi_allreduce (local_owner_blk, owner_blk, size(local_owner_blk), MPI_INTEGER, & + MPI_MIN, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network final ownership reduction') +#else + owner_blk = local_owner_blk +#endif + + DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1) + iblk = iucat - lbound(seq_x_blk,1) + 1 + IF (owner_blk(iblk) == mpas_rank) THEN + grid_id = (seq_y_blk(iucat)-1) * nlon_ucat + seq_x_blk(iucat) + nfound = nfound + 1 + ucat_ucid(nfound) = istart + iucat - lbound(seq_x_blk,1) + ENDIF + ENDDO + + deallocate (seq_x_blk) + deallocate (seq_y_blk) + deallocate (local_owner_blk) + deallocate (owner_blk) + istart = iend + 1 + ENDDO + + IF (allocated(inpm_sorted)) deallocate (inpm_sorted) + IF (allocated(inpm_order )) deallocate (inpm_order ) + + END SUBROUTINE build_mpas_embedded_local_ucats + + SUBROUTINE build_mpas_embedded_local_topology (parafile) + + USE MOD_MPAS_MPI + USE MOD_NetCDFSerial + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + + integer, parameter :: ucat_chunk_size = 131072 + integer, allocatable :: ucat_sorted(:), ucat_order(:), ups_count(:), ups_fill(:) + integer, allocatable :: seq_next_blk(:) + integer :: istart, iend, iucat, iloc, idn, local_upnmax + + IF (.not. .true.) RETURN + + IF (numucat > 0) THEN + CALL ncio_read_indexed_serial (parafile, 'seq_next', ucat_ucid, ucat_next) + + allocate (ucat_sorted (numucat)) + allocate (ucat_order (numucat)) + allocate (ups_count (numucat)) + + ucat_sorted = ucat_ucid + ucat_order = (/(iucat, iucat = 1, numucat)/) + CALL quicksort (numucat, ucat_sorted, ucat_order) + + ups_count(:) = 0 + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_next', istart, iend, seq_next_blk) + CALL validate_mpas_embedded_seq_next (seq_next_blk, istart) + + DO iucat = lbound(seq_next_blk,1), ubound(seq_next_blk,1) + idn = seq_next_blk(iucat) + IF (idn > 0) THEN + iloc = find_in_sorted_list1 (idn, numucat, ucat_sorted) + IF (iloc > 0) ups_count(ucat_order(iloc)) = ups_count(ucat_order(iloc)) + 1 + ENDIF + ENDDO + + deallocate (seq_next_blk) + istart = iend + 1 + ENDDO + + local_upnmax = maxval(ups_count) + ELSE + allocate (ucat_next (0)) + local_upnmax = 0 + ENDIF + +#ifdef MPAS_MPI + CALL mpi_allreduce (local_upnmax, upnmax, 1, MPI_INTEGER, MPI_MAX, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network upstream-degree reduction') +#else + upnmax = local_upnmax +#endif + upnmax = max(1, upnmax) + + allocate (ucat_ups (upnmax,numucat)) + ucat_ups(:,:) = 0 + + IF (numucat > 0) THEN + allocate (ups_fill (numucat)) + ups_fill(:) = 0 + + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'seq_next', istart, iend, seq_next_blk) + + DO iucat = lbound(seq_next_blk,1), ubound(seq_next_blk,1) + idn = seq_next_blk(iucat) + IF (idn > 0) THEN + iloc = find_in_sorted_list1 (idn, numucat, ucat_sorted) + IF (iloc > 0) THEN + ups_fill(ucat_order(iloc)) = ups_fill(ucat_order(iloc)) + 1 + ucat_ups(ups_fill(ucat_order(iloc)), ucat_order(iloc)) = & + istart + iucat - lbound(seq_next_blk,1) + ENDIF + ENDIF + ENDDO + + deallocate (seq_next_blk) + istart = iend + 1 + ENDDO + + deallocate (ups_fill) + deallocate (ups_count) + deallocate (ucat_sorted) + deallocate (ucat_order) + ENDIF + + END SUBROUTINE build_mpas_embedded_local_topology + + ! --------- + SUBROUTINE validate_mpas_embedded_seq_next (seq_next, first_id) + + USE MOD_MPAS_MPI, only: CoLM_Stop + IMPLICIT NONE + + integer, intent(in) :: seq_next(:) + integer, intent(in) :: first_id + integer :: i, source_id + + IF (any(seq_next > totalnumucat)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM seq_next contains an out-of-range unit-catchment ID.') + ENDIF + IF (any(seq_next <= 0 .and. seq_next /= -9 .and. seq_next /= -10 .and. seq_next /= -99)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM seq_next contains an unsupported outlet code.') + ENDIF + DO i = 1, size(seq_next) + source_id = first_id + i - 1 + IF (seq_next(i) == source_id) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM seq_next contains a self-loop.') + ENDIF + ENDDO + + END SUBROUTINE validate_mpas_embedded_seq_next + + ! --------- + SUBROUTINE check_mpas_embedded_topology_ownership () + + USE MOD_MPAS_MPI + IMPLICIT NONE + + integer, allocatable :: next_owner_count(:) + integer, allocatable :: ups_owner_count(:) + integer :: i, iup, irank, ireq + integer :: local_bad, global_bad + integer :: first_bad, global_first_bad + + IF (.not. .true.) RETURN + + local_bad = 0 + first_bad = huge(1) + + allocate (next_owner_count(push_next2ucat%num_req_uniq)) + next_owner_count(:) = 0 + DO i = 1, push_next2ucat%nself + ireq = push_next2ucat%self_to(i) + next_owner_count(ireq) = next_owner_count(ireq) + 1 + ENDDO +#ifdef MPAS_MPI + DO irank = 0, mpas_size-1 + DO i = 1, push_next2ucat%n_from_other(irank) + ireq = push_next2ucat%other_to(irank)%val(i) + next_owner_count(ireq) = next_owner_count(ireq) + 1 + ENDDO + ENDDO +#endif + + allocate (ups_owner_count(push_ups2ucat%num_req_uniq)) + ups_owner_count(:) = 0 + DO i = 1, push_ups2ucat%nself + ireq = push_ups2ucat%self_to(i) + ups_owner_count(ireq) = ups_owner_count(ireq) + 1 + ENDDO +#ifdef MPAS_MPI + DO irank = 0, mpas_size-1 + DO i = 1, push_ups2ucat%n_from_other(irank) + ireq = push_ups2ucat%other_to(irank)%val(i) + ups_owner_count(ireq) = ups_owner_count(ireq) + 1 + ENDDO + ENDDO +#endif + + DO i = 1, numucat + IF (ucat_next(i) > 0) THEN + ireq = push_next2ucat%addr_single(i) + IF (ireq <= 0 .or. ireq > size(next_owner_count)) THEN + local_bad = local_bad + 1 + first_bad = min(first_bad, ucat_next(i)) + ELSEIF (next_owner_count(ireq) /= 1) THEN + local_bad = local_bad + 1 + first_bad = min(first_bad, ucat_next(i)) + ENDIF + ENDIF + + DO iup = 1, upnmax + IF (ucat_ups(iup,i) > 0) THEN + ireq = push_ups2ucat%addr_multi(iup,i) + IF (ireq <= 0 .or. ireq > size(ups_owner_count)) THEN + local_bad = local_bad + 1 + first_bad = min(first_bad, ucat_ups(iup,i)) + ELSEIF (ups_owner_count(ireq) /= 1) THEN + local_bad = local_bad + 1 + first_bad = min(first_bad, ucat_ups(iup,i)) + ENDIF + ENDIF + ENDDO + ENDDO + + deallocate (next_owner_count) + deallocate (ups_owner_count) + +#ifdef MPAS_MPI + CALL mpi_allreduce (local_bad, global_bad, 1, MPI_INTEGER, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network invalid-owner count reduction') + CALL mpi_allreduce (first_bad, global_first_bad, 1, MPI_INTEGER, MPI_MIN, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network first invalid-owner reduction') +#else + global_bad = local_bad + global_first_bad = first_bad +#endif + + IF (global_bad > 0) THEN + IF (mpas_is_root) THEN + write(*,'(A,I0,A,I0)') 'ERROR: MPAS embedded CoLM GridRiverLakeFlow has ', & + global_bad, ' non-unique or missing topology owner reference(s); first unit-catchment ID = ', & + global_first_bad + ENDIF + CALL CoLM_Stop ('ERROR: MPAS domain/landdata must contain exactly one owner for every upstream and downstream unit catchment.') + ENDIF + + END SUBROUTINE check_mpas_embedded_topology_ownership + + ! --------- + SUBROUTINE validate_mpas_embedded_inpmat (idmap_x, idmap_y, area, inpn, nlon_ucat, nlat_ucat) + + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + USE MOD_MPAS_MPI, only: CoLM_Stop + IMPLICIT NONE + + integer, intent(in) :: idmap_x(:,:), idmap_y(:,:) + real(r8), intent(in) :: area(:,:) + integer, intent(in) :: inpn, nlon_ucat, nlat_ucat + integer :: first_map + integer :: grid_id + integer :: imap + integer :: imap_other + integer :: iucat + + IF (size(idmap_x,1) /= inpn .or. size(idmap_y,1) /= inpn .or. size(area,1) /= inpn .or. & + size(idmap_x,2) /= size(idmap_y,2) .or. size(idmap_x,2) /= size(area,2)) THEN + CALL CoLM_Stop ('ERROR: inconsistent inpmat dimensions in the embedded CoLM unit-catchment file.') + ENDIF + IF (.not. all(ieee_is_finite(area))) THEN + CALL CoLM_Stop ('ERROR: non-finite inpmat_area in the embedded CoLM unit-catchment file.') + ENDIF + IF (any(area < 0._r8)) THEN + CALL CoLM_Stop ('ERROR: negative inpmat_area in the embedded CoLM unit-catchment file.') + ENDIF + IF (any((area > 0._r8) .and. & + (idmap_x < 1 .or. idmap_x > nlon_ucat .or. idmap_y < 1 .or. idmap_y > nlat_ucat))) THEN + CALL CoLM_Stop ('ERROR: positive unit-catchment overlap area has an out-of-range runoff grid index.') + ENDIF + DO iucat = 1, size(area,2) + first_map = 0 + DO imap = 1, inpn + IF (area(imap,iucat) <= 0._r8) CYCLE + IF (first_map == 0) first_map = imap + grid_id = (idmap_y(imap,iucat)-1) * nlon_ucat + idmap_x(imap,iucat) + DO imap_other = imap + 1, inpn + IF (area(imap_other,iucat) <= 0._r8) CYCLE + IF ((idmap_y(imap_other,iucat)-1) * nlon_ucat + idmap_x(imap_other,iucat) == grid_id) THEN + CALL CoLM_Stop ('ERROR: a unit catchment maps to the same runoff grid more than once.') + ENDIF + ENDDO + ENDDO + IF (first_map == 0) THEN + CALL CoLM_Stop ('ERROR: a unit catchment has no positive runoff-grid overlap area.') + ENDIF + ENDDO + + END SUBROUTINE validate_mpas_embedded_inpmat + + ! --------- + SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, nlat_ucat, inpn, numinpm, inpm_gdid, & + nucpart, idmap_uc2gd, area_uc2gd) + + USE MOD_MPAS_MPI + USE MOD_NetCDFSerial + USE MOD_Utils + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + integer, intent(in) :: nlon_ucat, nlat_ucat + integer, intent(in) :: inpn + integer, intent(in) :: numinpm + integer, intent(in) :: inpm_gdid(:) + integer, intent(out) :: nucpart + integer, allocatable, intent(out) :: idmap_uc2gd(:,:) + real(r8), allocatable, intent(out) :: area_uc2gd(:,:) + + integer, parameter :: ucat_chunk_size = 131072 + integer, allocatable :: inpm_sorted(:), inpm_order(:), nucat_g(:) + integer, allocatable :: idmap_x_blk(:,:), idmap_y_blk(:,:) + real(r8), allocatable :: area_blk(:,:) + integer :: istart, iend, iucat, imap, iloc, igrd, grid_id + integer :: nucpart_local + + IF (numinpm > 0) THEN + allocate (inpm_sorted (numinpm)) + allocate (inpm_order (numinpm)) + allocate (nucat_g (numinpm)) + + inpm_sorted = inpm_gdid + inpm_order = (/(igrd, igrd = 1, numinpm)/) + CALL quicksort (numinpm, inpm_sorted, inpm_order) + nucat_g = 0 + + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'inpmat_x', (/1,istart/), (/inpn,iend/), idmap_x_blk) + CALL ncio_read_part_serial (parafile, 'inpmat_y', (/1,istart/), (/inpn,iend/), idmap_y_blk) + CALL ncio_read_part_serial (parafile, 'inpmat_area', (/1,istart/), (/inpn,iend/), area_blk) + CALL validate_mpas_embedded_inpmat (idmap_x_blk, idmap_y_blk, area_blk, inpn, nlon_ucat, nlat_ucat) + + DO iucat = lbound(idmap_x_blk,2), ubound(idmap_x_blk,2) + DO imap = 1, inpn + IF (area_blk(imap,iucat) > 0._r8 .and. idmap_x_blk(imap,iucat) > 0 .and. & + idmap_y_blk(imap,iucat) > 0) THEN + grid_id = (idmap_y_blk(imap,iucat)-1) * nlon_ucat + idmap_x_blk(imap,iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) THEN + igrd = inpm_order(iloc) + nucat_g(igrd) = nucat_g(igrd) + 1 + ENDIF + ENDIF + ENDDO + ENDDO + + deallocate (idmap_x_blk) + deallocate (idmap_y_blk) + deallocate (area_blk) + istart = iend + 1 + ENDDO + + nucpart_local = maxval(nucat_g) + ELSE + nucpart_local = 0 + ENDIF + +#ifdef MPAS_MPI + CALL mpi_allreduce (nucpart_local, nucpart, 1, MPI_INTEGER, MPI_MAX, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-network unit-overlap reduction') +#else + nucpart = nucpart_local +#endif + nucpart = max(1, nucpart) + + allocate (idmap_uc2gd (nucpart,numinpm)) + allocate (area_uc2gd (nucpart,numinpm)) + idmap_uc2gd = 0 + area_uc2gd = 0._r8 + + IF (numinpm > 0 .and. nucpart > 0) THEN + nucat_g = 0 + + istart = 1 + DO WHILE (istart <= totalnumucat) + iend = min(istart + ucat_chunk_size - 1, totalnumucat) + CALL ncio_read_part_serial (parafile, 'inpmat_x', (/1,istart/), (/inpn,iend/), idmap_x_blk) + CALL ncio_read_part_serial (parafile, 'inpmat_y', (/1,istart/), (/inpn,iend/), idmap_y_blk) + CALL ncio_read_part_serial (parafile, 'inpmat_area', (/1,istart/), (/inpn,iend/), area_blk) + CALL validate_mpas_embedded_inpmat (idmap_x_blk, idmap_y_blk, area_blk, inpn, nlon_ucat, nlat_ucat) + + DO iucat = lbound(idmap_x_blk,2), ubound(idmap_x_blk,2) + DO imap = 1, inpn + IF (area_blk(imap,iucat) > 0._r8 .and. idmap_x_blk(imap,iucat) > 0 .and. & + idmap_y_blk(imap,iucat) > 0) THEN + grid_id = (idmap_y_blk(imap,iucat)-1) * nlon_ucat + idmap_x_blk(imap,iucat) + iloc = find_in_sorted_list1 (grid_id, numinpm, inpm_sorted) + IF (iloc > 0) THEN + igrd = inpm_order(iloc) + nucat_g(igrd) = nucat_g(igrd) + 1 + idmap_uc2gd(nucat_g(igrd),igrd) = & + istart + iucat - lbound(idmap_x_blk,2) + area_uc2gd (nucat_g(igrd),igrd) = area_blk(imap,iucat) + ENDIF + ENDIF + ENDDO + ENDDO + + deallocate (idmap_x_blk) + deallocate (idmap_y_blk) + deallocate (area_blk) + istart = iend + 1 + ENDDO + ENDIF + + IF (allocated(inpm_sorted)) deallocate (inpm_sorted) + IF (allocated(inpm_order )) deallocate (inpm_order ) + IF (allocated(nucat_g )) deallocate (nucat_g ) + + END SUBROUTINE build_mpas_embedded_uc2gd +#endif + + ! --------- + SUBROUTINE validate_mpas_embedded_river_parameters () + + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + USE MOD_MPAS_MPI, only: CoLM_Stop + IMPLICIT NONE + + integer :: j + + IF (.not. .true. .or. numucat <= 0) RETURN + + IF (.not. allocated(topo_rivelv) .or. .not. allocated(topo_rivhgt) .or. & + .not. allocated(topo_rivlen) .or. .not. allocated(topo_rivman) .or. & + .not. allocated(topo_rivwth) .or. .not. allocated(topo_rivstomax) .or. & + .not. allocated(topo_area) .or. .not. allocated(topo_fldhgt)) THEN + CALL CoLM_Stop ('ERROR: incomplete embedded CoLM river parameter data.') + ENDIF + IF (size(topo_rivelv) /= numucat .or. size(topo_rivhgt) /= numucat .or. & + size(topo_rivlen) /= numucat .or. size(topo_rivman) /= numucat .or. & + size(topo_rivwth) /= numucat .or. size(topo_rivstomax) /= numucat .or. & + size(topo_area) /= numucat .or. size(topo_fldhgt,2) /= numucat .or. & + size(topo_fldhgt,1) < 1) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM river parameter dimensions do not match local unit catchments.') + ENDIF + IF (.not. all(ieee_is_finite(topo_rivelv)) .or. .not. all(ieee_is_finite(topo_rivhgt)) .or. & + .not. all(ieee_is_finite(topo_rivlen)) .or. .not. all(ieee_is_finite(topo_rivman)) .or. & + .not. all(ieee_is_finite(topo_rivwth)) .or. .not. all(ieee_is_finite(topo_rivstomax)) .or. & + .not. all(ieee_is_finite(topo_area)) .or. .not. all(ieee_is_finite(topo_fldhgt))) THEN + CALL CoLM_Stop ('ERROR: non-finite embedded CoLM river parameter data.') + ENDIF + IF (any(topo_rivhgt <= 0._r8) .or. any(topo_rivlen <= 0._r8) .or. & + any(topo_rivman <= 0._r8) .or. any(topo_rivwth <= 0._r8) .or. & + any(topo_rivstomax <= 0._r8) .or. any(topo_area <= 0._r8)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM river geometry and roughness parameters must be positive.') + ENDIF + IF (any(topo_fldhgt(1,:) <= 0._r8)) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM floodplain heights must start above the river bank.') + ENDIF + DO j = 2, size(topo_fldhgt,1) + IF (any(topo_fldhgt(j,:) <= topo_fldhgt(j-1,:))) THEN + CALL CoLM_Stop ('ERROR: embedded CoLM floodplain heights must be strictly increasing.') + ENDIF + ENDDO + + END SUBROUTINE validate_mpas_embedded_river_parameters + + ! --------- + SUBROUTINE readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idata1d) + + USE MOD_MPAS_MPI, only: mpas_comm, mpas_mpi_ierr, mpas_mpi_check + USE MOD_NetCDFSerial, only: ncio_read_indexed_serial + IMPLICIT NONE + + character(len=*), intent(in) :: parafile + character(len=*), intent(in) :: varname + real(r8), allocatable, intent(inout), optional :: rdata1d (:) + real(r8), allocatable, intent(inout), optional :: rdata2d (:,:) + integer, allocatable, intent(inout), optional :: idata1d (:) + + IF (.true.) THEN + IF (present(rdata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata1d) + IF (present(rdata2d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, rdata2d) + IF (present(idata1d)) CALL ncio_read_indexed_serial (parafile, varname, ucat_ucid, idata1d) + ENDIF + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('river-parameter indexed read completion') + + END SUBROUTINE readin_riverlake_parameter + + ! + FUNCTION retrieve_depth_from_volume (this, volume) result(depth) + + IMPLICIT NONE + + class(vol_dep_curve_type) :: this + real(r8), intent(in) :: volume + real(r8) :: depth + + ! Local Variables + real(r8) :: v0, g + integer :: i + + v0 = volume - this%rivstomax + IF (v0 <= 0) THEN + depth = volume / this%rivare + ELSE + i = 1 + DO WHILE (i <= this%nlfp) + IF (v0 > this%flpstomax(i)) THEN + i = i + 1 + ELSE + EXIT + ENDIF + ENDDO + + IF (i == this%nlfp+1) THEN + depth = this%rivhgt + this%flphgt(this%nlfp) & + + (v0-this%flpstomax(this%nlfp)) / this%flpaccare(this%nlfp) + ELSE + g = (this%flphgt(i)-this%flphgt(i-1))/this%flparea(i) + depth = this%rivhgt + this%flphgt(i-1) & + + g * (-this%flpaccare(i-1)+sqrt((this%flpaccare(i-1))**2+2*(v0-this%flpstomax(i-1))/g)) + ENDIF + ENDIF + + END FUNCTION retrieve_depth_from_volume + + ! + FUNCTION retrieve_volume_from_depth (this, depth) result(volume) + + IMPLICIT NONE + + class(vol_dep_curve_type) :: this + real(r8), intent(in) :: depth + real(r8) :: volume + + ! Local Variables + real(r8) :: h, d + integer :: i + + IF (depth <= this%rivhgt) THEN + volume = this%rivare * depth + ELSE + i = 1 + DO WHILE (i <= this%nlfp) + IF (depth > this%rivhgt+this%flphgt(i)) THEN + i = i + 1 + ELSE + EXIT + ENDIF + ENDDO + + d = depth - this%rivhgt - this%flphgt(i-1) + IF (i == this%nlfp+1) THEN + volume = this%rivstomax + this%flpstomax(this%nlfp) + d * this%flpaccare(this%nlfp) + ELSE + h = this%flphgt(i)-this%flphgt(i-1) + volume = this%rivstomax + this%flpstomax(i-1) & + + (d/h*this%flparea(i)+2*this%flpaccare(i-1))*d*0.5 + ENDIF + ENDIF + + END FUNCTION retrieve_volume_from_depth + + ! + FUNCTION retrieve_area_from_depth (this, depth) result(area) + + IMPLICIT NONE + + class(vol_dep_curve_type) :: this + real(r8), intent(in) :: depth + real(r8) :: area + + ! Local Variables + real(r8) :: h, d + integer :: i + + IF (depth <= this%rivhgt) THEN + area = 0. + ELSE + i = 1 + DO WHILE (i <= this%nlfp) + IF (depth > this%rivhgt+this%flphgt(i)) THEN + i = i + 1 + ELSE + EXIT + ENDIF + ENDDO + + IF (i == this%nlfp+1) THEN + area = this%flpaccare(this%nlfp) + ELSE + h = this%flphgt(i)-this%flphgt(i-1) + d = depth - this%rivhgt - this%flphgt(i-1) + area = this%flpaccare(i-1) + d/h * this%flparea(i) + ENDIF + ENDIF + + END FUNCTION retrieve_area_from_depth + + ! --- + SUBROUTINE vol_depth_curve_free_mem (this) + + IMPLICIT NONE + type(vol_dep_curve_type) :: this + + IF (allocated(this%flphgt )) deallocate (this%flphgt ) + IF (allocated(this%flparea )) deallocate (this%flparea ) + IF (allocated(this%flpaccare)) deallocate (this%flpaccare) + IF (allocated(this%flpstomax)) deallocate (this%flpstomax) + + END SUBROUTINE vol_depth_curve_free_mem + + ! --------- + SUBROUTINE riverlake_network_final () + + IMPLICIT NONE + + IF (allocated(ucat_ucid )) deallocate(ucat_ucid ) + + IF (allocated(inpm_gdid )) deallocate(inpm_gdid ) + IF (allocated(idmap_gd2uc )) deallocate(idmap_gd2uc ) + IF (allocated(area_gd2uc )) deallocate(area_gd2uc ) + IF (allocated(idmap_uc2gd )) deallocate(idmap_uc2gd ) + IF (allocated(area_uc2gd )) deallocate(area_uc2gd ) + IF (allocated(ucat_next )) deallocate(ucat_next ) + IF (allocated(ucat_ups )) deallocate(ucat_ups ) + IF (allocated(wts_ups )) deallocate(wts_ups ) + IF (allocated(irivsys )) deallocate(irivsys ) +#ifdef MPAS_MPI + IF (allocated(rivsys_send_counts)) deallocate(rivsys_send_counts) + IF (allocated(rivsys_send_displs)) deallocate(rivsys_send_displs) + IF (allocated(rivsys_recv_counts)) deallocate(rivsys_recv_counts) + IF (allocated(rivsys_recv_displs)) deallocate(rivsys_recv_displs) + IF (allocated(rivsys_send_local )) deallocate(rivsys_send_local ) + IF (allocated(rivsys_recv_owner )) deallocate(rivsys_recv_owner ) +#endif + + IF (allocated(topo_rivelv )) deallocate(topo_rivelv ) + IF (allocated(topo_rivhgt )) deallocate(topo_rivhgt ) + IF (allocated(topo_rivlen )) deallocate(topo_rivlen ) + IF (allocated(topo_rivman )) deallocate(topo_rivman ) + IF (allocated(topo_rivwth )) deallocate(topo_rivwth ) + IF (allocated(topo_rivare )) deallocate(topo_rivare ) + IF (allocated(topo_rivstomax )) deallocate(topo_rivstomax ) + IF (allocated(topo_area )) deallocate(topo_area ) + IF (allocated(topo_fldhgt )) deallocate(topo_fldhgt ) + IF (allocated(bedelv_next )) deallocate(bedelv_next ) + IF (allocated(outletwth )) deallocate(outletwth ) + + IF (allocated(floodplain_curve )) deallocate(floodplain_curve ) + + CALL grid_free_mem(griducat) + CALL compute_remapdata_free_mem(remap_patch2inpm) + CALL compute_pushdata_free_mem(push_inpm2ucat) + CALL compute_pushdata_free_mem(push_ucat2inpm) + CALL compute_pushdata_free_mem(push_next2ucat) + CALL compute_pushdata_free_mem(push_ups2ucat) + + totalnumucat = 0 + numucat = 0 + numinpm = 0 + inpn = 0 + nucpart = 0 + upnmax = 0 + numrivsys = 0 +#ifdef MPAS_MPI + num_owned_rivsys = 0 +#endif + + END SUBROUTINE riverlake_network_final + +END MODULE MOD_Grid_RiverLakeNetwork +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 new file mode 100644 index 0000000000..1b2a91920c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90 @@ -0,0 +1,494 @@ +#include + +#ifdef GridRiverLakeFlow +MODULE MOD_Grid_RiverLakeTimeVars +!------------------------------------------------------------------------------------- +! DESCRIPTION: +! +! Time Variables in gridded hydrological processes. +! +! Created by Shupeng Zhang, Oct 2025 +!------------------------------------------------------------------------------------- + + USE MOD_Precision +#ifdef GridRiverLakeSediment + USE MOD_Grid_RiverLakeSediment, only: write_sediment_restart +#endif + IMPLICIT NONE + + ! -- state variables -- + real(r8), allocatable :: wdsrf_ucat (:) ! river or lake water depth [m] + real(r8), allocatable :: veloc_riv (:) ! river velocity [m/s] + real(r8), allocatable :: discharge_riv (:) ! routing-period mean downstream discharge [m3/s] + real(r8), allocatable :: momen_riv (:) ! unit river momentum [m^2/s] + real(r8), allocatable :: volresv (:) ! reservoir water volume [m^3] + real(r8) :: acctime_rnof = 0._r8 + real(r8), allocatable :: acc_rnof_uc (:) ! accumulated runoff volume [m^3] + + ! Area-weighted diagnostics on the local CoLM element/MPAS-cell mesh. + real(r8), allocatable :: river_water_depth_elm (:) + real(r8), allocatable :: river_velocity_elm (:) + real(r8), allocatable :: river_discharge_elm (:) + + ! -- restart file path (saved for deferred sediment restart read) -- + character(len=512) :: gridriver_restart_file = '' + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_GridRiverLakeTimeVars + PUBLIC :: deallocate_GridRiverLakeTimeVars + + PUBLIC :: read_GridRiverLakeTimeVars + PUBLIC :: write_GridRiverLakeTimeVars + PUBLIC :: update_GridRiverLakeElementDiagnostics + +CONTAINS + + SUBROUTINE allocate_GridRiverLakeTimeVars + + USE MOD_MPAS_MPI + USE MOD_Grid_RiverLakeNetwork, only: numucat + USE MOD_Grid_Reservoir, only: numresv + USE MOD_Mesh, only: numelm + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + IF (.true.) THEN + IF (numucat < 0 .or. numresv < 0) THEN + CALL CoLM_stop('Cannot allocate embedded CoLM river state with negative local dimensions.') + ENDIF + IF (allocated(wdsrf_ucat) .or. allocated(veloc_riv) .or. allocated(discharge_riv) .or. & + allocated(momen_riv) .or. allocated(volresv) .or. allocated(acc_rnof_uc) .or. & + allocated(river_water_depth_elm) .or. allocated(river_velocity_elm) .or. & + allocated(river_discharge_elm)) THEN + CALL CoLM_stop('Embedded CoLM river state was allocated more than once.') + ENDIF + + allocate (wdsrf_ucat (numucat)) + allocate (veloc_riv (numucat)) + allocate (discharge_riv(numucat)) + allocate (momen_riv (numucat)) + allocate (volresv (numresv)) + allocate (acc_rnof_uc(numucat)) + allocate (river_water_depth_elm(numelm)) + allocate (river_velocity_elm (numelm)) + allocate (river_discharge_elm (numelm)) + wdsrf_ucat = 0._r8 + veloc_riv = 0._r8 + discharge_riv = 0._r8 + momen_riv = 0._r8 + volresv = spval + acc_rnof_uc = 0._r8 + river_water_depth_elm = spval + river_velocity_elm = spval + river_discharge_elm = spval + acctime_rnof = 0._r8 + + ENDIF + + END SUBROUTINE allocate_GridRiverLakeTimeVars + + + SUBROUTINE READ_GridRiverLakeTimeVars (file_restart, require_complete_restart) + + USE MOD_MPAS_MPI + USE MOD_Namelist + USE MOD_NetCDFSerial, only: ncio_read_bcast_serial, ncio_read_indexed_serial, ncio_var_exist + USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_ucid + USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_global_index + USE MOD_Vars_Global, only: spval + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + logical, intent(in) :: require_complete_restart + logical :: has_acc_rnof + logical :: has_acctime_rnof + logical :: has_discharge + + gridriver_restart_file = trim(file_restart) + has_acc_rnof = ncio_var_exist(file_restart, 'acc_rnof_uc', .false.) + has_acctime_rnof = ncio_var_exist(file_restart, 'acctime_rnof', .false.) + has_discharge = ncio_var_exist(file_restart, 'discharge_riv', .false.) + + IF (.true.) THEN + CALL validate_gridriver_indices(ucat_ucid, numucat, totalnumucat, 'unit-catchment') + ENDIF + IF (.true. .and. numucat > 0) THEN + CALL ncio_read_indexed_serial (file_restart, 'wdsrf_ucat', ucat_ucid, wdsrf_ucat) + CALL ncio_read_indexed_serial (file_restart, 'veloc_riv', ucat_ucid, veloc_riv ) + IF (has_discharge) CALL ncio_read_indexed_serial (file_restart, 'discharge_riv', ucat_ucid, discharge_riv) + IF (has_acc_rnof) CALL ncio_read_indexed_serial (file_restart, 'acc_rnof_uc', ucat_ucid, acc_rnof_uc) + ENDIF + IF (has_acctime_rnof) CALL ncio_read_bcast_serial (file_restart, 'acctime_rnof', acctime_rnof) + IF (.not. has_acc_rnof .or. .not. has_acctime_rnof) THEN + IF (require_complete_restart) THEN + IF (mpas_is_root) THEN + write(*,'(A)') 'CoLM river restart is missing runoff-accumulator state required for water-continuous restart.' + ENDIF + CALL CoLM_stop('Use a restart containing acc_rnof_uc and acctime_rnof, or start a new simulation.') + ELSE + acc_rnof_uc = 0._r8 + acctime_rnof = 0._r8 + IF (mpas_is_root) THEN + write(*,'(A)') 'Initializing CoLM river runoff accumulators to zero from legacy cold-start data.' + ENDIF + ENDIF + ENDIF + IF (.not. ieee_is_finite(acctime_rnof) .or. acctime_rnof < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river restart contains an invalid runoff accumulation time.') + ENDIF + IF (.true. .and. numucat > 0) THEN + IF (.not. all(ieee_is_finite(wdsrf_ucat)) .or. any(wdsrf_ucat < 0._r8) .or. & + .not. all(ieee_is_finite(veloc_riv)) .or. .not. all(ieee_is_finite(discharge_riv)) .or. & + .not. all(ieee_is_finite(acc_rnof_uc)) .or. & + any(acc_rnof_uc < 0._r8)) THEN + CALL CoLM_stop('Embedded CoLM river restart contains invalid unit-catchment state.') + ENDIF + ENDIF + + IF (DEF_Reservoir_Method > 0) THEN + IF (totalnumresv > 0) THEN + IF (.true. .and. numresv > 0) THEN + CALL validate_gridriver_indices(resv_global_index, numresv, totalnumresv, 'reservoir') + CALL ncio_read_indexed_serial (file_restart, 'volresv', resv_global_index(1:numresv), volresv) + IF (.not. all(ieee_is_finite(volresv)) .or. & + any(volresv < 0._r8 .and. abs(volresv) < 0.5_r8 * abs(spval))) THEN + CALL CoLM_stop('Embedded CoLM river restart contains invalid reservoir storage.') + ENDIF + ENDIF + ENDIF + ENDIF + + CALL update_GridRiverLakeElementDiagnostics() + + ! Note: sediment restart is read separately in grid_sediment_read_restart, + ! called from grid_riverlake_flow_init after sediment module is initialized. + + END SUBROUTINE READ_GridRiverLakeTimeVars + + + SUBROUTINE WRITE_GridRiverLakeTimeVars (file_restart) + + USE MOD_MPAS_MPI + USE MOD_Namelist + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + CALL write_gridriver_restart_mpas_embedded (file_restart) + +#ifdef GridRiverLakeSediment + IF (DEF_USE_SEDIMENT) THEN + CALL write_sediment_restart(file_restart) + ENDIF +#endif + + END SUBROUTINE WRITE_GridRiverLakeTimeVars + + SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart) + + USE mpi, only: MPI_INFO_NULL, MPI_OFFSET_KIND + USE pnetcdf + USE MOD_MPAS_MPI, only: mpas_comm, mpas_rank, CoLM_stop + USE MOD_Namelist, only: DEF_Reservoir_Method + USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_ucid + USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_global_index + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + integer :: ierr + integer :: ncid + integer :: dim_ucatch + integer :: dim_reservoir + integer :: var_wdsrf + integer :: var_veloc + integer :: var_discharge + integer :: var_acc_rnof + integer :: var_acctime_rnof + integer :: var_volresv + logical :: write_reservoir + + write_reservoir = DEF_Reservoir_Method > 0 .and. totalnumresv > 0 + + IF (totalnumucat < 1) THEN + CALL CoLM_stop('Cannot write an embedded CoLM river restart with no global unit catchments.') + ENDIF + CALL validate_gridriver_indices(ucat_ucid, numucat, totalnumucat, 'unit-catchment') + IF (write_reservoir) THEN + CALL validate_gridriver_indices(resv_global_index, numresv, totalnumresv, 'reservoir') + ENDIF + + ierr = nf90mpi_create(mpas_comm, trim(file_restart), & + IOR(NF90_CLOBBER, NF90_64BIT_OFFSET), MPI_INFO_NULL, ncid) + CALL pnetcdf_check(ierr, 'create', file_restart) + + ierr = nf90mpi_def_dim(ncid, 'ucatch', int(totalnumucat, MPI_OFFSET_KIND), dim_ucatch) + CALL pnetcdf_check(ierr, 'define ucatch dimension', file_restart) + + ierr = nf90mpi_def_var(ncid, 'wdsrf_ucat', NF90_DOUBLE, (/dim_ucatch/), var_wdsrf) + CALL pnetcdf_check(ierr, 'define wdsrf_ucat', file_restart) + + ierr = nf90mpi_def_var(ncid, 'veloc_riv', NF90_DOUBLE, (/dim_ucatch/), var_veloc) + CALL pnetcdf_check(ierr, 'define veloc_riv', file_restart) + + ierr = nf90mpi_def_var(ncid, 'discharge_riv', NF90_DOUBLE, (/dim_ucatch/), var_discharge) + CALL pnetcdf_check(ierr, 'define discharge_riv', file_restart) + + ierr = nf90mpi_def_var(ncid, 'acc_rnof_uc', NF90_DOUBLE, (/dim_ucatch/), var_acc_rnof) + CALL pnetcdf_check(ierr, 'define acc_rnof_uc', file_restart) + + ierr = nf90mpi_def_var(ncid, 'acctime_rnof', NF90_DOUBLE, varid = var_acctime_rnof) + CALL pnetcdf_check(ierr, 'define acctime_rnof', file_restart) + + IF (write_reservoir) THEN + ierr = nf90mpi_def_dim(ncid, 'reservoir', int(totalnumresv, MPI_OFFSET_KIND), dim_reservoir) + CALL pnetcdf_check(ierr, 'define reservoir dimension', file_restart) + + ierr = nf90mpi_def_var(ncid, 'volresv', NF90_DOUBLE, (/dim_reservoir/), var_volresv) + CALL pnetcdf_check(ierr, 'define volresv', file_restart) + ENDIF + + ierr = nf90mpi_enddef(ncid) + CALL pnetcdf_check(ierr, 'end define mode', file_restart) + + ierr = nf90mpi_begin_indep_data(ncid) + CALL pnetcdf_check(ierr, 'begin independent data mode', file_restart) + + CALL pnetcdf_write_real8_points(ncid, var_wdsrf, ucat_ucid, wdsrf_ucat, numucat, totalnumucat, & + 'wdsrf_ucat', file_restart) + CALL pnetcdf_write_real8_points(ncid, var_veloc, ucat_ucid, veloc_riv, numucat, totalnumucat, & + 'veloc_riv', file_restart) + CALL pnetcdf_write_real8_points(ncid, var_discharge, ucat_ucid, discharge_riv, numucat, totalnumucat, & + 'discharge_riv', file_restart) + CALL pnetcdf_write_real8_points(ncid, var_acc_rnof, ucat_ucid, acc_rnof_uc, numucat, totalnumucat, & + 'acc_rnof_uc', file_restart) + + IF (mpas_rank == 0) THEN + ierr = nf90mpi_put_var(ncid, var_acctime_rnof, acctime_rnof) + CALL pnetcdf_check(ierr, 'write acctime_rnof', file_restart) + ENDIF + + IF (write_reservoir) THEN + CALL pnetcdf_write_real8_points(ncid, var_volresv, resv_global_index, volresv, numresv, totalnumresv, & + 'volresv', file_restart) + ENDIF + + ierr = nf90mpi_end_indep_data(ncid) + CALL pnetcdf_check(ierr, 'end independent data mode', file_restart) + + ierr = nf90mpi_close(ncid) + CALL pnetcdf_check(ierr, 'close', file_restart) + + END SUBROUTINE write_gridriver_restart_mpas_embedded + + SUBROUTINE pnetcdf_write_real8_points(ncid, varid, index, data, ndata, global_size, varname, filename) + + USE mpi, only: MPI_OFFSET_KIND + USE pnetcdf, only: nf90mpi_put_var + USE MOD_MPAS_MPI, only: CoLM_stop + USE, intrinsic :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + integer, intent(in) :: ncid + integer, intent(in) :: varid + integer, intent(in) :: index(:) + real(r8), intent(inout) :: data(:) + integer, intent(in) :: ndata + integer, intent(in) :: global_size + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: filename + + integer :: ierr + integer :: i + integer :: iend + integer(kind=MPI_OFFSET_KIND) :: start(1) + integer(kind=MPI_OFFSET_KIND) :: count(1) + + IF (ndata < 0 .or. ndata > size(index) .or. ndata > size(data)) THEN + CALL CoLM_stop('PnetCDF indexed write size mismatch for '//trim(varname)) + ENDIF + + DO i = 1, ndata + IF (index(i) < 1 .or. index(i) > global_size) THEN + CALL CoLM_stop('PnetCDF indexed write invalid index for '//trim(varname)) + ENDIF + IF (.not. ieee_is_finite(data(i))) THEN + CALL CoLM_stop('PnetCDF indexed write contains non-finite data for '//trim(varname)) + ENDIF + ENDDO + + i = 1 + DO WHILE (i <= ndata) + iend = i + DO WHILE (iend < ndata) + IF (index(iend + 1) /= index(iend) + 1) EXIT + iend = iend + 1 + ENDDO + start(1) = int(index(i), MPI_OFFSET_KIND) + count(1) = int(iend - i + 1, MPI_OFFSET_KIND) + ierr = nf90mpi_put_var(ncid, varid, data(i:iend), start=start, count=count) + CALL pnetcdf_check(ierr, 'write '//trim(varname), filename) + i = iend + 1 + ENDDO + + END SUBROUTINE pnetcdf_write_real8_points + + SUBROUTINE validate_gridriver_indices(index, ndata, global_size, label) + + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer, intent(in) :: index(:) + integer, intent(in) :: ndata + integer, intent(in) :: global_size + character(len=*), intent(in) :: label + + IF (ndata < 0 .or. ndata > size(index)) THEN + CALL CoLM_stop('Invalid local '//trim(label)//' index count in embedded CoLM river routing.') + ENDIF + IF (global_size < 0) THEN + CALL CoLM_stop('Invalid global '//trim(label)//' count in embedded CoLM river routing.') + ENDIF + IF (ndata > 0) THEN + IF (global_size < 1 .or. any(index(1:ndata) < 1) .or. any(index(1:ndata) > global_size)) THEN + CALL CoLM_stop('Out-of-range '//trim(label)//' index in embedded CoLM river routing.') + ENDIF + ENDIF + IF (ndata > 1) THEN + IF (any(index(2:ndata) <= index(1:ndata-1))) THEN + CALL CoLM_stop('Duplicate or unordered '//trim(label)//' indices in embedded CoLM river routing.') + ENDIF + ENDIF + + END SUBROUTINE validate_gridriver_indices + + SUBROUTINE pnetcdf_check(status, action, filename) + + USE pnetcdf, only: NF90_NOERR, nf90mpi_strerror + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer, intent(in) :: status + character(len=*), intent(in) :: action + character(len=*), intent(in) :: filename + + IF (status /= NF90_NOERR) THEN + write(*,'(A)') 'PnetCDF error during '//trim(action)//' for '//trim(filename)//': ' & + //trim(nf90mpi_strerror(status)) + CALL CoLM_stop() + ENDIF + + END SUBROUTINE pnetcdf_check + + SUBROUTINE update_GridRiverLakeElementDiagnostics() + + IMPLICIT NONE + + CALL map_GridRiverLakeUcatToElement(wdsrf_ucat, river_water_depth_elm) + CALL map_GridRiverLakeUcatToElement(veloc_riv, river_velocity_elm) + CALL map_GridRiverLakeUcatToElement(discharge_riv, river_discharge_elm) + + END SUBROUTINE update_GridRiverLakeElementDiagnostics + + SUBROUTINE map_GridRiverLakeUcatToElement(ucat_data, element_data) + + USE MOD_ComputePushData, only: compute_push_data, compute_remap_data_grid2pset + USE MOD_Grid_RiverLakeNetwork, only: numucat, numinpm, push_ucat2inpm, remap_patch2inpm + USE MOD_LandPatch, only: numpatch, elm_patch + USE MOD_Mesh, only: numelm + USE MOD_MPAS_MPI, only: CoLM_stop + USE MOD_Vars_Global, only: spval + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + real(r8), intent(in) :: ucat_data(:) + real(r8), intent(inout) :: element_data(:) + + real(r8), allocatable :: grid_data(:) + real(r8), allocatable :: patch_data(:) + real(r8) :: weight + real(r8) :: weight_sum + integer :: element + integer :: patch + integer :: patch_start + integer :: patch_end + + IF (size(ucat_data) /= numucat .or. size(element_data) /= numelm) THEN + CALL CoLM_stop('Embedded CoLM river diagnostic dimensions do not match the local decomposition.') + ENDIF + IF (.not. allocated(elm_patch%substt) .or. .not. allocated(elm_patch%subend) .or. & + .not. allocated(elm_patch%subfrc)) THEN + CALL CoLM_stop('Embedded CoLM river diagnostics require a complete element-patch map.') + ENDIF + IF (size(elm_patch%substt) < numelm .or. size(elm_patch%subend) < numelm .or. & + size(elm_patch%subfrc) < numpatch) THEN + CALL CoLM_stop('Embedded CoLM river diagnostic element-patch map has inconsistent dimensions.') + ENDIF + IF (numucat > 0) THEN + IF (.not. all(ieee_is_finite(ucat_data))) THEN + CALL CoLM_stop('Embedded CoLM river diagnostics contain non-finite unit-catchment values.') + ENDIF + ENDIF + + allocate(grid_data(numinpm)) + allocate(patch_data(numpatch)) + grid_data = spval + patch_data = spval + element_data = spval + + CALL compute_push_data(push_ucat2inpm, ucat_data, grid_data, fillvalue=spval, mode='average') + CALL compute_remap_data_grid2pset(remap_patch2inpm, grid_data, patch_data, fillvalue=spval, mode='average') + + DO element = 1, numelm + patch_start = elm_patch%substt(element) + patch_end = elm_patch%subend(element) + IF (patch_start < 1 .or. patch_end < patch_start .or. patch_end > numpatch) THEN + CALL CoLM_stop('Embedded CoLM river diagnostic encountered an invalid element-patch range.') + ENDIF + + element_data(element) = 0._r8 + weight_sum = 0._r8 + DO patch = patch_start, patch_end + weight = elm_patch%subfrc(patch) + IF (.not. ieee_is_finite(weight) .or. weight < 0._r8) THEN + CALL CoLM_stop('Embedded CoLM river diagnostic encountered an invalid patch fraction.') + ENDIF + IF (weight > 0._r8 .and. ieee_is_finite(patch_data(patch)) .and. & + abs(patch_data(patch)) < 0.5_r8 * abs(spval)) THEN + element_data(element) = element_data(element) + weight * patch_data(patch) + weight_sum = weight_sum + weight + ENDIF + ENDDO + IF (weight_sum > 0._r8) THEN + element_data(element) = element_data(element) / weight_sum + ELSE + element_data(element) = spval + ENDIF + ENDDO + + deallocate(grid_data) + deallocate(patch_data) + + END SUBROUTINE map_GridRiverLakeUcatToElement + + SUBROUTINE deallocate_GridRiverLakeTimeVars + + IMPLICIT NONE + + IF (allocated (wdsrf_ucat)) deallocate (wdsrf_ucat) + IF (allocated (veloc_riv )) deallocate (veloc_riv ) + IF (allocated (discharge_riv)) deallocate (discharge_riv) + IF (allocated (momen_riv )) deallocate (momen_riv ) + IF (allocated (volresv )) deallocate (volresv ) + IF (allocated (acc_rnof_uc)) deallocate (acc_rnof_uc) + IF (allocated (river_water_depth_elm)) deallocate (river_water_depth_elm) + IF (allocated (river_velocity_elm )) deallocate (river_velocity_elm ) + IF (allocated (river_discharge_elm )) deallocate (river_discharge_elm ) + acctime_rnof = 0._r8 + gridriver_restart_file = '' + + END SUBROUTINE deallocate_GridRiverLakeTimeVars + +END MODULE MOD_Grid_RiverLakeTimeVars +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilFunction.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilFunction.F90 new file mode 100644 index 0000000000..1480a85553 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilFunction.F90 @@ -0,0 +1,173 @@ +#include + +MODULE MOD_Hydro_SoilFunction + +!---------------------------------------------------------------------------- +! Description: +! +! Soil function type 1: +! Campbell model +! CAMPBELL, G. S. (1974), Soil Science, 117(6), 311-314. +! +! Soil function type 2: +! Modified van Genuchten & Mualem model by introducing an air-entry value +! Ippisch et al. (2006), Advances in Water Resources, 29(12), 1780-1789. +! +! Created by Shupeng Zhang, 2022. +!---------------------------------------------------------------------------- + + USE MOD_Precision + + IMPLICIT NONE + + real(r8), parameter :: minsmp = -1.e8 + + PUBLIC :: get_derived_parameters_vGM + + PUBLIC :: soil_psi_from_vliq + PUBLIC :: soil_hk_from_psi + PUBLIC :: soil_vliq_from_psi + +CONTAINS + + !------------------------------------- + SUBROUTINE get_derived_parameters_vGM ( & + psi_s, alpha_vgm, n_vgm, sc_vgm, fc_vgm) + + real(r8), intent(in) :: psi_s + real(r8), intent(in) :: alpha_vgm + real(r8), intent(in) :: n_vgm + + real(r8), intent(out) :: sc_vgm + real(r8), intent(out) :: fc_vgm + + ! Local variables + real(r8) :: m_vgm + + m_vgm = 1.0_r8 - 1.0_r8 / n_vgm + sc_vgm = (1.0_r8 + (- alpha_vgm * psi_s)**n_vgm) ** (-m_vgm) + fc_vgm = 1.0_r8 - (1.0_r8 - sc_vgm ** (1.0_r8/m_vgm)) ** m_vgm + + END SUBROUTINE get_derived_parameters_vGM + + !------------------------------------------------------------------ + real(r8) FUNCTION soil_hk_from_psi (psi, & + psi_s, hksat, nprm, prms) + + IMPLICIT NONE + + real(r8), intent(in) :: psi + + real(r8), intent(in) :: psi_s + real(r8), intent(in) :: hksat + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + ! Local variables + real(r8) :: m_vgm, esat + + IF (psi >= psi_s) THEN + soil_hk_from_psi = hksat + RETURN + ENDIF + +#ifdef Campbell_SOIL_MODEL + ! bsw => prms(1) + soil_hk_from_psi = hksat * (psi / psi_s)**(- 3.0_r8 / prms(1) - 2.0_r8) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! alpha_vgm => prms(1), n_vgm => prms(2), L_vgm => prms(3), sc_vgm => prms(4), fc_vgm => prms(5) + m_vgm = 1.0_r8 - 1.0_r8 / prms(2) + esat = (1.0_r8 + (- prms(1) * psi)**(prms(2)))**(-m_vgm) / prms(4) + soil_hk_from_psi = hksat * esat**prms(3) & + * ((1.0_r8 - (1.0_r8 - (esat*prms(4))**(1.0_r8/m_vgm))**m_vgm) / prms(5))**2.0_r8 +#endif + + END FUNCTION soil_hk_from_psi + + + !----------------------------------------------------------------- + real(r8) FUNCTION soil_psi_from_vliq (vliq, & + porsl, vl_r, psi_s, nprm, prms) + + IMPLICIT NONE + + real(r8), intent(in) :: vliq + + real(r8), intent(in) :: porsl + real(r8), intent(in) :: vl_r + real(r8), intent(in) :: psi_s + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + ! Local variables + real(r8) :: esat, m_vgm + + IF (vliq >= porsl) THEN + soil_psi_from_vliq = psi_s + RETURN + ELSEIF (vliq <= max(vl_r,1.0e-8)) THEN + soil_psi_from_vliq = minsmp + RETURN + ENDIF + +#ifdef Campbell_SOIL_MODEL + ! bsw => prms(1) + soil_psi_from_vliq = psi_s * (vliq / porsl)**(-prms(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! alpha_vgm => prms(1), n_vgm => prms(2), L_vgm => prms(3), sc_vgm => prms(4), fc_vgm => prms(5) + m_vgm = 1.0_r8 - 1.0_r8 / prms(2) + esat = (vliq - vl_r) / (porsl - vl_r) + soil_psi_from_vliq = - ((esat*prms(4))**(- 1.0_r8/m_vgm) - 1.0_r8)**(1.0_r8/prms(2)) & + / prms(1) +#endif + + soil_psi_from_vliq = max(soil_psi_from_vliq, minsmp) + + + END FUNCTION soil_psi_from_vliq + + !------------------------------------------------------------------ + real(r8) FUNCTION soil_vliq_from_psi (psi, & + porsl, vl_r, psi_s, nprm, prms) + + IMPLICIT NONE + + real(r8), intent(in) :: psi + + real(r8), intent(in) :: porsl + real(r8), intent(in) :: vl_r + real(r8), intent(in) :: psi_s + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + ! Local variables + real(r8) :: esat, m_vgm + + IF (psi >= psi_s) THEN + soil_vliq_from_psi = porsl + RETURN + ENDIF + +#ifdef Campbell_SOIL_MODEL + ! bsw => prms(1) + soil_vliq_from_psi = porsl * (psi / psi_s)**(-1.0/prms(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! alpha_vgm => prms(1), n_vgm => prms(2), L_vgm => prms(3), sc_vgm => prms(4), fc_vgm => prms(5) + m_vgm = 1.0_r8 - 1.0_r8 / prms(2) + esat = (1.0_r8 + (psi * (-prms(1)))**(prms(2))) ** (-m_vgm) / prms(4) + soil_vliq_from_psi = (porsl - vl_r) * esat + vl_r +#endif + + END FUNCTION soil_vliq_from_psi + + +END MODULE MOD_Hydro_SoilFunction diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 new file mode 100644 index 0000000000..f1ddc2df3c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90 @@ -0,0 +1,3601 @@ +#include + +MODULE MOD_Hydro_SoilWater + +!------------------------------------------------------------------------- +! Description: +! +! Numerical Solver of Richards equation. +! +! Dai, Y., Zhang, S., Yuan, H., & Wei, N. (2019). +! Modeling Variably Saturated Flow in Stratified Soils +! With Explicit Tracking of Wetting Front and Water Table Locations. +! Water Resources Research. doi:10.1029/2019wr025368 +! +! Created by Shupeng Zhang, 2022. +!------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Hydro_SoilFunction + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS + USE MOD_UserDefFun, only: findloc_ud + + IMPLICIT NONE + + ! public subroutines and functions + PUBLIC :: soil_water_vertical_movement + PUBLIC :: get_water_equilibrium_state + PUBLIC :: soilwater_aquifer_exchange + PUBLIC :: get_zwt_from_wa + + + ! boundary condition: + ! 1: fixed pressure head + ! 2: rainfall condition with a ponding layer on top of ground surface + ! and a flux such as rainfall into the ponding layer + ! 3: fixed flux + ! 4: drainage condition with aquifers below soil columns + integer, parameter :: BC_FIX_HEAD = 1 + integer, parameter :: BC_RAINFALL = 2 + integer, parameter :: BC_FIX_FLUX = 3 + integer, parameter :: BC_DRAINAGE = 4 + + ! formula of effective hydraulic conductivity between levels + ! Please refer to Dai et al. (2019) for definitions + integer, parameter :: type_upstream_mean = 1 + integer, parameter :: type_weighted_geometric_mean = 2 + + integer, parameter :: effective_hk_type = type_weighted_geometric_mean + integer, parameter :: max_iters_richards = 10 + real(r8), parameter :: tol_richards = 8.e-8 + +#ifdef CoLMDEBUG + integer(8) :: count_implicit = 0 + integer(8) :: count_explicit = 0 + integer(8) :: count_wet2dry = 0 +#endif + + ! private subroutines and functions + PRIVATE :: Richards_solver + + PRIVATE :: water_balance + PRIVATE :: initialize_sublevel_structure + + PRIVATE :: use_explicit_form + + PRIVATE :: var_perturb_level + PRIVATE :: var_perturb_rainfall + PRIVATE :: var_perturb_drainage + + PRIVATE :: check_and_update_level + + PRIVATE :: flux_all + PRIVATE :: flux_sat_zone_all + PRIVATE :: flux_sat_zone_fixed_bc + PRIVATE :: flux_inside_hm_soil + PRIVATE :: flux_at_unsaturated_interface + PRIVATE :: flux_top_transitive_interface + PRIVATE :: flux_btm_transitive_interface + PRIVATE :: flux_both_transitive_interface + + PRIVATE :: solve_least_squares_problem + PRIVATE :: secant_method_iteration + + PRIVATE :: find_unsat_lev_lower + +CONTAINS + + ! ---- get equilibrium state ---- + SUBROUTINE get_water_equilibrium_state ( & + zwtmm, nlev, wliq, smp, hk, wa, sp_zc, sp_zi, porsl, vl_r, psi_s, hksat, nprm, prms) + + IMPLICIT NONE + + real(r8), intent(in) :: zwtmm ! location of water table [mm] + + integer, intent(in) :: nlev ! number of levels + + real(r8), intent(out) :: wliq(1:nlev) ! [mm] or [kg/m2] + real(r8), intent(out) :: smp (1:nlev) ! [mm] + real(r8), intent(out) :: hk (1:nlev) ! [mm/s] + real(r8), intent(out) :: wa ! water in aquifer [mm] + + real(r8), intent(in) :: sp_zc (1:nlev) ! soil parameter : centers of level [mm] + real(r8), intent(in) :: sp_zi (0:nlev) ! soil parameter : interfaces of level [mm] + + real(r8), intent(in) :: porsl (1:nlev) ! soil porosity + real(r8), intent(in) :: vl_r (1:nlev) ! residual soil moisture + real(r8), intent(in) :: psi_s (1:nlev) ! saturated capillary potential [mm, negative] + real(r8), intent(in) :: hksat (1:nlev) ! saturated hydraulic conductivity [mm/s] + + integer, intent(in) :: nprm ! number of parameters included in soil function + real(r8), intent(in) :: prms (nprm,1:nlev) ! parameters included in soil function + + ! Local Variables + integer :: izwt, ilev + real(r8) :: psi_zwt, smp_up, vliq_up, vliq(1:nlev), psi, vl + + ! water table location + izwt = findloc_ud(zwtmm >= sp_zi, back=.true.) + + IF (izwt <= nlev) THEN + psi_zwt = psi_s(izwt) + ELSE + psi_zwt = psi_s(nlev) + ENDIF + + DO ilev = 1, nlev + IF (ilev < izwt) THEN + smp (ilev) = psi_zwt - (zwtmm - sp_zc(ilev)) + vliq(ilev) = soil_vliq_from_psi (smp(ilev), porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + wliq(ilev) = vliq(ilev) * (sp_zi(ilev)-sp_zi(ilev-1)) + hk (ilev) = soil_hk_from_psi (smp(ilev), psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSEIF (ilev == izwt) THEN + smp_up = psi_zwt & + - (zwtmm-sp_zi(ilev-1)) * (sp_zi(ilev)-sp_zc(ilev))/(sp_zi(ilev)-sp_zi(ilev-1)) + vliq_up = soil_vliq_from_psi (smp_up, porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + wliq(ilev) = vliq_up * (zwtmm-sp_zi(ilev-1)) + porsl(ilev)*(sp_zi(ilev)-zwtmm) + vliq(ilev) = wliq(ilev) / (sp_zi(ilev)-sp_zi(ilev-1)) + smp(ilev) = soil_psi_from_vliq (vliq(ilev), porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + hk (ilev) = soil_hk_from_psi (smp(ilev), psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSE + wliq(ilev) = porsl(ilev) * (sp_zi(ilev)-sp_zi(ilev-1)) + smp (ilev) = psi_s(ilev) + hk (ilev) = hksat(ilev) + ENDIF + ENDDO + + IF (izwt == nlev+1) THEN + psi = psi_zwt - (zwtmm - sp_zi(nlev)) * 0.5 + vl = soil_vliq_from_psi (psi, porsl(nlev), vl_r(nlev), psi_s(nlev), nprm, prms(:,nlev)) + wa = -(zwtmm-sp_zi(nlev))*(porsl(nlev)-vl) + ELSE + wa = 0. + ENDIF + + END SUBROUTINE get_water_equilibrium_state + + ! --- soil water movement --- + SUBROUTINE soil_water_vertical_movement ( & + nlev, dt, sp_zc, sp_zi, is_permeable, porsl, & + vl_r, psi_s, hksat, nprm, prms, porsl_wa, & + qgtop, etr, rootr, rootflux, rsubst, qinfl, & + ss_dp, zwt, wa, ss_vliq, smp, hk, & + qlayer, tolerance, wblc) + + !======================================================================= + ! this is the main subroutine to execute the calculation of + ! soil water movement + !======================================================================= + + USE MOD_Const_Physical, only: tfrz + + IMPLICIT NONE + + integer, intent(in) :: nlev ! number of levels + real(r8), intent(in) :: dt ! time step (second) + + real(r8), intent(in) :: sp_zc (1:nlev) ! soil parameter : centers of level (mm) + real(r8), intent(in) :: sp_zi (0:nlev) ! soil parameter : interfaces of level (mm) + + logical, intent(in) :: is_permeable (1:nlev) + + real(r8), intent(in) :: porsl (1:nlev) ! soil porosity (mm^3/mm^3) + real(r8), intent(in) :: vl_r (1:nlev) ! residual soil moisture (mm^3/mm^3) + real(r8), intent(in) :: psi_s (1:nlev) ! saturated capillary potential (mm) + real(r8), intent(in) :: hksat (1:nlev) ! saturated hydraulic conductivity (mm/s) + + integer, intent(in) :: nprm ! number of parameters included in soil function + real(r8), intent(in) :: prms (nprm,1:nlev) ! parameters included in soil function + + real(r8), intent(in) :: porsl_wa ! soil porosity in aquifer (mm^3/mm^3) + + ! ground water including rain, snow melt and dew formation (mm/s) + real(r8), intent(in) :: qgtop + + real(r8), intent(in) :: etr ! transpiration rate (mm/s) + real(r8), intent(in) :: rootr(1:nlev) ! root fractions (percentage) + real(r8), intent(in) :: rootflux(1:nlev) ! root water uptake from different layers (mm/s) + + real(r8), intent(in) :: rsubst ! subsurface runoff (mm/s) + real(r8), intent(out) :: qinfl ! infiltration into soil (mm/s) + + real(r8), intent(inout) :: ss_dp ! soil water state : depth of ponding water (mm) + real(r8), intent(inout) :: zwt ! location of water table (mm) + real(r8), intent(inout) :: wa ! water deficit in aquifer (negative, mm) + real(r8), intent(inout) :: ss_vliq(1:nlev) ! volume content of liquid water (mm^3/mm^3) + + real(r8), intent(out) :: smp(1:nlev) ! soil matrix potential (mm) + real(r8), intent(out) :: hk (1:nlev) ! hydraulic conductivity (mm/s) + + real(r8), intent(out) :: qlayer(0:nlev) ! water flux at interface of soil layers (mm/s) + + real(r8), intent(in) :: tolerance + + real(r8), intent(out) :: wblc + + ! Local variables + integer :: lb, ub, ilev, izwt + real(r8) :: sumroot, deficit, etrdef, wexchange + real(r8) :: dp_m1, psi, vliq, zwtp, air + logical :: is_sat + + real(r8) :: sp_dz (1:nlev) + real(r8) :: etroot (1:nlev) + real(r8) :: ss_wt (1:nlev) + + integer :: ubc_typ_sub + real(r8) :: ubc_val_sub + integer :: lbc_typ_sub + real(r8) :: lbc_val_sub + + real(r8) :: w_sum_before, w_sum_after, vl_before(nlev), wt_before, wa_before, dp_before + + real(r8) :: tol_q, tol_z, tol_v, tol_p + + sp_dz(1:nlev) = sp_zi(1:nlev) - sp_zi(0:nlev-1) + + dp_m1 = ss_dp + + ! tolerances + tol_q = tolerance / real(nlev,r8) / dt /2.0 + tol_z = tol_q * dt + tol_v = tol_z / maxval(sp_dz) + tol_p = 1.0e-14 + + ! water table location + izwt = findloc_ud(zwt >= sp_zi, back=.true.) + + ! total water mass + w_sum_before = ss_dp + DO ilev = 1, nlev + IF (is_permeable(ilev)) THEN + IF (ilev <= izwt-1) THEN + w_sum_before = w_sum_before + ss_vliq(ilev) * sp_dz(ilev) + ELSEIF (ilev == izwt) THEN + w_sum_before = w_sum_before + ss_vliq(izwt) * (zwt - sp_zi(izwt-1)) + w_sum_before = w_sum_before + porsl (izwt) * (sp_zi(izwt) - zwt) + ELSE + w_sum_before = w_sum_before + porsl(ilev) * sp_dz(ilev) + ENDIF + ENDIF + ENDDO + w_sum_before = w_sum_before + wa + + vl_before = ss_vliq + wt_before = zwt + wa_before = wa + dp_before = ss_dp + + ! transpiration + IF(.not. DEF_USE_PLANTHYDRAULICS)THEN + sumroot = sum(rootr, mask = is_permeable .and. (rootr > 0.)) + etroot(:) = 0. + IF (sumroot > 0.) THEN + WHERE (is_permeable) + etroot = etr * max(rootr, 0.) / sumroot + END WHERE + etrdef = 0. + ELSE + etrdef = etr*dt + ENDIF + ELSE + etrdef = 0. + etroot(:) = rootflux + ENDIF + + deficit = etrdef + + DO ilev = 1, izwt-1 + IF (is_permeable(ilev)) THEN + + ss_vliq(ilev) = (ss_vliq(ilev) * sp_dz(ilev) & + - etroot(ilev)*dt - deficit) / sp_dz(ilev) + + IF (ss_vliq(ilev) < 0) THEN + deficit = ( - ss_vliq(ilev)) * sp_dz(ilev) + ss_vliq(ilev) = 0 + ELSEIF (ss_vliq(ilev) > porsl(ilev)) THEN + deficit = - (ss_vliq(ilev) - porsl(ilev)) * sp_dz(ilev) + ss_vliq(ilev) = porsl(ilev) + ELSE + deficit = 0. + ENDIF + ELSE + deficit = deficit + etroot(ilev)*dt + ENDIF + ENDDO + + DO ilev = izwt, nlev + deficit = deficit + etroot(ilev)*dt + ENDDO + + ! Exchange water with aquifer + wexchange = rsubst * dt + deficit + CALL soilwater_aquifer_exchange ( & + nlev, wexchange, sp_zi, is_permeable, porsl, vl_r, psi_s, hksat, & + nprm, prms, porsl_wa, ss_dp, ss_vliq, zwt, wa, izwt) + + ! water table location + ss_wt(:) = 0._r8 + IF ((izwt >= 1) .and. (izwt <= nlev)) THEN + ss_wt(izwt) = sp_zi(izwt) - zwt + ENDIF + DO ilev = izwt+1, nlev + ss_wt(ilev) = sp_dz(ilev) + ENDDO + + ! Impermeable levels cut the soil column into several disconnected parts. + ! The Richards solver is called to calculate water movement part by part. + ub = nlev + soilcolumn : DO WHILE (ub >= 1) + + DO WHILE (.not. is_permeable(ub)) + + qlayer(ub-1:ub) = 0._r8 + + IF (ub > 1) THEN + ub = ub - 1 + ELSE + EXIT soilcolumn + ENDIF + ENDDO + + lb = ub + DO WHILE (lb > 1) + IF (is_permeable(lb-1)) THEN + lb = lb - 1 + ELSE + EXIT + ENDIF + ENDDO + + IF (lb == 1) THEN + ubc_typ_sub = BC_RAINFALL + ubc_val_sub = qgtop + ELSE + ubc_typ_sub = BC_FIX_FLUX + ubc_val_sub = 0 + ENDIF + + IF ((ub == nlev) .and. (izwt > nlev)) THEN + lbc_typ_sub = BC_DRAINAGE + lbc_val_sub = 0. + ELSE + lbc_typ_sub = BC_FIX_FLUX + lbc_val_sub = 0. + ENDIF + + CALL Richards_solver ( & + lb, ub, dt, sp_zc(lb:ub), sp_zi(lb-1:ub), & + porsl(lb:ub), vl_r(lb:ub), psi_s(lb:ub), hksat(lb:ub), nprm, prms(:,lb:ub), & + porsl_wa, & + ubc_typ_sub, ubc_val_sub, lbc_typ_sub, lbc_val_sub, & + ss_dp, wa, ss_vliq(lb:ub), ss_wt(lb:ub), qlayer(lb-1:ub), & + tol_q, tol_z, tol_v, tol_p) + + ub = lb - 1 + + ENDDO soilcolumn + + IF (.not. is_permeable(1)) THEN + ss_dp = max(ss_dp + qgtop * dt, 0._r8) + ENDIF + + IF (wa >= 0) THEN + DO ilev = nlev, 1, -1 + is_sat = (.not. is_permeable(ilev)) & + .or. (ss_vliq(ilev) > porsl(ilev) - tol_v) & + .or. (ss_wt (ilev) > sp_dz(ilev) - tol_z) + IF (.not. is_sat) THEN + zwt = sp_zi(ilev) - ss_wt(ilev) + EXIT + ENDIF + ENDDO + + IF (is_sat) THEN + zwt = 0._r8 + ENDIF + ELSE + CALL get_zwt_from_wa ( & + porsl_wa, vl_r(nlev), psi_s(nlev), hksat(nlev), & + nprm, prms(:,nlev), tol_v, tol_z, & + wa, sp_zi(nlev), zwt) + ENDIF + + izwt = findloc_ud(zwt >= sp_zi, back=.true.) + DO ilev = izwt-1, 1, -1 + IF (is_permeable(ilev)) THEN + ss_vliq(ilev) = (ss_vliq(ilev)*(sp_dz(ilev)-ss_wt(ilev)) & + + porsl(ilev)*ss_wt(ilev)) / sp_dz(ilev) + ENDIF + ENDDO + + qinfl = qgtop - (ss_dp - dp_m1)/dt + + ! total water mass + w_sum_after = ss_dp + DO ilev = 1, nlev + IF (is_permeable(ilev)) THEN + IF (ilev <= izwt-1) THEN + w_sum_after = w_sum_after + ss_vliq(ilev) * sp_dz(ilev) + ELSEIF (ilev == izwt) THEN + w_sum_after = w_sum_after + ss_vliq(izwt) * (zwt - sp_zi(izwt-1)) + w_sum_after = w_sum_after + porsl (izwt) * (sp_zi(izwt) - zwt) + ELSE + w_sum_after = w_sum_after + porsl(ilev) * sp_dz(ilev) + ENDIF + ENDIF + ENDDO + w_sum_after = w_sum_after + wa + + wblc = w_sum_after - (w_sum_before + (qgtop - sum(etroot) - rsubst) * dt - etrdef) + + IF (abs(wblc) > tolerance) THEN + write(*,*) 'soil_water_vertical_movement balance error: ', wblc, ' in mm.' + write(*,*) 'qtop: ', qgtop, 'etr: ', sum(etroot)+etrdef, 'rsubst: ', rsubst + write(*,*) 'permeable (1-10): ', is_permeable + write(*,*) 'ponding depth: ', dp_before, '(before) to ', ss_dp, '(after)' + write(*,*) 'porsl (c1) and liquid volume before (c2) and after (c3) (1-10) : ' + DO ilev = 1, nlev + write(*,*) porsl(ilev), vl_before(ilev), ss_vliq(ilev) + ENDDO + write(*,*) 'water table : ', wt_before, '(before) to ', zwt, '(after)' + write(*,*) 'aquifer : ', wa_before, '(before) to ', wa, '(after)' + ENDIF + + DO ilev = 1, nlev + IF (ilev < izwt) THEN + smp(ilev) = soil_psi_from_vliq (ss_vliq(ilev), porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + hk (ilev) = soil_hk_from_psi (smp(ilev), psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSEIF (ilev == izwt) THEN + vliq = (ss_vliq(izwt) * (zwt - sp_zi(izwt-1)) + porsl(izwt) * (sp_zi(izwt) - zwt)) & + / (sp_zi(izwt) - sp_zi(izwt-1)) + smp(ilev) = soil_psi_from_vliq (vliq, porsl(ilev), vl_r(ilev), psi_s(ilev), & + nprm, prms(:,ilev)) + hk (ilev) = soil_hk_from_psi (smp(ilev), psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSE + smp(ilev) = psi_s(ilev) + hk (ilev) = hksat(ilev) + ENDIF + ENDDO + + END SUBROUTINE soil_water_vertical_movement + + ! --- water exchange between soil water and aquifer --- + SUBROUTINE soilwater_aquifer_exchange ( & + nlev, exwater, sp_zi, is_permeable, porsl, vl_r, psi_s, hksat, & + nprm, prms, porsl_wa, ss_dp, ss_vliq, zwt, wa, izwt) + + IMPLICIT NONE + + integer, intent(in) :: nlev + + real(r8), intent(in) :: exwater ! total water exchange [mm] + + real(r8), intent(in) :: sp_zi (0:nlev) ! soil parameter : interfaces of level [mm] + + logical, intent(in) :: is_permeable (1:nlev) + real(r8), intent(in) :: porsl (1:nlev) ! soil porosity [mm^3/mm^3] + real(r8), intent(in) :: vl_r (1:nlev) ! residual soil moisture [mm^3/mm^3] + real(r8), intent(in) :: psi_s (1:nlev) ! saturated capillary potential [mm] + real(r8), intent(in) :: hksat (1:nlev) ! saturated hydraulic conductivity [mm/s] + + integer, intent(in) :: nprm ! number of parameters included in soil function + real(r8), intent(in) :: prms (nprm,1:nlev) ! parameters included in soil function + + real(r8), intent(in) :: porsl_wa ! soil porosity in aquifer [mm^3/mm^3] + + real(r8), intent(inout) :: ss_dp ! depth of ponding water [mm] + real(r8), intent(inout) :: ss_vliq(1:nlev) ! volume content of liquid water [mm^3/mm^3] + real(r8), intent(inout) :: zwt ! location of water table [mm] + real(r8), intent(inout) :: wa ! water in aquifer [mm, negative] + + integer, intent(out) :: izwt + + ! Local variables + real(r8) :: sp_dz(1:nlev) + real(r8) :: reswater, zwtp, psi, vliq, air + real(r8) :: tol_v, tol_z + + sp_dz(1:nlev) = sp_zi(1:nlev) - sp_zi(0:nlev-1) + + ! tolerances + tol_z = tol_richards / sqrt(real(nlev,r8)) * 0.5_r8 * 1800._r8 + tol_v = tol_z / maxval(sp_dz) + + ! water table location + izwt = findloc_ud(zwt >= sp_zi, back=.true.) + + reswater = exwater + + IF (reswater > 0.) THEN + + IF ((zwt <= 0.) .and. (ss_dp > 0.)) THEN + IF (ss_dp > reswater) THEN + ss_dp = ss_dp - reswater + reswater = 0. + ELSE + reswater = reswater - ss_dp + ss_dp = 0. + ENDIF + ENDIF + + ! remove water from aquifer + DO WHILE (reswater > 0.) + IF (izwt <= nlev) THEN + IF (is_permeable(izwt)) THEN + + CALL get_zwt_from_wa ( & + porsl(izwt), vl_r(izwt), psi_s(izwt), hksat(izwt), & + nprm, prms(:,izwt), tol_v, tol_z, -reswater, zwt, zwtp) + + IF (zwtp < sp_zi(izwt)) THEN + ss_vliq(izwt) = (ss_vliq(izwt)*(zwt-sp_zi(izwt-1)) & + + porsl(izwt)*(zwtp-zwt) - reswater) / (zwtp - sp_zi(izwt-1)) + reswater = 0. + zwt = zwtp + ELSE + psi = psi_s(izwt) - (zwtp - 0.5*(sp_zi(izwt) + zwt)) + vliq = soil_vliq_from_psi (psi, & + porsl(izwt), vl_r(izwt), psi_s(izwt), nprm, prms(:,izwt)) + IF (reswater > (porsl(izwt)-vliq) * (sp_zi(izwt)-zwt)) THEN + ss_vliq(izwt) = (ss_vliq(izwt)*(zwt-sp_zi(izwt-1)) & + + vliq * (sp_zi(izwt)-zwt)) / sp_dz(izwt) + reswater = reswater - (porsl(izwt)-vliq) * (sp_zi(izwt)-zwt) + ELSE + ss_vliq(izwt) = (ss_vliq(izwt)*(zwt-sp_zi(izwt-1)) & + + porsl(izwt)*(sp_zi(izwt)-zwt) - reswater) / sp_dz(izwt) + reswater = 0. + ENDIF + + zwt = sp_zi(izwt) + izwt = izwt + 1 + ENDIF + + ELSE + zwt = sp_zi(izwt) + izwt = izwt + 1 + ENDIF + ELSE + CALL get_zwt_from_wa ( & + porsl_wa, vl_r(nlev), psi_s(nlev), hksat(nlev), & + nprm, prms(:,nlev), tol_v, tol_z, wa-reswater, sp_zi(nlev), zwt) + wa = wa - reswater + reswater = 0. + ENDIF + ENDDO + + ELSEIF (reswater < 0.) THEN + + ! increase water in aquifer + DO WHILE (reswater < 0.) + IF (izwt > nlev) THEN + IF (wa <= reswater) THEN + wa = wa - reswater + reswater = 0. + ELSE + reswater = reswater - wa + wa = 0. + izwt = nlev + zwt = sp_zi(nlev) + ENDIF + ELSEIF (izwt >= 1) THEN + IF (is_permeable(izwt)) THEN + air = (porsl(izwt)-ss_vliq(izwt)) * (zwt-sp_zi(izwt-1)) + IF (air > -reswater) THEN + ss_vliq(izwt) = ss_vliq(izwt) - reswater / (zwt-sp_zi(izwt-1)) + reswater = 0. + ELSE + ss_vliq(izwt) = porsl(izwt) + reswater = reswater + air + izwt = izwt - 1 + zwt = sp_zi(izwt) + ENDIF + ELSE + izwt = izwt - 1 + zwt = sp_zi(izwt) + ENDIF + ELSE + ss_dp = ss_dp - reswater + reswater = 0. + izwt = 1 + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE soilwater_aquifer_exchange + + ! ---- Richards equation solver ---- + SUBROUTINE Richards_solver ( & + lb, ub, dt, sp_zc, sp_zi, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + vl_s_wa, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + ss_dp, waquifer, ss_vl, ss_wt, ss_q, & + tol_q, tol_z, tol_v, tol_p) + + IMPLICIT NONE + + integer, intent(in) :: lb, ub ! lower and upper boundary + + real(r8), intent(in) :: dt ! time step (second) + + real(r8), intent(in) :: sp_zc (lb:ub) ! soil parameter : centers of level (mm) + real(r8), intent(in) :: sp_zi (lb-1:ub) ! soil parameter : interfaces of level (mm) + + real(r8), intent(in) :: vl_s (lb:ub) ! soil porosity (mm^3/mm^3) + real(r8), intent(in) :: vl_r (lb:ub) ! residual soil moisture (mm^3/mm^3) + real(r8), intent(in) :: psi_s (lb:ub) ! saturated capillary potential (mm,negative) + real(r8), intent(in) :: hksat (lb:ub) ! saturated hydraulic conductivity (mm/s) + + integer, intent(in) :: nprm ! number of parameters included in soil function + real(r8), intent(in) :: prms(nprm,lb:ub) ! parameters included in soil function + + real(r8), intent(in) :: vl_s_wa ! soil porosity in aquifer (mm^3/mm^3) + + integer, intent(in) :: ubc_typ ! upper boundary condition type + real(r8), intent(in) :: ubc_val ! value of upper boundary condition + integer, intent(in) :: lbc_typ ! lower boundary condition type + real(r8), intent(in) :: lbc_val ! value of lower boundary condition + + real(r8), intent(inout) :: ss_dp ! soil water state : depth of ponding water (mm) + real(r8), intent(inout) :: waquifer ! water deficit in aquifer (mm, negative) + real(r8), intent(inout) :: ss_vl (lb:ub) ! soil water state : volume content of liquid water + real(r8), intent(inout) :: ss_wt (lb:ub) ! soil water state : location of water table (mm) + real(r8), intent(out) :: ss_q (lb-1:ub) ! soil water state : flux between levels (mm/s) + + real(r8), intent(in) :: tol_q ! tolerance for flux + real(r8), intent(in) :: tol_z ! tolerance for locations + real(r8), intent(in) :: tol_v ! tolerance for volumetric water content + real(r8), intent(in) :: tol_p ! tolerance for potential head + + ! Local variables + real(r8) :: zwt ! location of water table (mm) + real(r8) :: sp_dz (lb:ub) ! thickness of level (mm) + real(r8) :: ss_wf (lb:ub) ! soil water state : location of wetting front + + logical :: is_sat (lb:ub) ! whether a level is saturated or not at this time step + logical :: has_wf (lb:ub) ! whether a wetting front is present or not + logical :: has_wt (lb:ub) ! whether a water table is present or not + + real(r8) :: psi (lb:ub) ! water pressure head in unsaturated soil (mm) + real(r8) :: hk (lb:ub) ! hydraulic conductivity in unsaturated soil (mm/s) + + real(r8) :: psi_pb (lb:ub) ! perturbed water pressure head (mm) + real(r8) :: hk_pb (lb:ub) ! perturbed hydraulic conductivity (mm/s) + + real(r8) :: q_this(lb-1:ub) ! water flux between levels (mm/s) + real(r8) :: q_wf (lb:ub) ! water flux at wetting front (mm/s) + real(r8) :: q_wt (lb:ub) ! water flux at water table (mm/s) + + real(r8) :: dp_m1 ! depth of ponding water at previous time step (mm) + real(r8) :: wf_m1 (lb:ub) ! location of wetting front at previous time step (mm) + real(r8) :: vl_m1 (lb:ub) ! volumetric water content at previous time step (mm/mm) + real(r8) :: wt_m1 (lb:ub) ! location of water table at previous time step (mm) + real(r8) :: waquifer_m1 ! water deficit in aquifer at previous time step + + real(r8) :: q_0 (lb-1:ub) ! initial value of water flux between levels (mm/s) + real(r8) :: q_wf_0 (lb:ub) ! initial value of water flux at wetting front (mm/s) + real(r8) :: q_wt_0 (lb:ub) ! initial value of water flux at water table (mm/s) + + real(r8) :: dp_pb ! perturbed depth of ponding water (mm) + real(r8) :: vl_pb (lb:ub) ! perturbed volumetric water content (mm/mm) + real(r8) :: wf_pb (lb:ub) ! perturbed location of wetting front (mm) + real(r8) :: wt_pb (lb:ub) ! perturbed location of water table (mm) + real(r8) :: zwt_pb, waquifer_pb + + real(r8) :: q_pb (lb-1:ub) ! perturbed water flux between levels (mm/s) + real(r8) :: q_wf_pb (lb:ub) ! perturbed water flux at wetting front (mm/s) + real(r8) :: q_wt_pb (lb:ub) ! perturbed water flux at water table (mm/s) + + real(r8) :: blc (lb-1:ub+1) ! mass balance (mm water) + logical :: is_solvable + logical :: lev_update (lb-1:ub+1) ! whether a level is updated or not + real(r8) :: blc_pb (lb-1:ub+1) ! perturbed mass balance (mm water) + logical :: vact (lb-1:ub+1) ! whether a level is active or not + integer :: jsbl (lb:ub) ! which variable of wf,vl,wt inside each level is active + + real(r8) :: dr_dv (lb-1:ub+1,lb-1:ub+1) ! the Jacobian matrix + real(r8) :: dv (lb-1:ub+1) ! searching step of variables + + real(r8) :: f2_norm (max_iters_richards) ! sqrt( f2 ), where f2 = sum_i (r_i ^2) + + real(r8) :: dt_this, dt_done + real(r8) :: dt_explicit ! time step (day) for explicit scheme + + integer :: ilev, iter + real(r8) :: dlt + + logical :: wet2dry + + real(r8) :: wsum_m1, wsum, werr + + ss_wf(lb:ub) = 0 + + DO ilev = lb, ub + sp_dz(ilev) = sp_zi(ilev) - sp_zi(ilev-1) + ENDDO + + dt_explicit = dt / max_iters_richards + + ss_q = 0 + dt_done = 0 + DO WHILE (dt_done < dt) + + dt_this = dt - dt_done + + wf_m1 = ss_wf + vl_m1 = ss_vl + wt_m1 = ss_wt + + wsum_m1 = sum(ss_vl * (sp_dz - ss_wt)) + sum(ss_wt * vl_s) + IF (ubc_typ == BC_RAINFALL) THEN + wsum_m1 = wsum_m1 + ss_dp + ENDIF + IF (lbc_typ == BC_DRAINAGE) THEN + wsum_m1 = wsum_m1 + waquifer + ENDIF + + IF (ubc_typ == BC_RAINFALL) THEN + dp_m1 = max(ss_dp, 0._r8) + ENDIF + + IF (lbc_typ == BC_DRAINAGE) THEN + waquifer_m1 = waquifer + CALL get_zwt_from_wa ( & + vl_s_wa, vl_r(ub), psi_s(ub), hksat(ub), & + nprm, prms(:,ub), tol_v, tol_z, & + waquifer, sp_zi(ub), zwt) + ENDIF + + iter = 0 + DO WHILE (.true.) + + iter = iter + 1 + + CALL initialize_sublevel_structure ( & + lb, ub, sp_dz, sp_zi(ub), & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + is_sat, has_wf, has_wt, & + ss_wf, ss_vl, ss_wt, ss_dp, psi, hk, & + tol_v, tol_z) + + lev_update (:) = .true. + CALL flux_all ( & + lb, ub, sp_dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, .true., & + is_sat, has_wf, has_wt, & + ss_wf, ss_vl, ss_wt, ss_dp, zwt, psi, hk, & + q_this, q_wf, q_wt, & + tol_q, tol_z, tol_p) + + CALL water_balance ( & + lb, ub, sp_dz, dt_this, is_sat, vl_s, q_this, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + ss_wf, ss_vl, ss_wt, ss_dp, waquifer, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc, is_solvable, tol_richards * dt_this) + + IF (iter == 1) THEN + q_0 = q_this + q_wf_0 = q_wf + q_wt_0 = q_wt + + wet2dry = .false. + IF (ubc_typ == BC_RAINFALL) THEN + IF ((dp_m1 > tol_z) .and. (dp_m1 - (q_0(lb-1)-ubc_val)*dt_this < tol_z)) THEN + wet2dry = .true. + ENDIF + ENDIF + ENDIF + + f2_norm(iter) = sqrt(sum(blc**2)) + + IF ( (f2_norm(iter) < tol_richards * dt_this) & ! converged + .or. (dt_this < dt_explicit) & + .or. (iter >= max_iters_richards) & + .or. (.not. is_solvable) & + .or. wet2dry) THEN + + IF ((dt_this < dt_explicit) & + .or. (iter >= max_iters_richards) & + .or. (.not. is_solvable) & + .or. wet2dry) THEN + + dt_this = min(dt_this, dt_explicit) + q_this = q_0 + + CALL use_explicit_form ( & + lb, ub, dt_this, sp_dz, sp_zc, sp_zi, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + vl_s_wa, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + q_this, q_wf_0, q_wt_0, & + ss_wf, ss_vl, ss_wt, ss_dp, waquifer, zwt, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + tol_q, tol_z, tol_v) + + ENDIF + + dt_done = dt_done + dt_this + +#ifdef CoLMDEBUG + IF (f2_norm(iter) < tol_richards * dt_this) THEN + count_implicit = count_implicit + 1 + ELSEIF (iter >= max_iters_richards) then + count_explicit = count_explicit + 1 + ELSEIF (wet2dry) THEN + count_wet2dry = count_wet2dry + 1 + ENDIF +#endif + + EXIT + + ENDIF + + dr_dv = 0 + vact = .false. + + IF (ubc_typ == BC_RAINFALL) THEN + + CALL var_perturb_rainfall ( & + blc(lb-1), ss_dp, dp_pb, dlt, vact(lb-1)) + + IF (vact(lb-1)) THEN + q_pb = q_this + q_wf_pb = q_wf + q_wt_pb = q_wt + + lev_update(:) = .false. + lev_update(lb-1) = .true. + CALL flux_all ( & + lb, ub, sp_dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, .false., & + is_sat, has_wf, has_wt, & + ss_wf, ss_vl, ss_wt, dp_pb, zwt, psi, hk, & + q_pb, q_wf_pb, q_wt_pb, & + tol_q, tol_z, tol_p) + + CALL water_balance ( & + lb, ub, sp_dz, dt_this, is_sat, vl_s, q_pb, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + ss_wf, ss_vl, ss_wt, dp_pb, waquifer, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc_pb) + + dr_dv(:,lb-1) = (blc_pb - blc) / dlt + + ENDIF + + ENDIF + + DO ilev = lb, ub + IF (.not. is_sat(ilev)) THEN + + wf_pb = ss_wf + vl_pb = ss_vl + wt_pb = ss_wt + psi_pb = psi + hk_pb = hk + + CALL var_perturb_level ( jsbl(ilev), blc(ilev), & + sp_dz(ilev), sp_zc(ilev), sp_zi(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), hksat(ilev), & + nprm, prms(:,ilev), & + is_sat(ilev), has_wf(ilev), has_wt(ilev), & + q_this(ilev-1), q_this(ilev), q_wf(ilev), q_wt(ilev), & + wf_pb(ilev), vl_pb(ilev), wt_pb(ilev), dlt, & + psi_pb(ilev), hk_pb(ilev), vact(ilev), & + tol_v) + + IF (vact(ilev)) THEN + + q_pb = q_this + q_wf_pb = q_wf + q_wt_pb = q_wt + + lev_update(:) = .false. + lev_update(ilev) = .true. + CALL flux_all ( & + lb, ub, sp_dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, .false., & + is_sat, has_wf, has_wt, & + wf_pb, vl_pb, wt_pb, ss_dp, zwt, psi_pb, hk_pb, & + q_pb, q_wf_pb, q_wt_pb, & + tol_q, tol_z, tol_p) + + CALL water_balance ( & + lb, ub, sp_dz, dt_this, is_sat, vl_s, q_pb, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + wf_pb, vl_pb, wt_pb, ss_dp, waquifer, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc_pb) + + dr_dv(:,ilev) = (blc_pb - blc) / dlt + + ENDIF + ENDIF + ENDDO + + IF (lbc_typ == BC_DRAINAGE) THEN + + CALL var_perturb_drainage (sp_zi(ub), blc(ub+1), zwt, zwt_pb, dlt, vact(ub+1)) + + IF (vact(ub+1)) THEN + q_pb = q_this + q_wf_pb = q_wf + q_wt_pb = q_wt + + waquifer_pb = - (zwt_pb - sp_zi(ub)) * (vl_s_wa & + - soil_vliq_from_psi (psi_s(ub)+(sp_zi(ub)-zwt_pb)*0.5, & + vl_s_wa, vl_r(ub), psi_s(ub), nprm, prms(:,ub))) + + lev_update(:) = .false. + lev_update(ub+1) = .true. + CALL flux_all ( & + lb, ub, sp_dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, .false., & + is_sat, has_wf, has_wt, & + ss_wf, ss_vl, ss_wt, ss_dp, zwt_pb, psi, hk, & + q_pb, q_wf_pb, q_wt_pb, & + tol_q, tol_z, tol_p) + + CALL water_balance ( & + lb, ub, sp_dz, dt_this, is_sat, vl_s, q_pb, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + ss_wf, ss_vl, ss_wt, ss_dp, waquifer_pb, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc_pb) + + dr_dv(:,ub+1) = (blc_pb - blc) / dlt + + ENDIF + + ENDIF + + DO ilev = lb-1, ub+1 + vact(ilev) = vact(ilev) .and. (abs(dr_dv(ilev,ilev)) > tol_q) + ENDDO + + CALL solve_least_squares_problem (ub-lb+3, dr_dv, vact, blc, dv) + + IF (vact(lb-1)) THEN + ss_dp = ss_dp - dv(lb-1) + ss_dp = max(ss_dp, 0._r8) + ENDIF + + DO ilev = lb, ub + IF (vact(ilev)) THEN + IF (jsbl(ilev) == 1) THEN + IF ((ss_wf(ilev) == sp_dz(ilev)) .and. (dv(ilev) > 0)) THEN + ss_wf(ilev) = ss_wf(ilev) - min(dv(ilev), sp_dz(ilev)) + + psi(ilev) = psi_s(ilev) + (1 - q_this(ilev)/hksat(ilev)) & + * min(dv(ilev),sp_dz(ilev)) * (sp_zc(ilev)-sp_zi(ilev-1))/sp_dz(ilev) + ss_vl(ilev) = soil_vliq_from_psi (psi(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), nprm, prms(:,ilev)) + hk(ilev) = soil_hk_from_psi (psi(ilev), & + psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSE + ss_wf(ilev) = ss_wf(ilev) - dv(ilev) + ss_wf(ilev) = max(ss_wf(ilev), 0._r8) + ss_wf(ilev) = min(ss_wf(ilev), sp_dz(ilev)-ss_wt(ilev)) + ENDIF + ENDIF + + IF (jsbl(ilev) == 2) THEN + ss_vl(ilev) = ss_vl(ilev) - dv(ilev) + ss_vl(ilev) = max(ss_vl(ilev), tol_v) + ss_vl(ilev) = min(ss_vl(ilev), vl_s(ilev)) + ENDIF + + IF (jsbl(ilev) == 3) THEN + IF ((ss_wt(ilev) == sp_dz(ilev)) .and. (dv(ilev) > 0)) THEN + ss_wt(ilev) = ss_wt(ilev) - min(dv(ilev), sp_dz(ilev)) + + psi(ilev) = psi_s(ilev) - (1 - q_this(ilev-1)/hksat(ilev)) & + * min(dv(ilev),sp_dz(ilev)) * (sp_zi(ilev)-sp_zc(ilev))/sp_dz(ilev) + ss_vl(ilev) = soil_vliq_from_psi (psi(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), nprm, prms(:,ilev)) + hk(ilev) = soil_hk_from_psi (psi(ilev), & + psi_s(ilev), hksat(ilev), nprm, prms(:,ilev)) + ELSE + ss_wt(ilev) = ss_wt(ilev) - dv(ilev) + ss_wt(ilev) = max(ss_wt(ilev), 0._r8) + ss_wt(ilev) = min(ss_wt(ilev), sp_dz(ilev)-ss_wf(ilev)) + ENDIF + ENDIF + ENDIF + + CALL check_and_update_level (sp_dz(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), hksat(ilev), & + nprm, prms(:,ilev), & + is_sat(ilev), has_wf(ilev), has_wt(ilev), & + ss_wf(ilev), ss_vl(ilev), ss_wt(ilev), psi(ilev), hk(ilev), & + jsbl(ilev) == 2, tol_v) + ENDDO + + IF (vact(ub+1)) THEN + zwt = zwt - dv(ub+1) + zwt = max(zwt, sp_zi(ub)) + waquifer = - (zwt - sp_zi(ub)) * (vl_s_wa & + - soil_vliq_from_psi (psi_s(ub)+(sp_zi(ub)-zwt)*0.5, & + vl_s_wa, vl_r(ub), psi_s(ub), nprm, prms(:,ub))) + ENDIF + + ENDDO + + ss_q = ss_q + q_this * dt_this + + wsum = sum(ss_vl * (sp_dz - ss_wt - ss_wf)) + sum((ss_wt + ss_wf) * vl_s) + IF (ubc_typ == BC_RAINFALL) THEN + wsum = wsum + ss_dp + ENDIF + IF (lbc_typ == BC_DRAINAGE) THEN + wsum = wsum + waquifer + ENDIF + + werr = wsum - (wsum_m1 + ubc_val * dt_this - lbc_val * dt_this) + + ENDDO + + ss_q = ss_q / dt + + DO ilev = lb, ub + IF (abs(sp_dz(ilev) - ss_wt(ilev)) > tol_z) THEN + ss_vl(ilev) = (ss_wf(ilev) * vl_s(ilev) & + + (sp_dz(ilev) - ss_wf(ilev) - ss_wt(ilev)) * ss_vl(ilev)) & + / (sp_dz(ilev) - ss_wt(ilev)) + ENDIF + ENDDO + + END SUBROUTINE Richards_solver + + + ! ---- water balance ---- + SUBROUTINE water_balance ( & + lb, ub, dz, dt, is_sat, vl_s, q, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + wf, vl, wt, dp, waquifer, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + blc, is_solvable, tol) + + integer, intent(in) :: lb, ub + + real(r8), intent(in) :: dz(lb:ub) + real(r8), intent(in) :: dt + + logical, intent(in) :: is_sat(lb:ub) + real(r8), intent(in) :: vl_s (lb:ub) + + real(r8), intent(in) :: q(lb-1:ub) + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + real(r8), intent(in) :: wf(lb:ub) + real(r8), intent(in) :: vl(lb:ub) + real(r8), intent(in) :: wt(lb:ub) + real(r8), intent(in) :: dp + real(r8), intent(in) :: waquifer + + real(r8), intent(in) :: wf_m1(lb:ub) + real(r8), intent(in) :: vl_m1(lb:ub) + real(r8), intent(in) :: wt_m1(lb:ub) + real(r8), intent(in) :: dp_m1 + real(r8), intent(in) :: waquifer_m1 + + real(r8), intent(out) :: blc(lb-1:ub+1) + logical, intent(out), optional :: is_solvable + real(r8), intent(in ), optional :: tol + + ! Local variables + integer :: ilev, jlev + real(r8) :: dmss, qsum + + blc(:) = 0 + + IF (ubc_typ == BC_RAINFALL) THEN + dmss = max(dp, 0._r8) - max(dp_m1, 0._r8) + qsum = ubc_val - q(lb-1) + blc(lb-1) = dmss - qsum * dt + ENDIF + + ilev = lb - 1 + DO jlev = lb, ub + + dmss = (vl_s(jlev) - vl_m1(jlev)) * (wf(jlev) - wf_m1(jlev)) + dmss = (vl_s(jlev) - vl_m1(jlev)) * (wt(jlev) - wt_m1(jlev)) + dmss + dmss = (dz(jlev) - wt(jlev) - wf(jlev)) * (vl(jlev) - vl_m1(jlev)) + dmss + + qsum = q(jlev-1) - q(jlev) + + IF (.not. is_sat(jlev)) THEN + + ilev = jlev + + IF ((ubc_typ /= BC_RAINFALL) .and. (blc(lb-1) /= 0)) THEN + blc(ilev) = blc(ilev) + blc(lb-1) + blc(lb-1) = 0 + ENDIF + ENDIF + + blc(ilev) = blc(ilev) + dmss - qsum * dt + + ENDDO + + IF (lbc_typ == BC_DRAINAGE) THEN + IF ((waquifer == 0) .and. (q(ub) >= 0)) THEN + blc(ilev) = blc(ilev) - waquifer_m1 - q(ub) * dt + ELSE + blc(ub+1) = waquifer - waquifer_m1 - q(ub) * dt + + IF ((ubc_typ /= BC_RAINFALL) .and. (blc(lb-1) /= 0)) THEN + blc(ub+1) = blc(ub+1) + blc(lb-1) + blc(lb-1) = 0 + ENDIF + ENDIF + ENDIF + + IF (present(is_solvable)) THEN + IF (present(tol)) THEN + is_solvable = (ubc_typ == BC_RAINFALL) .or. (blc(lb-1) < tol) + ELSE + is_solvable = (ubc_typ == BC_RAINFALL) .or. (blc(lb-1) == 0) + ENDIF + ENDIF + + END SUBROUTINE water_balance + + ! ---- initialize sublevel structure ---- + SUBROUTINE initialize_sublevel_structure ( & + lb, ub, dz, zbtm, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + is_sat, has_wf, has_wt, & + wf, vl, wt, dp, psi, hk, & + tol_v, tol_z) + + integer, intent(in) :: lb, ub + real(r8), intent(in) :: dz (lb:ub) + real(r8), intent(in) :: zbtm + + real(r8), intent(in) :: vl_s (lb:ub) + real(r8), intent(in) :: vl_r (lb:ub) + real(r8), intent(in) :: psi_s (lb:ub) + real(r8), intent(in) :: hksat (lb:ub) + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms (nprm,lb:ub) + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + logical, intent(inout) :: is_sat(lb:ub) + logical, intent(inout) :: has_wf(lb:ub) + logical, intent(inout) :: has_wt(lb:ub) + + real(r8), intent(inout) :: wf(lb:ub) + real(r8), intent(inout) :: vl(lb:ub) + real(r8), intent(inout) :: wt(lb:ub) + real(r8), intent(inout) :: dp + + real(r8), intent(inout) :: psi(lb:ub) + real(r8), intent(inout) :: hk (lb:ub) + + real(r8), intent(in) :: tol_v + real(r8), intent(in) :: tol_z + + ! Local variables + integer :: ilev + + DO ilev = lb, ub + is_sat(ilev) = (abs(vl(ilev) - vl_s(ilev)) < tol_v) & + .or. (abs(wf(ilev) + wt(ilev) - dz(ilev)) < tol_z) + ENDDO + + IF (ubc_typ == BC_FIX_HEAD) THEN + IF (ubc_val < psi_s(lb)) THEN + IF (is_sat(lb)) THEN + is_sat(lb) = .false. + + wf(lb) = 0 + vl(lb) = vl_s(lb) + wt(lb) = 0.9 * dz(lb) + ELSEIF (wf(lb) >= tol_z) THEN + vl(lb) = (wf(lb)*vl_s(lb) + vl(lb)*(dz(lb)-wf(lb)-wt(lb))) / (dz(lb)-wt(lb)) + wf(lb) = 0 + ENDIF + ENDIF + ENDIF + + IF (lbc_typ == BC_FIX_HEAD) THEN + IF (lbc_val < psi_s(ub)) THEN + IF (is_sat(ub)) THEN + is_sat(ub) = .false. + + wf(ub) = 0.9 * dz(ub) + vl(ub) = vl_s(ub) + wt(ub) = 0 + ELSEIF (wt(ub) >= tol_z) THEN + vl(ub) = (wt(ub)*vl_s(ub) + vl(ub)*(dz(ub)-wf(ub)-wt(ub))) / (dz(ub)-wf(ub)) + wt(ub) = 0 + ENDIF + ENDIF + ENDIF + + DO ilev = lb, ub + IF (is_sat(ilev)) THEN + wf(ilev) = 0 + wt(ilev) = dz(ilev) + vl(ilev) = vl_s(ilev) + ELSE + IF (ilev > lb) THEN + IF (is_sat(ilev-1)) THEN + has_wf(ilev) = .true. + ELSE + has_wf(ilev) = (wf(ilev) >= tol_z) .or. (wt(ilev-1) >= tol_z) + ENDIF + + IF (has_wf(ilev)) THEN + IF ((wf(ilev) < tol_z) .and. (psi_s(ilev) < psi_s(ilev-1))) THEN + wf(ilev) = 0.1 * (dz(ilev)-wt(ilev)) + ENDIF + ENDIF + ELSE + SELECTCASE (ubc_typ) + CASE (BC_RAINFALL) + has_wf(lb) = (dp >= tol_z) .or. (wf(lb) >= tol_z) + CASE (BC_FIX_HEAD) + has_wf(lb) = (ubc_val > psi_s(lb)) .or. (wf(lb) >= tol_z) + + IF (has_wf(lb) .and. (wf(lb) < tol_z)) THEN + wf(lb) = 0.01 * (dz(lb)-wt(lb)) + ENDIF + CASE (BC_FIX_FLUX) + has_wf(lb) = wf(lb) >= tol_z + ENDSELECT + ENDIF + + IF (ilev < ub) THEN + IF (is_sat(ilev+1)) THEN + has_wt(ilev) = .true. + ELSE + has_wt(ilev) = (wt(ilev) >= tol_z) .or. (wf(ilev+1) >= tol_z) + ENDIF + + IF (has_wt(ilev)) THEN + IF ((wt(ilev) < tol_z) .and. (psi_s(ilev) < psi_s(ilev+1))) THEN + wt(ilev) = 0.1 * (dz(ilev)-wf(ilev)) + ENDIF + ENDIF + ELSE + SELECTCASE (lbc_typ) + CASE (BC_DRAINAGE) + has_wt(ub) = (wt(ub) >= tol_z) + CASE (BC_FIX_HEAD) + has_wt(ub) = (lbc_val > psi_s(ub)) .or. (wt(ub) >= tol_z) + + IF ((has_wt(ub)) .and. (wt(ub) < tol_z)) THEN + wt(ub) = 0.01 * (dz(ub)-wf(ub)) + ENDIF + CASE (BC_FIX_FLUX) + has_wt(ub) = (wt(ub) >= tol_z) + ENDSELECT + ENDIF + ENDIF + + CALL check_and_update_level ( dz(ilev), & + vl_s(ilev), vl_r(ilev), psi_s(ilev), hksat(ilev), & + nprm, prms(:,ilev), & + is_sat(ilev), has_wf(ilev), has_wt(ilev), & + wf(ilev), vl(ilev), wt(ilev), psi(ilev), hk(ilev), & + .true., tol_v) + ENDDO + + END SUBROUTINE initialize_sublevel_structure + + !----------------------------------------------------------------------- + SUBROUTINE use_explicit_form ( & + lb, ub, dt, dz, sp_zc, sp_zi, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + vl_s_wa, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + q, q_wf, q_wt, wf, vl, wt, dp, waquifer, zwt, & + wf_m1, vl_m1, wt_m1, dp_m1, waquifer_m1, & + tol_q, tol_z, tol_v) + + integer, intent(in) :: lb, ub + + real(r8), intent(in) :: dt + + real(r8), intent(in) :: dz (lb:ub) + real(r8), intent(in) :: sp_zc (lb:ub) + real(r8), intent(in) :: sp_zi(lb-1:ub) + + real(r8), intent(in) :: vl_s (lb:ub) + real(r8), intent(in) :: vl_r (lb:ub) + real(r8), intent(in) :: psi_s (lb:ub) + real(r8), intent(in) :: hksat (lb:ub) + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm,lb:ub) + + real(r8), intent(in) :: vl_s_wa + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + real(r8), intent(inout) :: q (lb-1:ub) + real(r8), intent(in) :: q_wf (lb:ub) + real(r8), intent(in) :: q_wt (lb:ub) + + real(r8), intent(inout) :: wf (lb:ub) + real(r8), intent(inout) :: vl (lb:ub) + real(r8), intent(inout) :: wt (lb:ub) + real(r8), intent(inout) :: dp + real(r8), intent(inout) :: waquifer + real(r8), intent(inout) :: zwt + + real(r8), intent(in) :: wf_m1 (lb:ub) + real(r8), intent(in) :: vl_m1 (lb:ub) + real(r8), intent(in) :: wt_m1 (lb:ub) + real(r8), intent(in) :: dp_m1 + real(r8), intent(in) :: waquifer_m1 + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_v + + ! Local variables + integer :: ilev + real(r8) :: air_m1, wa_m1, dwat, dwat_s + real(r8) :: alp, zwf_this, zwt_this, vl_wa + + real(r8) :: dmss, mblc + + ! depleted : decrease outflux from top down + IF (ubc_typ == BC_RAINFALL) THEN + IF (dp_m1 < - (ubc_val - q(lb-1))*dt) THEN + q(lb-1) = dp_m1/dt + ubc_val + ENDIF + ENDIF + + DO ilev = lb, ub + + dwat = (q(ilev-1) - q(ilev)) * dt + wa_m1 = (wt_m1(ilev)+wf_m1(ilev)) * vl_s(ilev) & + + (dz(ilev)-wt_m1(ilev)-wf_m1(ilev)) * vl_m1(ilev) + IF (dwat <= - wa_m1) THEN + q(ilev) = q(ilev-1) + wa_m1/dt + ENDIF + + ENDDO + + IF ((lbc_typ == BC_FIX_FLUX) .and. (q(ub) < lbc_val)) THEN + + q(ub) = lbc_val + DO ilev = ub, lb, -1 + dwat = (q(ilev-1) - q(ilev)) * dt + wa_m1 = (wt_m1(ilev)+wf_m1(ilev)) * vl_s(ilev) & + + (dz(ilev)-wt_m1(ilev)-wf_m1(ilev)) * vl_m1(ilev) + IF (dwat <= - wa_m1) THEN + q(ilev-1) = q(ilev) - wa_m1/dt + ENDIF + ENDDO + + ENDIF + + ! overfilled : increase influx from bottom up + IF (lbc_typ == BC_DRAINAGE) THEN + IF (q(ub)*dt > -waquifer_m1) THEN + q(ub) = - waquifer_m1/dt + ENDIF + ENDIF + + DO ilev = ub, lb, -1 + + dwat = (q(ilev-1) - q(ilev)) * dt + air_m1 = (vl_s(ilev) - vl_m1(ilev)) * (dz(ilev) - wt_m1(ilev) - wf_m1(ilev)) + IF (dwat >= air_m1) THEN + q(ilev-1) = q(ilev) + air_m1/dt + ENDIF + + ENDDO + + IF ((ubc_typ == BC_FIX_FLUX) .and. (q(lb-1) < ubc_val)) THEN + + q(lb-1) = ubc_val + DO ilev = lb, ub + dwat = (q(ilev-1) - q(ilev)) * dt + air_m1 = (vl_s(ilev) - vl_m1(ilev)) * (dz(ilev) - wt_m1(ilev) - wf_m1(ilev)) + IF (dwat >= air_m1) THEN + q(ilev) = q(ilev-1) - air_m1/dt + ENDIF + ENDDO + + ENDIF + + ! update prognostic variables : dp, wf, vl, wt, zwt + IF (ubc_typ == BC_RAINFALL) THEN + dp = max(0., dp_m1 + (ubc_val - q(lb-1))*dt) + ENDIF + + DO ilev = lb, ub + + dwat = (q(ilev-1) - q(ilev)) * dt + + wt(ilev) = 0. + wf(ilev) = 0. + vl(ilev) = ((wt_m1(ilev)+wf_m1(ilev)) * vl_s(ilev) & + + (dz(ilev)-wt_m1(ilev)-wf_m1(ilev)) * vl_m1(ilev) + dwat) / dz(ilev) + + ENDDO + + IF (lbc_typ == BC_DRAINAGE) THEN + waquifer = waquifer_m1 + q(ub)*dt + CALL get_zwt_from_wa ( & + vl_s_wa, vl_r(ub), psi_s(ub), hksat(ub), nprm, prms(:,ub), tol_v, tol_z, & + waquifer, sp_zi(ub), zwt) + ENDIF + + END SUBROUTINE use_explicit_form + + !---------------------------------------------------------------------- + SUBROUTINE var_perturb_level ( jsbl, blc, & + dz, zc, zi, vl_s, vl_r, psi_s, hksat, nprm, prms, & + is_sat, has_wf, has_wt, qin, qout, q_wf, q_wt, & + wf_p, vl_p, wt_p, delta, psi_p, hk_p, is_act, & + tol_v) + + integer, intent(out) :: jsbl + + real(r8), intent(in) :: blc + + real(r8), intent(in) :: dz, zc, zi + real(r8), intent(in) :: vl_s, vl_r, psi_s, hksat + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + logical, intent(in) :: is_sat, has_wf, has_wt + real(r8), intent(in) :: qin, qout, q_wf, q_wt + + real(r8), intent(inout) :: wf_p, vl_p, wt_p + real(r8), intent(out) :: delta + real(r8), intent(inout) :: psi_p, hk_p + logical, intent(out) :: is_act + + real(r8), intent(in) :: tol_v + + ! Local variables + real(r8), parameter :: vstep = 1.0e-6_r8 + real(r8), parameter :: wstep = 1.0e-1_r8 + + jsbl = 2 + + IF (has_wt) THEN + + IF ((wt_p == dz) .or. & + ((blc >= 0) .and. (q_wt < qout) .and. (wt_p > 0) .and. (vl_p < vl_s))) THEN + ! reduce water table + + jsbl = 3 + + delta = - min(wstep, wt_p * 0.1_r8) + + IF (wt_p == dz) THEN + psi_p = psi_s - (1 - qin/hksat) * (-delta)*(zi-zc)/dz + vl_p = soil_vliq_from_psi (psi_p, vl_s, vl_r, psi_s, nprm, prms) + hk_p = soil_hk_from_psi (psi_p, psi_s, hksat, nprm, prms) + ENDIF + + wt_p = wt_p + delta + + ELSEIF ((blc < 0) .and. (q_wt > qout) .and. (vl_p < vl_s)) THEN + ! increase water table + + jsbl = 3 + + delta = min(wstep, (dz - wf_p - wt_p) * 0.1_r8) + wt_p = wt_p + delta + + ENDIF + + ENDIF + + IF ((jsbl == 2) .and. has_wf) THEN + + IF ((wf_p == dz) .or. & + ((blc >= 0) .and. (qin < q_wf) .and. (wf_p > 0) .and. (vl_p < vl_s))) THEN + ! reduce wetting front + + jsbl = 1 + + delta = - min(wstep, wf_p * 0.1_r8) + IF (wf_p == dz) THEN + psi_p = psi_s + (1 - qout/hksat) * (-delta)*(dz-(zi-zc))/dz + vl_p = soil_vliq_from_psi (psi_p, vl_s, vl_r, psi_s, nprm, prms) + hk_p = soil_hk_from_psi (psi_p, psi_s, hksat, nprm, prms) + ENDIF + + wf_p = wf_p + delta + + ELSEIF ((blc < 0) .and. (qin > q_wf) .and. (vl_p < vl_s)) THEN + ! increase wetting front + + jsbl = 1 + + delta = min(wstep, (dz - wf_p - wt_p) * 0.1_r8) + wf_p = wf_p + delta + + ENDIF + + ENDIF + + IF (jsbl == 2) THEN + + IF (((blc > 0) .and. (vl_p > vl_r + tol_v)) .or. (vl_p >= vl_s)) THEN + ! reduce water content + delta = - min(vstep, (vl_p - vl_r - tol_v) * 0.5_r8) + ELSEIF (((blc <= 0) .and. (vl_p < vl_s)) .or. (vl_p <= vl_r+tol_v)) THEN + ! increase water content + delta = + min(vstep, (vl_s - vl_p) * 0.5_r8) + ELSE + delta = 0 + ENDIF + + vl_p = vl_p + delta + + ENDIF + + is_act = (delta /= 0) + + IF (is_act) THEN + CALL check_and_update_level (dz, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + is_sat, has_wf, has_wt, wf_p, vl_p, wt_p, psi_p, hk_p, & + jsbl == 2, tol_v) + ENDIF + + END SUBROUTINE var_perturb_level + + !---------------------------------------------------------------- + SUBROUTINE var_perturb_rainfall ( & + blc_srf, dp, dp_p, delta, is_act) + + real(r8), intent(in) :: blc_srf + + real(r8), intent(in) :: dp + real(r8), intent(out) :: dp_p + real(r8), intent(out) :: delta + logical, intent(out) :: is_act + + ! Local variables + real(r8), parameter :: wstep = 1.0e-1_r8 + + delta = 0 + + IF (blc_srf > 0) THEN + IF (dp > 0) THEN + delta = - min(wstep, dp * 0.5_r8) + ENDIF + ELSEIF (blc_srf < 0) THEN + delta = wstep + ENDIF + + dp_p = dp + delta + is_act = (delta /= 0) + + END SUBROUTINE var_perturb_rainfall + + !---------------------------------------------------------------- + SUBROUTINE var_perturb_drainage ( & + zmin, blc_btm, zwt, zwt_p, delta, is_act) + + real(r8), intent(in) :: zmin + + real(r8), intent(in) :: blc_btm + + real(r8), intent(in) :: zwt + real(r8), intent(out) :: zwt_p + real(r8), intent(out) :: delta + logical, intent(out) :: is_act + + ! Local variables + real(r8), parameter :: wstep = 1.0e-1_r8 + + delta = 0 + + IF (blc_btm > 0) THEN + delta = wstep + ELSEIF (blc_btm < 0) THEN + delta = - min(max((zwt-zmin)*0.5_r8,0.0), wstep) + ENDIF + + zwt_p = zwt + delta + is_act = (delta /= 0) + + END SUBROUTINE var_perturb_drainage + + + !---------------------------------------------------------------- + SUBROUTINE check_and_update_level ( dz, & + vl_s, vl_r, psi_s, hksat, nprm, prms, & + is_sat, has_wf, has_wt, & + wf, vl, wt, psi, hk, & + is_update_psi_hk, tol_v) + + real(r8), intent(in) :: dz + real(r8), intent(in) :: vl_s, vl_r, psi_s, hksat + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + logical, intent(in) :: is_sat, has_wf, has_wt + + real(r8), intent(inout) :: wf, vl, wt + real(r8), intent(inout) :: psi, hk + + logical, intent(in) :: is_update_psi_hk + + real(r8), intent(in) :: tol_v + + ! Local variables + real(r8) :: alpha + + IF (.not. is_sat) THEN + + IF (has_wf) THEN + wf = min(max(wf, 0._r8), dz) + ELSE + wf = 0 + ENDIF + + IF (has_wt) THEN + wt = min(max(wt, 0._r8), dz) + ELSE + wt = 0 + ENDIF + + IF (has_wf .and. has_wt) THEN + IF (wf + wt > dz) THEN + alpha = wf / (wf + wt) + wf = dz * alpha + wt = dz * (1.0_r8 - alpha) + ENDIF + ENDIF + + vl = min(vl, vl_s) + vl = max(vl, tol_v) + + IF (is_update_psi_hk) THEN + psi = soil_psi_from_vliq (vl, vl_s, vl_r, psi_s, nprm, prms) + hk = soil_hk_from_psi (psi, psi_s, hksat, nprm, prms) + ENDIF + ELSE + vl = vl_s + psi = psi_s + hk = hksat + ENDIF + + END SUBROUTINE check_and_update_level + + + !---------------------------------------------------------------------- + SUBROUTINE flux_all ( & + lb, ub, dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + lev_update, is_update_sublevel, & + is_sat, has_wf, has_wt, & + wf, vl, wt, dp, zwt, psi_us, hk_us, & + qq, qq_wf, qq_wt, & + tol_q, tol_z, tol_p) + + integer, intent(in) :: lb, ub + + real(r8), intent(in) :: dz (lb:ub) + real(r8), intent(in) :: sp_zc (lb:ub) + real(r8), intent(in) :: sp_zi (lb-1:ub) + + real(r8), intent(in) :: vl_s (lb:ub) + real(r8), intent(in) :: psi_s (lb:ub) + real(r8), intent(in) :: hksat (lb:ub) + integer, intent(in) :: nprm + real(r8), intent(in) :: prms (nprm,lb:ub) + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + logical, intent(in) :: lev_update (lb-1:ub+1) + logical, intent(in) :: is_update_sublevel + + logical, intent(inout) :: is_sat (lb:ub) + logical, intent(inout) :: has_wf (lb:ub) + logical, intent(inout) :: has_wt (lb:ub) + + real(r8), intent(inout) :: wf (lb:ub) + real(r8), intent(inout) :: vl (lb:ub) + real(r8), intent(inout) :: wt (lb:ub) + real(r8), intent(inout) :: dp + real(r8), intent(inout) :: zwt + real(r8), intent(in) :: psi_us (lb:ub) + real(r8), intent(in) :: hk_us (lb:ub) + + real(r8), intent(inout) :: qq (lb-1:ub) + real(r8), intent(inout) :: qq_wf (lb:ub) + real(r8), intent(inout) :: qq_wt (lb:ub) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + ! Local variables + integer :: ilev_u, ilev_l + real(r8) :: hk_top, pbtm, hk_btm + real(r8) :: dz_this, dz_upp, dz_low + logical :: has_sat_zone + real(r8) :: psi_i, hk_i + real(r8) :: qtest + + + ilev_u = lb - 1 + ilev_l = find_unsat_lev_lower (is_sat, lb, ub, ilev_u+1) + + DO WHILE (.true.) + + IF (lev_update(ilev_u) .or. lev_update(ilev_l)) THEN + + IF (ilev_l == lb) THEN + ! CASE 1: water flux on top + + dz_this = (dz(lb)-wt(lb)-wf(lb)) * (sp_zc(lb)-sp_zi(lb-1))/dz(lb) + + SELECTCASE (ubc_typ) + CASE (BC_FIX_HEAD) + + IF (has_wf(lb)) THEN + qq(lb-1) = - hksat(lb) * ((psi_s(lb) - ubc_val) / wf(lb) - 1) + ELSE + hk_top = soil_hk_from_psi (ubc_val, & + psi_s(lb), hksat(lb), nprm, prms(:,lb)) + qq(lb-1) = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, ubc_val, psi_us(lb), hk_top, hk_us(lb)) + ENDIF + + CASE (BC_RAINFALL) + + IF (has_wf(lb) .and. (wf(lb) >= tol_z)) THEN + + qq(lb-1) = - hksat(lb) * ((psi_s(lb) - dp) / wf(lb) - 1) + + ELSE + + IF (dp > tol_z) THEN + qq(lb-1) = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, dp, psi_us(lb), hksat(lb), hk_us(lb)) + ELSE + qtest = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, psi_s(lb), psi_us(lb), hksat(lb), hk_us(lb)) + + qq(lb-1) = min(ubc_val, qtest) + + IF (is_update_sublevel) THEN + IF (qq(lb-1) > qtest) THEN + has_wf(lb) = .true. + wf(lb) = 0.0 + ENDIF + ENDIF + ENDIF + + ENDIF + + CASE (BC_FIX_FLUX) + + qq(lb-1) = ubc_val + + IF (is_update_sublevel) THEN + IF ((.not. has_wf(lb)) .and. (ubc_val > hksat(lb))) THEN + qtest = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, psi_s(lb), psi_us(lb), hksat(lb), hk_us(lb)) + IF (qq(lb-1) > qtest) THEN + has_wf(lb) = .true. + wf(lb) = 0.0 + ENDIF + ENDIF + ENDIF + + ENDSELECT + + IF ((has_wf(lb)) .and. (dz_this >= tol_z)) THEN + qq_wf(lb) = flux_inside_hm_soil ( & + psi_s(lb), hksat(lb), nprm, prms(:,lb), & + dz_this, psi_s(lb), psi_us(lb), hksat(lb), hk_us(lb)) + ELSE + IF (has_wf(lb)) THEN + qq_wf(lb) = qq(lb) + ELSE + qq_wf(lb) = qq(lb-1) + ENDIF + ENDIF + + ELSEIF (ilev_u == ub) THEN + ! CASE 2: water flux at bottom + + dz_this = (dz(ub) - wf(ub) - wt(ub)) * (sp_zi(ub) - sp_zc(ub))/ dz(ub) + + SELECTCASE (lbc_typ) + CASE (BC_FIX_HEAD) + + IF (has_wt(ub)) THEN + qq(ub) = - hksat(ub) * ((lbc_val - psi_s(ub))/wt(ub) - 1) + ELSE + hk_btm = soil_hk_from_psi (lbc_val, & + psi_s(ub), hksat(ub), nprm, prms(:,ub)) + qq(ub) = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), lbc_val, hk_us(ub), hk_btm) + ENDIF + + CASE (BC_DRAINAGE) + + IF (has_wt(ub)) THEN + IF (zwt > sp_zi(ub)) THEN + qq(ub) = hksat(ub) + ELSE + qq(ub) = 0 + ENDIF + ELSE + IF (zwt > sp_zi(ub)) THEN + pbtm = psi_s(ub) + sp_zi(ub) - zwt + hk_btm = soil_hk_from_psi (pbtm, & + psi_s(ub), hksat(ub), nprm, prms(:,ub)) + qq(ub) = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), pbtm, hk_us(ub), hk_btm) + ELSE + qq(ub) = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), psi_s(ub), hk_us(ub), hksat(ub)) + + IF (is_update_sublevel) THEN + IF (qq(ub) > 0) THEN + has_wt(ub) = .true. + wt(ub) = 0 + qq(ub) = 0 + ENDIF + ENDIF + ENDIF + ENDIF + + CASE (BC_FIX_FLUX) + + qq(ub) = lbc_val + + IF (is_update_sublevel) THEN + IF ((.not. has_wt(ub)) .and. (lbc_val < hksat(ub))) THEN + qtest = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), psi_s(ub), hk_us(ub), hksat(ub)) + + IF (qtest > lbc_val) THEN + has_wt(ub) = .true. + wt(ub) = 0 + ENDIF + ENDIF + ENDIF + + ENDSELECT + + IF ((has_wt(ub)) .and. (dz_this >= tol_z)) THEN + qq_wt(ub) = flux_inside_hm_soil ( & + psi_s(ub), hksat(ub), nprm, prms(:,ub), & + dz_this, psi_us(ub), psi_s(ub), hk_us(ub), hksat(ub)) + ELSE + IF (has_wt(ub)) THEN + qq_wt(ub) = qq(ub-1) + ELSE + qq_wt(ub) = qq(ub) + ENDIF + ENDIF + + ELSE + ! CASE 3: inside soil column + + IF ((ilev_u == lb-1) .or. (ilev_l == ub+1)) THEN + has_sat_zone = .true. + ELSEIF (has_wf(ilev_l)) THEN + has_sat_zone = .true. + IF (ilev_l == ilev_u+1) THEN + IF ((wf(ilev_l) < tol_z) .and. (wt(ilev_u) < tol_z)) THEN + has_sat_zone = .false. + ENDIF + ENDIF + ELSE + has_sat_zone = .false. + ENDIF + + IF (has_sat_zone) THEN + ! CASE 3(1): inside soil column, saturated zone + CALL flux_sat_zone_all ( & + lb, ub, max(ilev_u,lb), min(ilev_l,ub), & + dz, sp_zc, sp_zi, vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + is_sat, has_wf, has_wt, is_update_sublevel, & + wf, vl, wt, dp, zwt, psi_us, hk_us, & + qq, qq_wt, qq_wf, tol_q, tol_z, tol_p) + + ELSE + ! CASE 3(2): inside soil column, unsaturated zone + + dz_upp = (dz(ilev_u) - wf(ilev_u)) * (sp_zi(ilev_u)-sp_zc(ilev_u))/dz(ilev_u) + dz_low = (dz(ilev_l) - wt(ilev_l)) * (sp_zc(ilev_l)-sp_zi(ilev_u))/dz(ilev_l) + + IF ((dz_upp >= tol_z) .and. (dz_low >= tol_z)) THEN + + CALL flux_at_unsaturated_interface (nprm, & + psi_s(ilev_u), hksat(ilev_u), prms(:,ilev_u), dz_upp, psi_us(ilev_u), hk_us(ilev_u), & + psi_s(ilev_l), hksat(ilev_l), prms(:,ilev_l), dz_low, psi_us(ilev_l), hk_us(ilev_l), & + qq_wt(ilev_u), qq_wf(ilev_l), tol_q, tol_p) + + IF (abs(qq_wt(ilev_u) - qq_wf(ilev_l)) < tol_q) THEN + + qq(ilev_u) = (qq_wt(ilev_u) + qq_wf(ilev_l)) * 0.5_r8 + qq_wt(ilev_u) = qq(ilev_u) + qq_wf(ilev_l) = qq(ilev_u) + + IF (is_update_sublevel) THEN + has_wt(ilev_u) = .false. + has_wf(ilev_l) = .false. + ENDIF + + ELSEIF (qq_wt(ilev_u) > qq_wf(ilev_l)) THEN + IF (is_update_sublevel) THEN + has_wt(ilev_u) = .true. + wt(ilev_u) = 0 + + has_wf(ilev_l) = .true. + wf(ilev_l) = 0 + ENDIF + + IF (has_wt(ilev_u) .and. has_wf(ilev_l)) THEN + IF (psi_s(ilev_u) >= psi_s(ilev_l)) THEN + qq(ilev_u) = qq_wt(ilev_u) + ELSE + qq(ilev_u) = qq_wf(ilev_l) + ENDIF + ELSE + qq(ilev_u) = (qq_wt(ilev_u) + qq_wf(ilev_l)) * 0.5_r8 + ENDIF + ENDIF + + ELSEIF ((dz_upp >= tol_z) .and. (dz_low < tol_z)) THEN + + psi_i = min(psi_s(ilev_u), psi_s(ilev_l)) + hk_i = soil_hk_from_psi (psi_i, & + psi_s(ilev_u), hksat(ilev_u), nprm, prms(:,ilev_u)) + qq(ilev_u) = flux_inside_hm_soil ( & + psi_s(ilev_u), hksat(ilev_u), nprm, prms(:,ilev_u), & + dz_upp, psi_us(ilev_u), psi_i, hk_us(ilev_u), hk_i) + + qq_wt(ilev_u) = qq(ilev_u) + qq_wf(ilev_l) = qq(ilev_u) + qq_wt(ilev_l) = qq(ilev_u) + + ELSEIF ((dz_upp < tol_z) .and. (dz_low >= tol_z)) THEN + + psi_i = min(psi_s(ilev_u), psi_s(ilev_l)) + hk_i = soil_hk_from_psi (psi_i, & + psi_s(ilev_l), hksat(ilev_l), nprm, prms(:,ilev_l)) + qq(ilev_u) = flux_inside_hm_soil ( & + psi_s(ilev_l), hksat(ilev_l), nprm, prms(:,ilev_l), & + dz_low, psi_i, psi_us(ilev_l), hk_i, hk_us(ilev_l)) + + qq_wf(ilev_u) = qq(ilev_u) + qq_wt(ilev_u) = qq(ilev_u) + qq_wf(ilev_l) = qq(ilev_u) + + ELSEIF ((dz_upp < tol_z) .and. (dz_low < tol_z)) THEN + ! This CASE does not exist in principle. + + qq(ilev_u) = min(hksat(ilev_u), hksat(ilev_l)) + + qq_wf(ilev_u) = qq(ilev_u) + qq_wt(ilev_u) = qq(ilev_u) + qq_wf(ilev_l) = qq(ilev_u) + qq_wt(ilev_l) = qq(ilev_u) + + ENDIF + ENDIF + + ENDIF + ENDIF + + IF (ilev_l == ub+1) THEN + EXIT + ELSE + ilev_u = ilev_l + ilev_l = find_unsat_lev_lower (is_sat, lb, ub, ilev_u+1) + ENDIF + ENDDO + + END SUBROUTINE flux_all + + + !------------------------------------------------------------------- + SUBROUTINE flux_sat_zone_all ( & + lb, ub, i_stt, i_end, dz, sp_zc, sp_zi, & + vl_s, psi_s, hksat, nprm, prms, & + ubc_typ, ubc_val, lbc_typ, lbc_val, & + is_sat, has_wf, has_wt, is_update_sublevel, & + wf, vl, wt, wdsrf, zwt, psi_us, hk_us, & + qq, qq_wt, qq_wf, tol_q, tol_z, tol_p) + + integer, intent(in) :: lb, ub + integer, intent(in) :: i_stt, i_end + + real(r8), intent(in) :: dz (lb:ub) + real(r8), intent(in) :: sp_zc (lb:ub) + real(r8), intent(in) :: sp_zi (lb-1:ub) + + real(r8), intent(in) :: vl_s (lb:ub) + real(r8), intent(in) :: psi_s (lb:ub) + real(r8), intent(in) :: hksat (lb:ub) + integer, intent(in) :: nprm + real(r8), intent(in) :: prms (nprm,lb:ub) + + integer, intent(in) :: ubc_typ + real(r8), intent(in) :: ubc_val + integer, intent(in) :: lbc_typ + real(r8), intent(in) :: lbc_val + + logical, intent(inout) :: is_sat (lb:ub) + logical, intent(inout) :: has_wf (lb:ub) + logical, intent(inout) :: has_wt (lb:ub) + logical, intent(in) :: is_update_sublevel + + real(r8), intent(inout) :: wf (lb:ub) + real(r8), intent(inout) :: vl (lb:ub) + real(r8), intent(inout) :: wt (lb:ub) + real(r8), intent(in) :: wdsrf + real(r8), intent(in) :: zwt + real(r8), intent(in) :: psi_us (lb:ub) + real(r8), intent(in) :: hk_us (lb:ub) + + real(r8), intent(inout) :: qq (lb-1:ub) + real(r8), intent(inout) :: qq_wt (lb:ub) + real(r8), intent(inout) :: qq_wf (lb:ub) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + ! Local variables + logical :: top_at_ground, top_at_interface, top_inside_level + logical :: btm_at_bottom, btm_at_interface, btm_inside_level + + integer :: i_s, i_e, ilev, iface + + integer :: nlev_sat + real(r8), allocatable :: qlc (:) + real(r8), allocatable :: dz_sat (:) + real(r8), allocatable :: psi_sat (:) + real(r8), allocatable :: hk_sat (:) + + real(r8) :: ptop, pbtm, qtop, qupper, qlower + real(r8) :: dz_us_top, dz_us_btm + + logical :: is_trans + + top_at_ground = (i_stt == lb) .and. is_sat(i_stt) + top_at_interface = (.not. top_at_ground) .and. (wt(i_stt) < tol_z) + top_inside_level = .not. (top_at_ground .or. top_at_interface) + + btm_at_bottom = (i_end == ub) .and. is_sat(i_end) + btm_at_interface = (.not. btm_at_bottom) .and. (wf(i_end) < tol_z) + btm_inside_level = .not. (btm_at_bottom .or. btm_at_interface) + + IF (top_at_interface) THEN + i_s = i_stt + 1 + ELSE + i_s = i_stt + ENDIF + + IF (btm_at_interface) THEN + i_e = i_end - 1 + ELSE + i_e = i_end + ENDIF + + nlev_sat = i_e - i_s + 1 + + allocate (dz_sat (i_s:i_e)) + allocate (psi_sat (i_s:i_e)) + allocate (hk_sat (i_s:i_e)) + allocate (qlc (i_s:i_e)) + + DO ilev = i_s, i_e + dz_sat (ilev) = dz (ilev) + psi_sat(ilev) = psi_s(ilev) + hk_sat (ilev) = hksat(ilev) + ENDDO + + IF (top_inside_level) dz_sat(i_s) = wt(i_stt) + IF (btm_inside_level) dz_sat(i_e) = wf(i_end) + + IF (.not. top_at_ground) THEN + dz_us_top = (dz(i_stt) - wt(i_stt) - wf(i_stt)) & + * (sp_zi(i_stt) - sp_zc(i_stt)) / dz(i_stt) + ENDIF + + IF (.not. btm_at_bottom) THEN + dz_us_btm = (dz(i_end) - wt(i_end) - wf(i_end)) & + * (sp_zc(i_end) - sp_zi(i_end-1)) / dz(i_end) + ENDIF + + ! Case 1 + IF (top_at_ground .and. btm_at_bottom) THEN + + ! Case 1-1 + IF ((ubc_typ == BC_FIX_HEAD) .and. (lbc_typ == BC_FIX_HEAD)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, ubc_val, lbc_val, qlc) + ENDIF + + ! Case 1-2 + IF ((ubc_typ == BC_RAINFALL) .and. (lbc_typ == BC_FIX_HEAD)) THEN + + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, wdsrf, lbc_val, qlc) + + ENDIF + + ! Case 1-3 + IF ((ubc_typ == BC_FIX_FLUX) .and. (lbc_typ == BC_FIX_HEAD)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(lb), lbc_val, qlc, & + flux_top = ubc_val) + ENDIF + + ! Case 1-4 + IF ((ubc_typ == BC_FIX_HEAD) .and. (lbc_typ == BC_FIX_FLUX)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, ubc_val, psi_s(ub), qlc, & + flux_btm = lbc_val) + ENDIF + + ! Case 1-5 + IF ((ubc_typ == BC_RAINFALL) .and. (lbc_typ == BC_FIX_FLUX)) THEN + + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, wdsrf, psi_s(ub), qlc, & + flux_btm = lbc_val) + + ENDIF + + ! Case 1-6 + IF ((ubc_typ == BC_FIX_FLUX) .and. (lbc_typ == BC_FIX_FLUX)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(lb), psi_s(ub), qlc, & + flux_top = ubc_val, flux_btm = lbc_val) + ENDIF + + ! Case 1-7 + IF ((ubc_typ == BC_FIX_HEAD) .and. (lbc_typ == BC_DRAINAGE)) THEN + IF (zwt > sp_zi(ub)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, ubc_val, psi_s(ub), qlc) + ELSE + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, ubc_val, psi_s(ub), qlc, & + flux_btm = 0.0) + ENDIF + ENDIF + + ! Case 1-8 + IF ((ubc_typ == BC_RAINFALL) .and. (lbc_typ == BC_DRAINAGE)) THEN + IF (zwt > sp_zi(ub)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, wdsrf, psi_s(ub), qlc) + ELSE + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, wdsrf, psi_s(ub), qlc, & + flux_btm = 0.0) + ENDIF + + ENDIF + + ! Case 1-9 + IF ((ubc_typ == BC_FIX_FLUX) .and. (lbc_typ == BC_DRAINAGE)) THEN + IF (zwt > sp_zi(ub)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(lb), psi_s(ub), qlc, & + flux_top = ubc_val) + ELSE + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(lb), psi_s(ub), qlc, & + flux_top = ubc_val, flux_btm = 0.0) + ENDIF + ENDIF + ENDIF + + ! Case 2 + IF (top_at_ground .and. btm_at_interface) THEN + + SELECTCASE (ubc_typ) + CASE (BC_FIX_HEAD) + + CALL flux_btm_transitive_interface ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + nlev_sat, dz_sat, psi_sat, hk_sat, ubc_val, & + qq_wf(i_end), qlc, tol_q, tol_z, tol_p) + + CASE (BC_FIX_FLUX) + + CALL flux_btm_transitive_interface ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(lb), & + qq_wf(i_end), qlc, tol_q, tol_z, tol_p, & + flux_top = ubc_val) + + CASE (BC_RAINFALL) + + CALL flux_btm_transitive_interface ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + nlev_sat, dz_sat, psi_sat, hk_sat, wdsrf, & + qq_wf(i_end), qlc, tol_q, tol_z, tol_p) + + ENDSELECT + + ENDIF + + ! Case 3 + IF (top_at_ground .and. btm_inside_level) THEN + + SELECTCASE (ubc_typ) + CASE (BC_FIX_HEAD) + + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, ubc_val, psi_s(i_end), qlc) + + CASE (BC_FIX_FLUX) + + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, psi_s(lb), psi_s(i_end), qlc, & + flux_top = ubc_val) + + CASE (BC_RAINFALL) + + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, wdsrf, psi_s(i_end), qlc) + + ENDSELECT + + ENDIF + + ! Case 4 + IF (top_at_interface .and. btm_at_bottom) THEN + + SELECTCASE (lbc_typ) + CASE (BC_FIX_HEAD) + + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, lbc_val, & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p) + + CASE (BC_FIX_FLUX) + + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(ub), & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p, & + flux_btm = lbc_val) + + CASE (BC_DRAINAGE) + + IF (zwt > sp_zi(ub)) THEN + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(ub), & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p) + ELSE + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(ub), & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p, & + flux_btm = 0.0) + ENDIF + + ENDSELECT + + ENDIF + + ! Case 5 + IF (top_at_interface .and. btm_at_interface) THEN + + CALL flux_both_transitive_interface ( & + i_stt, i_end, dz(i_stt:i_end), & + psi_s(i_stt:i_end), hksat(i_stt:i_end), nprm, prms(:,i_stt:i_end), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + qq_wt(i_stt), qq_wf(i_end), qlc, & + tol_q, tol_z, tol_p) + + ENDIF + + ! Case 6 + IF (top_at_interface .and. btm_inside_level) THEN + + CALL flux_top_transitive_interface ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), hk_us(i_stt), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(i_end), & + qq_wt(i_stt), qlc, tol_q, tol_z, tol_p) + + ENDIF + + ! Case 7 + IF (top_inside_level .and. btm_at_bottom) THEN + + SELECTCASE (lbc_typ) + CASE (BC_FIX_HEAD) + + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, psi_s(i_stt), lbc_val, qlc) + + CASE (BC_FIX_FLUX) + + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(i_stt), psi_s(ub), & + qlc, flux_btm = lbc_val) + + CASE (BC_DRAINAGE) + + IF (zwt > sp_zi(ub)) THEN + CALL flux_sat_zone_fixed_bc (nlev_sat, dz_sat, psi_sat, & + hk_sat, psi_s(i_stt), psi_s(ub), qlc) + ELSE + CALL flux_sat_zone_fixed_bc (nlev_sat, & + dz_sat, psi_sat, hk_sat, psi_s(i_stt), psi_s(ub), & + qlc, flux_btm = 0.0) + ENDIF + + ENDSELECT + + ENDIF + + ! Case 8 + IF (top_inside_level .and. btm_at_interface) THEN + + CALL flux_btm_transitive_interface ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_us(i_end), hk_us(i_end), & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_s(i_stt), & + qq_wf(i_end), qlc, tol_q, tol_z, tol_p) + + ENDIF + + ! Case 9 + IF (top_inside_level .and. btm_inside_level) THEN + + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_s(i_stt), psi_s(i_end), qlc) + + ENDIF + + IF (top_inside_level) THEN + IF (dz_us_top < tol_z) THEN + qq_wt(i_stt) = qq(i_stt-1) + ELSE + qq_wt(i_stt) = flux_inside_hm_soil ( & + psi_s(i_stt), hksat(i_stt), nprm, prms(:,i_stt), & + dz_us_top, psi_us(i_stt), psi_s(i_stt), hk_us(i_stt), hksat(i_stt)) + ENDIF + ENDIF + + IF (top_at_interface) THEN + IF (dz_us_top < tol_z) THEN + qq_wf(i_stt) = qq_wt(i_stt) + ENDIF + ENDIF + + IF (top_at_ground) THEN + + SELECTCASE (ubc_typ) + CASE (BC_FIX_HEAD) + qq(lb-1) = qlc(lb) + is_trans = .false. + CASE (BC_FIX_FLUX) + qq(lb-1) = ubc_val ! min(qlc(lb), ubc_val) + is_trans = (qlc(lb) > ubc_val) + CASE (BC_RAINFALL) + IF (wdsrf < tol_z) THEN + qq(lb-1) = min(ubc_val, qlc(lb)) + is_trans = (qlc(lb) > ubc_val) + ELSE + qq(lb-1) = qlc(lb) + is_trans = .false. + ENDIF + ENDSELECT + + IF (is_update_sublevel) THEN + IF (is_trans .and. is_sat(lb)) THEN + is_sat(lb) = .false. + has_wf(lb) = .false. + has_wt(lb) = .true. + + wt(lb) = 0.9*dz(lb) + vl(lb) = vl_s(lb) + wf(lb) = 0 + + qq_wt(lb) = qq(lb-1) + ENDIF + ENDIF + ENDIF + + DO iface = i_stt, i_end-1 + IF (top_at_interface .and. (iface == i_stt)) THEN + qupper = qq_wt(i_stt) + ELSE + qupper = qlc(iface) + ENDIF + + IF (btm_at_interface .and. (iface == i_end-1)) THEN + qlower = qq_wf(i_end) + ELSE + qlower = qlc(iface+1) + ENDIF + + IF (qlower - qupper >= tol_q) THEN + IF ((psi_s(iface) < psi_s(iface+1)) & + .or. & + ((psi_s(iface) == psi_s(iface+1)) .and. (is_sat(iface+1))) & + .or. & + (top_at_interface .and. (iface == i_stt))) THEN + + qq(iface) = qupper + + IF (is_update_sublevel .and. is_sat(iface+1)) THEN + is_sat(iface+1) = .false. + has_wf(iface+1) = .false. + has_wt(iface+1) = .true. + + wt(iface+1) = dz(iface+1) + vl(iface+1) = vl_s(iface+1) + wf(iface+1) = 0 + + qq_wf(iface+1) = qq(iface) + qq_wt(iface+1) = qq(iface) + + IF (top_at_interface .and. (iface == i_stt)) THEN + has_wt(iface) = .false. + ENDIF + ENDIF + + ELSEIF ((psi_s(iface) > psi_s(iface+1)) & + .or. & + ((psi_s(iface) == psi_s(iface+1)) .and. (.not. is_sat(iface+1))) & + .or. & + (btm_at_interface .and. (iface == i_end-1))) THEN + + qq(iface) = qlower + + IF (is_update_sublevel .and. is_sat(iface)) THEN + is_sat(iface) = .false. + has_wt(iface) = .false. + has_wf(iface) = .true. + + wf(iface) = dz(iface) + vl(iface) = vl_s(iface) + wt(iface) = 0 + + qq_wf(iface) = qq(iface) + qq_wt(iface) = qq(iface) + + IF (btm_at_interface .and. (iface == i_end-1)) THEN + has_wf(iface+1) = .false. + ENDIF + ENDIF + ENDIF + ELSEIF (qupper - qlower >= tol_q) THEN + IF (top_at_interface .and. (iface == i_stt)) THEN + qq(iface) = qlower + ENDIF + + IF (btm_at_interface .and. (iface == i_end-1)) THEN + qq(iface) = qupper + ENDIF + ELSE + qq(iface) = (qupper + qlower) * 0.5_r8 + ENDIF + ENDDO + + IF (btm_at_bottom) THEN + qq(ub) = qlc(ub) + ENDIF + + IF (btm_at_interface) THEN + IF (dz_us_btm < tol_z) THEN + qq_wt(i_end) = qq_wf(i_end) + ENDIF + ENDIF + + IF (btm_inside_level) THEN + IF (dz_us_btm < tol_z) THEN + qq_wf(i_end) = qq(i_end) + ELSE + qq_wf(i_end) = flux_inside_hm_soil ( & + psi_s(i_end), hksat(i_end), nprm, prms(:,i_end), & + dz_us_btm, psi_s(i_end), psi_us(i_end), hksat(i_end), hk_us(i_end)) + ENDIF + ENDIF + + deallocate (qlc ) + deallocate (dz_sat ) + deallocate (psi_sat) + deallocate (hk_sat ) + + END SUBROUTINE flux_sat_zone_all + + !-------------------------------------------------------------------------- + SUBROUTINE flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_btm, qlc, flux_top, flux_btm) + + IMPLICIT NONE + + integer, intent(in) :: nlev_sat + + real(r8), intent(in) :: dz_sat (nlev_sat) + real(r8), intent(in) :: psi_sat (nlev_sat) + real(r8), intent(in) :: hk_sat (nlev_sat) + + real(r8), intent(in) :: psi_top + real(r8), intent(in) :: psi_btm + + real(r8), intent(inout) :: qlc (nlev_sat) + + real(r8), intent(in), optional :: flux_top + real(r8), intent(in), optional :: flux_btm + + ! Local variables + real(r8) :: psi (0:nlev_sat) + integer :: ilev, ilev_u, ilev_l + integer :: spr(1:nlev_sat) + + IF (present(flux_top) .and. present(flux_btm)) THEN + IF (flux_top >= flux_btm) THEN + qlc(:) = flux_btm + RETURN + ENDIF + ENDIF + + psi(0) = psi_top + psi(nlev_sat) = psi_btm + + DO ilev = 1, nlev_sat + IF (ilev < nlev_sat) THEN + psi(ilev) = max(psi_sat(ilev),psi_sat(ilev+1)) + ENDIF + + qlc(ilev) = - hk_sat(ilev) & + * ((psi(ilev) - psi(ilev-1)) / dz_sat(ilev) - 1) + + spr(ilev) = ilev + ENDDO + + ilev_u = nlev_sat + ilev_l = ilev_u + DO WHILE (.true.) + + IF (ilev_l < nlev_sat) THEN + ilev = findloc_ud(spr == spr(ilev_l+1), BACK=.true.) + DO WHILE (qlc(ilev_u) >= qlc(ilev)) + + ilev_l = ilev + qlc(ilev_u:ilev_l) = - (psi(ilev_l) - psi(ilev_u-1) & + - sum(dz_sat(ilev_u:ilev_l))) & + / sum(dz_sat(ilev_u:ilev_l) / hk_sat(ilev_u:ilev_l)) + + spr(ilev_u:ilev_l) = ilev_u + + IF (ilev_l < nlev_sat) THEN + spr(ilev_l+1:nlev_sat) = spr(ilev_l+1:nlev_sat) - 1 + ilev = findloc_ud(spr == spr(ilev_l+1), BACK=.true.) + ELSE + EXIT + ENDIF + ENDDO + ENDIF + + IF ((ilev_l == nlev_sat) .and. (present(flux_btm))) THEN + IF (qlc(ilev_l) > flux_btm) THEN + qlc(ilev_u:ilev_l) = flux_btm + ENDIF + ENDIF + + IF (ilev_u > 1) THEN + ilev_u = ilev_u - 1 + ilev_l = ilev_u + ELSE + IF (present(flux_top)) THEN + DO ilev = 1, nlev_sat + IF (flux_top > qlc(ilev)) THEN + qlc(ilev) = flux_top + ELSE + EXIT + ENDIF + ENDDO + ENDIF + + EXIT + ENDIF + + ENDDO + + END SUBROUTINE flux_sat_zone_fixed_bc + + + !------------------------------------------------------------------------- + real(r8) FUNCTION flux_inside_hm_soil ( & + psi_s, hksat, nprm, prms, & + dz, psi_u, psi_l, hk_u, hk_l) + + IMPLICIT NONE + + real(r8), intent(in) :: psi_s, hksat + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + + real(r8), intent(in) :: dz + real(r8), intent(in) :: psi_u, psi_l + real(r8), intent(in) :: hk_u, hk_l + + ! Local variables + real(r8) :: grad_psi + real(r8) :: hk_m + real(r8) :: r0, rr + + grad_psi = (1.0_r8 - (psi_l - psi_u)/dz) + + SELECTCASE (effective_hk_type) + + CASE (type_upstream_mean) + + IF (grad_psi < 0) THEN + flux_inside_hm_soil = hk_l * grad_psi + ELSE + flux_inside_hm_soil = hk_u * grad_psi + ENDIF + + CASE (type_weighted_geometric_mean) + +#ifdef Campbell_SOIL_MODEL + ! bsw => prms(1) + r0 = 1.0_r8 / (3.0_r8 / prms(1) + 2.0_r8) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! n_gm => prms(2), L_gm => prms(3) + r0 = 1.0_r8 / (prms(3) * (prms(2) - 1.0_r8) + prms(2) * 2.0_r8) +#endif + + IF (grad_psi < 0) THEN + rr = r0 + hk_m = soil_hk_from_psi (psi_l-dz, psi_s, hksat, nprm, prms) + flux_inside_hm_soil = hk_u**rr * hk_m**(1.0_r8 - rr) * grad_psi + ELSEIF (grad_psi == 0) THEN + flux_inside_hm_soil = 0 + ELSEIF ((grad_psi > 0) .and. (grad_psi < 1)) THEN + rr = max(1.0_r8+r0*psi_l/dz, 1.0_r8-r0) + flux_inside_hm_soil = hk_u**rr * hk_l**(1.0_r8-rr) * grad_psi + ELSEIF (grad_psi == 1) THEN + flux_inside_hm_soil = hk_u + ELSEIF (grad_psi > 1) THEN + rr = r0 + flux_inside_hm_soil = hk_u + (psi_u - psi_l)/dz * hk_u**(1.0_r8-rr) * hk_l**rr + ENDIF + + ENDSELECT + + END FUNCTION flux_inside_hm_soil + + + !-------------------------------------------------------- + SUBROUTINE flux_at_unsaturated_interface (& + nprm, & + psi_s_u, hksat_u, prms_u, dz_u, psi_u, hk_u, & + psi_s_l, hksat_l, prms_l, dz_l, psi_l, hk_l, & + flux_u, flux_l, tol_q, tol_p) + + IMPLICIT NONE + + integer, intent(in) :: nprm + real(r8), intent(in) :: psi_s_u, hksat_u, prms_u(nprm) + real(r8), intent(in) :: psi_s_l, hksat_l, prms_l(nprm) + + real(r8), intent(in) :: dz_u, psi_u, hk_u + real(r8), intent(in) :: dz_l, psi_l, hk_l + + real(r8), intent(out) :: flux_u + real(r8), intent(out) :: flux_l + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_p + + ! Local variables + real(r8) :: psi_s_min + real(r8) :: psi_i + real(r8) :: psi_i_r, psi_i_l + real(r8) :: psi_i_k1 + real(r8) :: hk_i_u, hk_i_l + real(r8) :: fval, fval_k1 + integer :: iter + + + psi_i_r = max(psi_u + dz_u, psi_l - dz_l) + psi_i_l = min(psi_u + dz_u, psi_l - dz_l) + + psi_s_min = min(psi_s_u, psi_s_l) + + IF (psi_i_r > psi_s_min) THEN + hk_i_u = soil_hk_from_psi (psi_s_min, psi_s_u, hksat_u, nprm, prms_u) + hk_i_l = soil_hk_from_psi (psi_s_min, psi_s_l, hksat_l, nprm, prms_l) + + flux_u = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_u, psi_u, psi_s_min, hk_u, hk_i_u) + + flux_l = flux_inside_hm_soil (& + psi_s_l, hksat_l, nprm, prms_l, & + dz_l, psi_s_min, psi_l, hk_i_l, hk_l) + + IF (flux_u >= flux_l) THEN + RETURN + ELSE + psi_i_r = psi_s_min + ENDIF + ENDIF + + psi_i = (dz_l * psi_u + dz_u * psi_l) / (dz_u + dz_l) + IF ((psi_i < psi_i_l) .or. (psi_i > psi_i_r)) THEN + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + ENDIF + + iter = 0 + DO WHILE (iter < 50) + hk_i_u = soil_hk_from_psi (psi_i, psi_s_u, hksat_u, nprm, prms_u) + hk_i_l = soil_hk_from_psi (psi_i, psi_s_l, hksat_l, nprm, prms_l) + + flux_u = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_u, psi_u, psi_i, hk_u, hk_i_u) + + flux_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_l, psi_i, psi_l, hk_i_l, hk_l) + + fval = flux_l - flux_u + + IF ((abs(fval) < tol_q) .or. (psi_i_r - psi_i_l < tol_p)) THEN + EXIT + ELSE + IF (iter == 0) THEN + IF (fval < 0) THEN + psi_i_l = psi_i + ELSE + psi_i_r = psi_i + ENDIF + + psi_i_k1 = psi_i + fval_k1 = fval + + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, psi_i, psi_i_k1, psi_i_l, psi_i_r) + ENDIF + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : flux_at_unsaturated_interface: not converged.' + ENDIF +#endif + + END SUBROUTINE flux_at_unsaturated_interface + + !------------------------------------------------------------------- + SUBROUTINE flux_top_transitive_interface ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, hk_us, & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_btm, & + q_us_up, qlc, tol_q, tol_z, tol_p, flux_btm) + + IMPLICIT NONE + + real(r8), intent(in) :: psi_s_u, hksat_u + integer, intent(in) :: nprm + real(r8), intent(in) :: prms_u(nprm) + + real(r8), intent(in) :: dz_us + real(r8), intent(in) :: psi_us + real(r8), intent(in) :: hk_us + + integer, intent(in) :: nlev_sat + real(r8), intent(in) :: dz_sat (nlev_sat) + real(r8), intent(in) :: psi_sat (nlev_sat) + real(r8), intent(in) :: hk_sat (nlev_sat) + + real(r8), intent(in) :: psi_btm + + real(r8), intent(out) :: q_us_up + real(r8), intent(inout) :: qlc (nlev_sat) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + real(r8), intent(in), optional :: flux_btm + + ! Local variables + real(r8) :: psi_i + real(r8) :: psi_i_r, psi_i_l + real(r8) :: psi_i_k1 + real(r8) :: hk_i + real(r8) :: fval, fval_k1 + integer :: iter + + + IF (dz_us < tol_z) THEN + + psi_i = max(psi_s_u, psi_sat(1)) + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + q_us_up = qlc(1) + + RETURN + + ENDIF + + IF (psi_s_u <= psi_sat(1)) THEN + ! The case psi_s_u < psi_sat(1) does not exist in principle. + + psi_i = psi_s_u + hk_i = hksat_u + q_us_up = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, psi_i, hk_us, hk_i) + + psi_i = psi_sat(1) + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + RETURN + + ENDIF + + psi_i = psi_sat(1) + hk_i = soil_hk_from_psi (psi_i, psi_s_u, hksat_u, nprm, prms_u) + q_us_up = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, psi_i, hk_us, hk_i) + + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + IF (q_us_up <= qlc(1)) THEN + RETURN + ELSE + psi_i_l = psi_sat(1) + ENDIF + + psi_i = psi_s_u + hk_i = hksat_u + q_us_up = flux_inside_hm_soil (& + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, psi_i, hk_us, hk_i) + + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + IF (q_us_up >= qlc(1)) THEN + RETURN + ELSE + psi_i_r = psi_s_u + ENDIF + + psi_i_k1 = psi_i_r + fval_k1 = qlc(1) - q_us_up + + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + iter = 0 + DO WHILE (iter < 50) + hk_i = soil_hk_from_psi (psi_i, psi_s_u, hksat_u, nprm, prms_u) + q_us_up = flux_inside_hm_soil ( & + psi_s_u, hksat_u, nprm, prms_u, & + dz_us, psi_us, psi_i, hk_us, hk_i) + + IF (present(flux_btm)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc, flux_btm = flux_btm) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_i, psi_btm, qlc) + ENDIF + + fval = qlc(1) - q_us_up + + IF ((abs(fval) < tol_q) .or. (psi_i_r - psi_i_l < tol_p)) THEN + EXIT + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, psi_i, psi_i_k1, psi_i_l, psi_i_r) + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : flux_top_transitive_interface: not converged.' + ENDIF +#endif + + END SUBROUTINE flux_top_transitive_interface + + !------------------------------------------------------------------------ + SUBROUTINE flux_btm_transitive_interface ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_us, hk_us, & + nlev_sat, dz_sat, psi_sat, hk_sat, psi_top, & + q_us_l, qlc, tol_q, tol_z, tol_p, flux_top) + + IMPLICIT NONE + + real(r8), intent(in) :: psi_s_l, hksat_l + integer, intent(in) :: nprm + real(r8), intent(in) :: prms_l(nprm) + + real(r8), intent(in) :: dz_us + real(r8), intent(in) :: psi_us + real(r8), intent(in) :: hk_us + + integer, intent(in) :: nlev_sat + real(r8), intent(in) :: dz_sat (nlev_sat) + real(r8), intent(in) :: psi_sat (nlev_sat) + real(r8), intent(in) :: hk_sat (nlev_sat) + + real(r8), intent(in) :: psi_top + + real(r8), intent(out) :: q_us_l + real(r8), intent(inout) :: qlc (nlev_sat) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + real(r8), intent(in), optional :: flux_top + + ! Local variables + real(r8) :: psi_i + real(r8) :: psi_i_r, psi_i_l + real(r8) :: psi_i_k1 + real(r8) :: hk_i + real(r8) :: fval, fval_k1 + integer :: iter + + + IF (dz_us < tol_z) THEN + + psi_i = max(psi_sat(nlev_sat), psi_s_l) + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + q_us_l = qlc(nlev_sat) + + RETURN + + ENDIF + + IF (psi_sat(nlev_sat) >= psi_s_l) THEN + ! The case psi_sat(nlev_sat) > psi_s_l does not exist in principle. + + psi_i = psi_s_l + hk_i = hksat_l + q_us_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_i, psi_us, hk_i, hk_us) + + psi_i = psi_sat(nlev_sat) + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + RETURN + + ENDIF + + psi_i = psi_sat(nlev_sat) + + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + hk_i = soil_hk_from_psi (psi_i, psi_s_l, hksat_l, nprm, prms_l) + q_us_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_i, psi_us, hk_i, hk_us) + + IF (qlc(nlev_sat) <= q_us_l) THEN + RETURN + ELSE + psi_i_l = psi_sat(nlev_sat) + ENDIF + + psi_i = psi_s_l + + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + hk_i = soil_hk_from_psi (psi_i, psi_s_l, hksat_l, nprm, prms_l) + q_us_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_i, psi_us, hk_i, hk_us) + + IF (qlc(nlev_sat) >= q_us_l) THEN + RETURN + ELSE + psi_i_r = psi_s_l + ENDIF + + psi_i_k1 = psi_i_r + fval_k1 = q_us_l - qlc(nlev_sat) + + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + iter = 0 + DO WHILE (iter < 50) + + IF (present(flux_top)) THEN + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc, flux_top = flux_top) + ELSE + CALL flux_sat_zone_fixed_bc ( & + nlev_sat, dz_sat, psi_sat, hk_sat, & + psi_top, psi_i, qlc) + ENDIF + + hk_i = soil_hk_from_psi (psi_i, psi_s_l, hksat_l, nprm, prms_l) + q_us_l = flux_inside_hm_soil ( & + psi_s_l, hksat_l, nprm, prms_l, & + dz_us, psi_i, psi_us, hk_i, hk_us) + + fval = q_us_l - qlc(nlev_sat) + + IF ((abs(fval) < tol_q) .or. (psi_i_r - psi_i_l < tol_p)) THEN + EXIT + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, psi_i, psi_i_k1, psi_i_l, psi_i_r) + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : flux_btm_transitive_interface: not converged.' + ENDIF +#endif + + END SUBROUTINE flux_btm_transitive_interface + + + !----------------------------------------------------------------------- + SUBROUTINE flux_both_transitive_interface ( & + ilev_us_u, ilev_us_l, & + dz, psi_s, hksat, nprm, prms, & + dz_us_u, psi_us_u, hk_us_u, & + dz_us_l, psi_us_l, hk_us_l, & + q_us_u, q_us_l, qlc, & + tol_q, tol_z, tol_p) + + IMPLICIT NONE + + integer, intent(in) :: ilev_us_u, ilev_us_l + real(r8), intent(in) :: dz (ilev_us_u:ilev_us_l) + real(r8), intent(in) :: psi_s (ilev_us_u:ilev_us_l) + real(r8), intent(in) :: hksat (ilev_us_u:ilev_us_l) + + integer, intent(in) :: nprm + real(r8), intent(in) :: prms (nprm,ilev_us_u:ilev_us_l) + + real(r8), intent(in) :: dz_us_u, psi_us_u, hk_us_u + real(r8), intent(in) :: dz_us_l, psi_us_l, hk_us_l + + real(r8), intent(out) :: q_us_u, q_us_l + real(r8), intent(inout) :: qlc (ilev_us_u+1:ilev_us_l-1) + + real(r8), intent(in) :: tol_q + real(r8), intent(in) :: tol_z + real(r8), intent(in) :: tol_p + + ! Local variables + integer :: nlev_sat + real(r8) :: psi_i + real(r8) :: psi_i_r, psi_i_l + real(r8) :: psi_i_k1 + real(r8) :: hk_i + real(r8) :: fval, fval_k1 + integer :: iter + + nlev_sat = ilev_us_l - ilev_us_u - 1 + + IF ((psi_s(ilev_us_u) <= psi_s(ilev_us_u+1)) & + .or. (dz_us_u < tol_z)) THEN + + psi_i = max(psi_s(ilev_us_u), psi_s(ilev_us_u+1)) + CALL flux_btm_transitive_interface ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_us_l, hk_us_l, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), psi_s(ilev_us_u+1:ilev_us_l-1), & + hksat(ilev_us_u+1:ilev_us_l-1), psi_i, & + q_us_l, qlc, tol_q, tol_z, tol_p) + + IF (dz_us_u < tol_z) THEN + q_us_u = qlc(ilev_us_u+1) + ELSE + q_us_u = flux_inside_hm_soil ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, psi_s(ilev_us_u), hk_us_u, hksat(ilev_us_u)) + ENDIF + + RETURN + ENDIF + + IF ((psi_s(ilev_us_l) <= psi_s(ilev_us_l-1)) & + .or. (dz_us_l < tol_z)) THEN + + psi_i = max(psi_s(ilev_us_l-1), psi_s(ilev_us_l)) + CALL flux_top_transitive_interface ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, hk_us_u, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), & + psi_s(ilev_us_u+1:ilev_us_l-1), hksat(ilev_us_u+1:ilev_us_l-1), psi_i, & + q_us_u, qlc, tol_q, tol_z, tol_p) + + IF (dz_us_l < tol_z) THEN + q_us_l = qlc(ilev_us_l-1) + ELSE + q_us_l = flux_inside_hm_soil ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_s(ilev_us_l), psi_us_l, hksat(ilev_us_l), hk_us_l) + ENDIF + + RETURN + ENDIF + + psi_i_l = psi_s(ilev_us_l-1) + + CALL flux_top_transitive_interface ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, hk_us_u, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), & + psi_s(ilev_us_u+1:ilev_us_l-1), hksat(ilev_us_u+1:ilev_us_l-1), psi_i_l, & + q_us_u, qlc, tol_q/2.0_r8, tol_z, tol_p) + + hk_i = soil_hk_from_psi (psi_i_l, & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l)) + q_us_l = flux_inside_hm_soil ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_i_l, psi_us_l, hk_i, hk_us_l) + + IF (qlc(ilev_us_l-1) <= q_us_l) THEN + RETURN + ENDIF + + psi_i_r = psi_s(ilev_us_l) + + CALL flux_top_transitive_interface ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, hk_us_u, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), & + psi_s(ilev_us_u+1:ilev_us_l-1), hksat(ilev_us_u+1:ilev_us_l-1), psi_i_r, & + q_us_u, qlc, tol_q/2.0_r8, tol_z, tol_p) + + hk_i = soil_hk_from_psi (psi_i_r, & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l)) + q_us_l = flux_inside_hm_soil ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_i_r, psi_us_l, hk_i, hk_us_l) + + IF (qlc(ilev_us_l-1) >= q_us_l ) THEN + RETURN + ENDIF + + psi_i_k1 = psi_i_r + fval_k1 = q_us_l - qlc(ilev_us_l-1) + + psi_i = (psi_i_r + psi_i_l)/2.0_r8 + iter = 0 + DO WHILE (iter < 50) + + CALL flux_top_transitive_interface ( & + psi_s(ilev_us_u), hksat(ilev_us_u), nprm, prms(:,ilev_us_u), & + dz_us_u, psi_us_u, hk_us_u, & + nlev_sat, dz(ilev_us_u+1:ilev_us_l-1), & + psi_s(ilev_us_u+1:ilev_us_l-1), hksat(ilev_us_u+1:ilev_us_l-1), psi_i, & + q_us_u, qlc, tol_q/2.0_r8, tol_z, tol_p) + + hk_i = soil_hk_from_psi (psi_i, & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l)) + q_us_l = flux_inside_hm_soil ( & + psi_s(ilev_us_l), hksat(ilev_us_l), nprm, prms(:,ilev_us_l), & + dz_us_l, psi_i, psi_us_l, hk_i, hk_us_l) + + fval = q_us_l - qlc(ilev_us_l-1) + + IF ((abs(fval) < tol_q) .or. (psi_i_r - psi_i_l < tol_p)) THEN + EXIT + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, psi_i, psi_i_k1, psi_i_l, psi_i_r) + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : flux_both_transitive_interface: not converged.' + ENDIF +#endif + + END SUBROUTINE flux_both_transitive_interface + + !----------------------------------------------------------------- + SUBROUTINE get_zwt_from_wa ( & + vl_s, vl_r, psi_s, hksat, nprm, prms, tol_v, tol_z, & + wa, zmin, zwt) + + IMPLICIT NONE + + real(r8), intent(in) :: vl_s, vl_r, psi_s, hksat + integer, intent(in) :: nprm + real(r8), intent(in) :: prms(nprm) + real(r8), intent(in) :: tol_v, tol_z + real(r8), intent(in) :: wa, zmin + real(r8), intent(out) :: zwt + + real(r8) :: vl + real(r8) :: zwt_l, zwt_r, zwt_k1 + real(r8) :: fval, fval_k1 + real(r8) :: psi + integer :: iter + + IF (wa >= 0) THEN + zwt = zmin + vl = vl_s + RETURN + ENDIF + + zwt = zmin + (-wa)/vl_s * 2.0 + psi = psi_s - (zwt - zmin) * 0.5 + vl = soil_vliq_from_psi (psi, & + vl_s, vl_r, psi_s, nprm, prms) + DO WHILE (wa <= -(zwt-zmin)*(vl_s-vl)) + zwt = zmin + (zwt-zmin)*2 + 0.1 + psi = psi_s - (zwt - zmin) * 0.5 + vl = soil_vliq_from_psi (psi, & + vl_s, vl_r, psi_s, nprm, prms) + ENDDO + + zwt_r = zwt + zwt_l = zmin + + zwt_k1 = zwt_l + fval_k1 = wa + + zwt = (zwt_l + zwt_r) / 2.0 + iter = 0 + DO WHILE (iter < 50) + + psi = psi_s - (zwt - zmin) * 0.5 + vl = soil_vliq_from_psi (psi, & + vl_s, vl_r, psi_s, nprm, prms) + fval = wa + (zwt-zmin)* (vl_s-vl) + + IF ((abs(fval) < tol_v) .or. (zwt_r - zwt_l < tol_z)) THEN + EXIT + ELSE + CALL secant_method_iteration ( & + fval, fval_k1, zwt, zwt_k1, zwt_l, zwt_r) + ENDIF + + iter = iter + 1 + ENDDO + +#if (defined CoLMDEBUG) + IF (iter == 50) THEN + write(*,*) 'Warning : get_zwt_from_wa: not converged.' + ENDIF +#endif + + END SUBROUTINE get_zwt_from_wa + + + !--------------------------------------------------------------------- + SUBROUTINE solve_least_squares_problem (ndim, dr_dv, lact, rhs, dv) + ! By using Givens rotation. + + IMPLICIT NONE + + integer, intent(in) :: ndim + real(r8), intent(in) :: dr_dv (ndim,ndim) + logical, intent(in) :: lact (ndim) + real(r8), intent(in) :: rhs (ndim) + + real(r8), intent(out) :: dv (ndim) + + ! Local variables + real(r8) :: Amatrix (ndim,ndim) + real(r8) :: res (ndim) + integer :: i, j, k + real(r8) :: tau, c, s + real(r8) :: tmp + + Amatrix = dr_dv + res = rhs + dv = 0 + + DO i = 1, ndim + IF (lact(i)) THEN + + DO j = i+1, ndim + IF (Amatrix(j,i) /= 0) THEN + IF (abs(Amatrix(j,i)) > abs(Amatrix(i,i))) THEN + tau = Amatrix(i,i) / Amatrix(j,i) + s = 1 / sqrt(1 + tau**2) + c = s * tau + ELSE + tau = Amatrix(j,i) / Amatrix(i,i) + c = 1 / sqrt(1 + tau**2) + s = c * tau + ENDIF + + Amatrix(i,i) = c * Amatrix(i,i) + s * Amatrix(j,i) + Amatrix(j,i) = 0 + + DO k = i+1, ndim + IF (lact(k)) THEN + tmp = c * Amatrix(i,k) + s * Amatrix(j,k) + Amatrix(j,k) = - s * Amatrix(i,k) + c * Amatrix(j,k) + Amatrix(i,k) = tmp + ENDIF + ENDDO + + tmp = c * res(i) + s * res(j) + res(j) = - s * res(i) + c * res(j) + res(i) = tmp + ENDIF + ENDDO + + ENDIF + ENDDO + + dv = 0 + + DO i = ndim, 1, -1 + IF (lact(i)) THEN + + dv(i) = res(i) + + DO k = i+1, ndim + IF (lact(k)) THEN + dv(i) = dv(i) - Amatrix(i,k) * dv(k) + ENDIF + ENDDO + + dv(i) = dv(i) / Amatrix(i,i) + + ENDIF + ENDDO + + END SUBROUTINE solve_least_squares_problem + + + !--------------------------------------------------------------------------------- + SUBROUTINE secant_method_iteration ( & + fval, fval_k1, x_i, x_k1, x_l, x_r) + + IMPLICIT NONE + + real(r8), intent(in) :: fval + real(r8), intent(inout) :: fval_k1 + + real(r8), intent(inout) :: x_i, x_k1 + real(r8), intent(inout) :: x_l, x_r + + real(r8), parameter :: alp = 0.9_r8 + + ! Local variables + real(r8) :: x_k2, fval_k2 + + IF (fval > 0.0_r8) THEN + x_r = x_i + ELSE + x_l = x_i + ENDIF + + fval_k2 = fval_k1 + fval_k1 = fval + + x_k2 = x_k1 + x_k1 = x_i + + IF (fval_k1 == fval_k2) THEN + x_i = (x_l + x_r) * 0.5_r8 + ELSE + x_i = (fval_k1 * x_k2 - fval_k2 * x_k1) / (fval_k1 - fval_k2) + x_i = max(x_i, x_l * alp + x_r * (1.0_r8 - alp)) + x_i = min(x_i, x_l * (1.0_r8 - alp) + x_r * alp) + ENDIF + + END SUBROUTINE secant_method_iteration + + + !------------------------------------------------------------------------------- + integer FUNCTION find_unsat_lev_lower (is_sat, lb, ub, ilev) + + IMPLICIT NONE + + integer, intent(in) :: lb, ub + logical, intent(in) :: is_sat (lb:ub) + integer, intent(in) :: ilev + + find_unsat_lev_lower = ilev + DO WHILE (find_unsat_lev_lower <= ub) + IF (is_sat(find_unsat_lev_lower)) THEN + find_unsat_lev_lower = find_unsat_lev_lower + 1 + ELSE + EXIT + ENDIF + ENDDO + + END FUNCTION find_unsat_lev_lower + + ! ----- + SUBROUTINE print_VSF_iteration_stat_info () + + USE MOD_MPAS_MPI + IMPLICIT NONE + + integer(8), SAVE :: count_implicit_accum = 0 + integer(8), SAVE :: count_explicit_accum = 0 + integer(8), SAVE :: count_wet2dry_accum = 0 +#ifdef CoLMDEBUG + IF (.true.) THEN +#ifdef MPAS_MPI + CALL mpi_allreduce (MPI_IN_PLACE, count_implicit, 1, MPI_INTEGER8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('VSF implicit-iteration count reduction') + CALL mpi_allreduce (MPI_IN_PLACE, count_explicit, 1, MPI_INTEGER8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('VSF explicit-iteration count reduction') + CALL mpi_allreduce (MPI_IN_PLACE, count_wet2dry , 1, MPI_INTEGER8, MPI_SUM, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('VSF wet-to-dry count reduction') +#endif + IF (mpas_rank == mpas_root) THEN + count_implicit_accum = count_implicit_accum + count_implicit + count_explicit_accum = count_explicit_accum + count_explicit + count_wet2dry_accum = count_wet2dry_accum + count_wet2dry + ENDIF + ENDIF + + IF (mpas_is_root) THEN + write(*,"(/,A,I13,A,I13,A,I13,A)") 'VSF scheme this step: ', & + count_implicit, ' (implicit)', count_explicit, ' (explicit)', count_wet2dry, ' (wet2dry)' + write(*,"(A,I13,A,I13,A,I13,A)") 'VSF scheme all steps: ', & + count_implicit_accum, ' (implicit)', count_explicit_accum, ' (explicit)', & + count_wet2dry_accum, ' (wet2dry)' + ENDIF + + count_implicit = 0 + count_explicit = 0 + count_wet2dry = 0 +#endif + END SUBROUTINE print_VSF_iteration_stat_info + +END MODULE MOD_Hydro_SoilWater diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC.F90 new file mode 100644 index 0000000000..cbc90062c7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC.F90 @@ -0,0 +1,588 @@ +MODULE MOD_Hydro_VIC + USE MOD_Hydro_VIC_Variables + IMPLICIT NONE + + PUBLIC :: compute_vic_runoff + + PRIVATE :: compute_runoff_and_asat + PRIVATE :: calc_Q12 + PRIVATE :: compute_zwt + PRIVATE :: wrap_compute_zwt + + CONTAINS + + ! ****************************************************************************** + SUBROUTINE Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & + wice_soisno, wliq_soisno, fevpg, rootflux, ppt, & + b_infilt, Dsmax, Ds, Ws, c, & + rsur,rsubst,wliq_soisno_tmp) + + USE MOD_Namelist + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + + !-----------------------Arguments--------------------------------------- + type(soil_con_struct) :: soil_con + type(cell_data_struct) :: cell + + real(r8), intent(in) :: porsl(1:nl_soil), theta_r(1:nl_soil), hksati(1:nl_soil), bsw(1:nl_soil) + real(r8), intent(in) :: wice_soisno(1:nl_soil) + real(r8), intent(in) :: wliq_soisno(1:nl_soil) + real(r8), intent(in) :: fevpg + real(r8), intent(in) :: rootflux(1:nl_soil) + real(r8), intent(in) :: ppt ! /**< amount of liquid water coming to the surface */ + real(r8), intent(in) :: deltim ! int(DEF_simulation_time%timestep) + + real(r8), intent(in) :: b_infilt, Dsmax, Ds, Ws, c + + real(r8), intent(inout) :: rsur, rsubst + real(r8), intent(out) :: wliq_soisno_tmp(1:nl_soil) + + !-----------------------Local Variables--------------------------------- + integer :: ilay + real(r8) :: vic_tmp(Nlayer), vic_tmp_(Nlayer) + !-----------------------Arguments--------------------------------------- + + CALL vic_para(porsl, theta_r, hksati, bsw, wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg, rootflux, & + b_infilt, Dsmax, Ds, Ws, c, & + soil_con, cell) + + CALL compute_vic_runoff(soil_con, ppt*deltim, soil_con%frost_fract, cell) + + DO ilay = 1, Nlayer + vic_tmp(ilay) = cell%layer(ilay)%moist + ENDDO + wliq_soisno_tmp = 0. + CALL VIC2CoLM(wliq_soisno_tmp, vic_tmp) + + DO ilay = 1, Nlayer + vic_tmp_(ilay) = sum(cell%layer(ilay)%ice) + ENDDO + ! CALL VIC2CoLM(wice_soisno(1:nl_soil), vic_tmp_) + + IF (ppt > 0.) rsur = cell%runoff/deltim + rsubst = cell%baseflow/deltim + + END SUBROUTINE Runoff_VIC + + ! /****************************************************************************** + ! * @brief Calculate infiltration and runoff from the surface, gravity driven + ! * drainage between all soil layers, and generates baseflow from the + ! * bottom layer. + ! ******************************************************************************/ + SUBROUTINE compute_vic_runoff(soil_con, ppt, frost_fract, cell) + USE MOD_Hydro_VIC_Variables + USE MOD_Namelist + IMPLICIT NONE + + !-----------------------Arguments--------------------------------------- + type(soil_con_struct), intent(in) :: soil_con + real(r8), intent(in) :: ppt ! /**< amount of liquid water coming to the surface */ + real(r8), intent(in) :: frost_fract(:) ! /**< spatially distributed frost coverage fractions */ + type(cell_data_struct),intent(inout) :: cell + + !-----------------------Local Variables--------------------------------- + integer :: lindex, time_step + integer :: last_index, tmplayer, fidx + real(r8) :: A + real(r8) :: frac + real(r8) :: tmp_runoff + real(r8) :: inflow + real(r8) :: resid_moist(MAX_LAYERS) ! residual moisture (mm) + real(r8) :: org_moist(MAX_LAYERS) ! total soil moisture (liquid and frozen) at beginning of this FUNCTION (mm) + real(r8) :: avail_liq(MAX_LAYERS, MAX_FROST_AREAS) ! liquid soil moisture available for evap/drainage (mm) + real(r8) :: liq(MAX_LAYERS) + real(r8) :: ice(MAX_LAYERS) + real(r8) :: moist(MAX_LAYERS) + real(r8) :: max_moist(MAX_LAYERS) + real(r8) :: Ksat(MAX_LAYERS) + real(r8) :: Q12(MAX_LAYERS - 1) + real(r8) :: Dsmax + real(r8) :: tmp_inflow + real(r8) :: tmp_moist + real(r8) :: tmp_moist_for_runoff(MAX_LAYERS) + real(r8) :: tmp_liq + real(r8) :: dt_inflow + real(r8) :: dt_runoff + real(r8) :: runoff(MAX_FROST_AREAS) + real(r8) :: tmp_dt_runoff(MAX_FROST_AREAS) + real(r8) :: baseflow(MAX_FROST_AREAS) + real(r8) :: dt_baseflow + real(r8) :: rel_moist + real(r8) :: evap(MAX_LAYERS, MAX_FROST_AREAS) + real(r8) :: sum_liq + real(r8) :: evap_fraction + real(r8) :: evap_sum + type(layer_data_struct), dimension(MAX_LAYERS) :: layer + + real(r8) :: dltime !/**< timestep in seconds */ + integer :: runoff_steps_per_day !/**< Number of runoff timesteps per day */ + integer :: model_steps_per_day !/**< Number of model timesteps per day */ + integer :: runoff_steps_per_dt + + !-----------------------End Variable List------------------------------- + + dltime = DEF_simulation_time%timestep + runoff_steps_per_day = 86400/dltime + model_steps_per_day = 86400/dltime + + ! /** Set Temporary Variables **/ + DO lindex = 1, Nlayer + resid_moist(lindex) = soil_con%resid_moist(lindex) + max_moist(lindex) = soil_con%max_moist(lindex) + Ksat(lindex) = soil_con%Ksat(lindex) / runoff_steps_per_day + ENDDO + + ! /** Allocate and Set Values for Soil Sublayers **/ + layer = cell%layer + cell%runoff = 0 + cell%baseflow = 0 + cell%asat = 0 + + runoff_steps_per_dt = runoff_steps_per_day / model_steps_per_day + + ! initialize baseflow + DO fidx = 1, Nfrost + baseflow(fidx) = 0.0 + ENDDO + + DO lindex = 1, Nlayer + evap(lindex, 1) = layer(lindex)%evap / real(runoff_steps_per_dt) + org_moist(lindex) = layer(lindex)%moist + layer(lindex)%moist = 0.0 + + ! if there is positive evaporation + IF (evap(lindex, 1) > 0.0) THEN + sum_liq = 0.0 + ! compute available soil moisture for each frost sub area + DO fidx = 1, Nfrost + avail_liq(lindex, fidx) = org_moist(lindex) - layer(lindex)%ice(fidx) - resid_moist(lindex) + !avail_liq(lindex, fidx) = org_moist(lindex) - resid_moist(lindex) + IF (avail_liq(lindex, fidx) < 0.0) THEN + avail_liq(lindex, fidx) = 0.0 + ENDIF + sum_liq = sum_liq + avail_liq(lindex, fidx) * frost_fract(fidx) + ENDDO + + ! compute fraction of available soil moisture that is evaporated + IF (sum_liq > 0.0) THEN + evap_fraction = evap(lindex, 1) / sum_liq + ELSE + evap_fraction = 1.0 + ENDIF + + ! distribute evaporation between frost sub areas by percentage + evap_sum = evap(lindex, 1) + DO fidx = Nfrost, 1, -1 + evap(lindex, fidx) = avail_liq(lindex, fidx) * evap_fraction + avail_liq(lindex, fidx) = avail_liq(lindex, fidx) - evap(lindex, fidx) + evap_sum = evap_sum - evap(lindex, fidx) * frost_fract(fidx) + ENDDO + ELSE + ! if no evaporation + DO fidx = Nfrost, 2, -1 + evap(lindex, fidx) = evap(lindex, 1) + ENDDO + ENDIF + ENDDO + + + DO fidx = 1, Nfrost + ! ppt = amount of liquid water coming to the surface + inflow = ppt + + ! /************************************************** + ! Initialize Variables + ! **************************************************/ + DO lindex = 1, Nlayer + ! Set Layer Liquid Moisture Content + liq(lindex) = org_moist(lindex) - layer(lindex)%ice(fidx) + + ! Set Layer Frozen Moisture Content + ice(lindex) = layer(lindex)%ice(fidx) + ENDDO + + ! /****************************************************** + ! Runoff Based on Soil Moisture Level of Upper Layers + ! ******************************************************/ + DO lindex = 1, Nlayer + tmp_moist_for_runoff(lindex) = liq(lindex) + ice(lindex) + ENDDO + + CALL compute_runoff_and_asat(soil_con, tmp_moist_for_runoff, inflow, A, runoff(fidx)) + + ! Save dt_runoff based on initial runoff estimate + tmp_dt_runoff(fidx) = runoff(fidx) / real(runoff_steps_per_dt, kind=r8) + + ! /************************************************** + ! Compute Flow Between Soil Layers () + ! **************************************************/ + dt_inflow = inflow / real(runoff_steps_per_dt, kind=r8) + + Dsmax = soil_con%Dsmax / runoff_steps_per_day + + DO time_step = 1, runoff_steps_per_dt + inflow = dt_inflow + + ! /************************************* + ! Compute Drainage between Sublayers + ! *************************************/ + DO lindex = 1, Nlayer - 1 + ! Brooks & Corey relation for hydraulic conductivity + tmp_liq = liq(lindex) - evap(lindex, fidx) ! Assume evap is a 2D array now, adjusted indexing + + IF (tmp_liq < resid_moist(lindex)) THEN + tmp_liq = resid_moist(lindex) + ENDIF + + IF (tmp_liq > resid_moist(lindex)) THEN + CALL calc_Q12(Ksat(lindex), tmp_liq, resid_moist(lindex), max_moist(lindex), soil_con%expt(lindex),Q12(lindex)) + ELSE + Q12(lindex) = 0.0 + ENDIF + ENDDO + + ! /************************************************** + ! Solve for Current Soil Layer Moisture, and + ! Check Versus Maximum and Minimum Moisture Contents. + ! **************************************************/ + last_index = 0 + DO lindex = 1, Nlayer - 1 + IF (lindex == 1) THEN + dt_runoff = tmp_dt_runoff(fidx) + ELSE + dt_runoff = 0.0 + ENDIF + + ! transport moisture for all sublayers + tmp_inflow = 0.0 + + ! Update soil layer moisture content + liq(lindex) = liq(lindex) + (inflow - dt_runoff) - (Q12(lindex) + evap(lindex, fidx)) + + ! Verify that soil layer moisture is less than maximum + IF ((liq(lindex) + ice(lindex)) > max_moist(lindex)) THEN + tmp_inflow = (liq(lindex) + ice(lindex)) - max_moist(lindex) + liq(lindex) = max_moist(lindex) - ice(lindex) + + IF (lindex == 1) THEN + Q12(lindex) = Q12(lindex) + tmp_inflow + tmp_inflow = 0.0 + ELSE + tmplayer = lindex + DO WHILE (tmp_inflow > 0) + tmplayer = tmplayer - 1 + IF (tmplayer < 1) THEN + ! If top layer saturated, add to runoff + runoff(fidx) = runoff(fidx) + tmp_inflow + tmp_inflow = 0.0 + ELSE + ! else add excess soil moisture to next higher layer + liq(tmplayer) = liq(tmplayer) + tmp_inflow + IF ((liq(tmplayer) + ice(tmplayer)) > max_moist(tmplayer)) THEN + tmp_inflow = (liq(tmplayer) + ice(tmplayer)) - max_moist(tmplayer) + liq(tmplayer) = max_moist(tmplayer) - ice(tmplayer) + ELSE + tmp_inflow = 0.0 + ENDIF + ENDIF + ENDDO + ENDIF ! /** END trapped excess moisture **/ + ENDIF ! /** END check if excess moisture in top layer **/ + + ! verify that current layer moisture is greater than minimum + IF (liq(lindex) < 0.0) THEN + ! liquid cannot fall below 0 + Q12(lindex) = Q12(lindex) + liq(lindex) + liq(lindex) = 0.0 + ENDIF + + IF ((liq(lindex) + ice(lindex)) < resid_moist(lindex)) THEN + ! moisture cannot fall below minimum + Q12(lindex) = Q12(lindex) + (liq(lindex) + ice(lindex)) - resid_moist(lindex) + liq(lindex) = resid_moist(lindex) - ice(lindex) + ENDIF + + inflow = Q12(lindex) + tmp_inflow + Q12(lindex) = Q12(lindex) + tmp_inflow + + last_index = last_index + 1 + ENDDO ! /* END loop through soil layers */ + + ! /************************************************** + ! Compute Baseflow + ! **************************************************/ + ! ARNO model for the bottom soil layer (based on bottom + ! soil layer moisture from previous time step) + + lindex = Nlayer + + ! Compute relative moisture + rel_moist = (liq(lindex) - resid_moist(lindex)) / & + (max_moist(lindex) - resid_moist(lindex)) + + ! Compute baseflow as FUNCTION of relative moisture + frac = Dsmax * soil_con%Ds / soil_con%Ws + dt_baseflow = frac * rel_moist + IF (rel_moist > soil_con%Ws) THEN + frac = (rel_moist - soil_con%Ws) / (1 - soil_con%Ws) + dt_baseflow = dt_baseflow + Dsmax * (1 - soil_con%Ds / soil_con%Ws) * & + frac ** soil_con%c + ENDIF + + ! Make sure baseflow isn't negative + IF (dt_baseflow < 0) THEN + dt_baseflow = 0.0 + ENDIF + + ! Extract baseflow from the bottom soil layer + liq(lindex) = liq(lindex) + Q12(lindex - 1) - (evap(lindex, fidx) + dt_baseflow) + + ! Check Lower Sub-Layer Moistures + tmp_moist = 0.0 + + ! /* If soil moisture has gone below minimum, take water out + ! * of baseflow and add back to soil to make up the difference + ! * Note: this may lead to negative baseflow, in which case we will + ! * reduce evap to make up for it */ + IF ((liq(lindex) + ice(lindex)) < resid_moist(lindex)) THEN + dt_baseflow = dt_baseflow + & + (liq(lindex) + ice(lindex)) - resid_moist(lindex) + liq(lindex) = resid_moist(lindex) - ice(lindex) + ENDIF + + IF ((liq(lindex) + ice(lindex)) > max_moist(lindex)) THEN + ! soil moisture above maximum + tmp_moist = (liq(lindex) + ice(lindex)) - max_moist(lindex) + liq(lindex) = max_moist(lindex) - ice(lindex) + tmplayer = lindex + DO WHILE (tmp_moist > 0) + tmplayer = tmplayer - 1 + IF (tmplayer < 1) THEN + ! If top layer saturated, add to runoff + runoff(fidx) = runoff(fidx) + tmp_moist + tmp_moist = 0.0 + ELSE + ! else if sublayer exists, add excess soil moisture + liq(tmplayer) = liq(tmplayer) + tmp_moist + IF ((liq(tmplayer) + ice(tmplayer)) > max_moist(tmplayer)) THEN + tmp_moist = (liq(tmplayer) + ice(tmplayer)) - max_moist(tmplayer) + liq(tmplayer) = max_moist(tmplayer) - ice(tmplayer) + ELSE + tmp_moist = 0.0 + ENDIF + ENDIF + ENDDO + ENDIF + + baseflow(fidx) = baseflow(fidx) + dt_baseflow + ENDDO ! /* END of sub-dt time step loop */ + + ! If negative baseflow, reduce evap accordingly + IF (baseflow(fidx) < 0.0) THEN + ! layer(lindex)%evap = layer(lindex)%evap + baseflow(fidx) !!!! need check + baseflow(fidx) = 0.0 + endif + + ! Recompute Asat based on final moisture level of upper layers + do lindex = 1, Nlayer + tmp_moist_for_runoff(lindex) = (liq(lindex) + ice(lindex)) + enddo + + CALL compute_runoff_and_asat(soil_con, tmp_moist_for_runoff, real(0.0, kind=r8), A, tmp_runoff) + + ! Store tile-wide values + do lindex = 1, Nlayer + layer(lindex)%moist = layer(lindex)%moist + & + ((liq(lindex) + ice(lindex)) * frost_fract(fidx)) + enddo + cell%asat = cell%asat + A * frost_fract(fidx) + cell%runoff = cell%runoff + runoff(fidx) * frost_fract(fidx) + cell%baseflow = cell%baseflow + baseflow(fidx) * frost_fract(fidx) + + ! ! /** Compute water table depth **/ + ! CALL wrap_compute_zwt(soil_con, cell) + + enddo + + END SUBROUTINE compute_vic_runoff + + + ! ****************************************************************************** + ! * @brief Calculate the saturated area and runoff + ! ****************************************************************************** + SUBROUTINE compute_runoff_and_asat(soil_con, moist, inflow, A, runoff) + USE MOD_Hydro_VIC_Variables, only: soil_con_struct, Nlayer + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + type(soil_con_struct), intent(in) :: soil_con + real(r8), intent(in) :: moist(Nlayer) + real(r8), intent(in) :: inflow + real(r8), intent(inout) :: A + real(r8), intent(inout) :: runoff + !-----------------------Local Variables--------------------------------- + real(r8) :: top_moist !! total moisture (liquid and frozen) in topmost soil layers (mm) + real(r8) :: top_max_moist !! maximum storable moisture (liquid and frozen) in topmost soil layers (mm) + integer :: lindex + real(r8) :: ex, max_infil, i_0, basis + !-----------------------End Variable List------------------------------- + + top_moist = 0.0 + top_max_moist = 0.0 + do lindex = 1, Nlayer - 1 + top_moist = top_moist + moist(lindex) + top_max_moist = top_max_moist + soil_con%max_moist(lindex) + enddo + if (top_moist > top_max_moist) then + top_moist = top_max_moist + endif + + ! A as in Wood et al. in JGR 97, D3, 1992 equation (1) + ex = soil_con%b_infilt / (1.0 + soil_con%b_infilt) + A = 1.0 - (1.0 - top_moist / top_max_moist)**ex + + max_infil = (1.0 + soil_con%b_infilt) * top_max_moist + i_0 = max_infil * (1.0 - (1.0 - A)**(1.0 / soil_con%b_infilt)) + + ! equation (3a) Wood et al. + if (inflow == 0.0) then + runoff = 0.0 + else if (max_infil == 0.0) then + runoff = inflow + else if ((i_0 + inflow) > max_infil) then + runoff = inflow - top_max_moist + top_moist + ! equation (3b) Wood et al. (wrong in paper) + else + basis = 1.0 - (i_0 + inflow) / max_infil + runoff = (inflow - top_max_moist + top_moist + & + top_max_moist * basis**(1.0 * (1.0 + soil_con%b_infilt))) + endif + if (runoff < 0.0) then + runoff = 0.0 + endif + END SUBROUTINE compute_runoff_and_asat + + + ! ****************************************************************************** + ! * @brief Calculate drainage between two layers + ! ****************************************************************************** + SUBROUTINE calc_Q12(Ksat, init_moist, resid_moist, max_moist, expt, Q12) + IMPLICIT NONE + real(r8), intent(in) :: Ksat, init_moist, resid_moist, max_moist, expt + real(r8), intent(out) :: Q12 + + Q12 = init_moist - ((init_moist - resid_moist)**(1.0d0 - expt) - Ksat / & + (max_moist - resid_moist)**expt * (1.0d0 - expt))**(1.0d0 / (1.0d0 - expt)) - resid_moist + + END SUBROUTINE calc_Q12 + + + ! /****************************************************************************** + ! * @brief Compute spatial average water table position (zwt). Water table + ! * position is measured in cm and is negative below the soil surface. + ! *****************************************************************************/ + SUBROUTINE compute_zwt(soil_con,lindex, moist, zwt) + USE MOD_Hydro_VIC_Variables + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + type(soil_con_struct), intent(in) :: soil_con + integer, intent(in) :: lindex + real(r8), intent(in) :: moist + real(r8), intent(out) :: zwt + !-----------------------Local Variables--------------------------------- + integer :: i + real(r8) :: MISSING = -99999. !/**< missing value */ + !-----------------------End Variable List------------------------------- + + zwt = MISSING + + ! /** Compute zwt using soil moisture v zwt curve **/ + i = MAX_ZWTVMOIST - 1 + do while (i >= 1 .and. moist > soil_con%zwtvmoist_moist(lindex, i)) + i = i - 1 + enddo + + if (i == MAX_ZWTVMOIST - 1) then + if (moist < soil_con%zwtvmoist_moist(lindex, i)) then + zwt = 999.0 ! 999 indicates water table not present in this layer + else if (moist == soil_con%zwtvmoist_moist(lindex, i)) then + zwt = soil_con%zwtvmoist_zwt(lindex, i) ! Just barely enough water for a water table + endif + else + zwt = soil_con%zwtvmoist_zwt(lindex, i+1) + & + (soil_con%zwtvmoist_zwt(lindex, i) - soil_con%zwtvmoist_zwt(lindex, i+1)) * & + (moist - soil_con%zwtvmoist_moist(lindex, i+1)) / & + (soil_con%zwtvmoist_moist(lindex, i) - soil_con%zwtvmoist_moist(lindex, i+1)) + endif + END SUBROUTINE compute_zwt + + + ! /****************************************************************************** + ! * @brief Function to compute spatial average water table position (zwt) for + ! * individual layers as well as various total-column versions of zwt. + ! * Water table position is measured in cm and is negative below the + ! * soil surface. + ! *****************************************************************************/ + SUBROUTINE wrap_compute_zwt(soil_con, cell) + USE MOD_Hydro_VIC_Variables + IMPLICIT NONE + + !-----------------------Arguments--------------------------------------- + type(soil_con_struct), intent(in) :: soil_con + type(cell_data_struct), intent(inout) :: cell + !-----------------------Local Variables--------------------------------- + integer :: lindex + integer :: idx + real(r8) :: total_depth + real(r8) :: tmp_depth + real(r8) :: tmp_moist + integer, parameter :: CM_PER_M = 100 !/**< centimeters per meter */ + real(r8), parameter :: DBL_EPSILON = 2.2204460492503131E-16 + !-----------------------End Variable List------------------------------- + + ! /** Compute total soil column depth **/ + total_depth = 0.0 + do lindex = 1, Nlayer + total_depth = total_depth + soil_con%depth(lindex) + enddo + + ! /** Compute each layer's zwt using soil moisture v zwt curve **/ + do lindex = 1, Nlayer + CALL compute_zwt(soil_con, lindex, cell%layer(lindex)%moist, cell%layer(lindex)%zwt) + enddo + if (cell%layer(Nlayer)%zwt == 999) then + cell%layer(Nlayer)%zwt = -total_depth * CM_PER_M + endif + + ! /** Compute total soil column's zwt; this will be the zwt of the lowest layer that isn't completely saturated **/ + idx = Nlayer + tmp_depth = total_depth + do while (idx >= 1 .and. soil_con%max_moist(idx) - cell%layer(idx)%moist <= DBL_EPSILON) + tmp_depth = tmp_depth - soil_con%depth(idx) + idx = idx - 1 + enddo + if (idx < 1) then + cell%zwt = 0.0 + else if (idx < Nlayer) then + if (cell%layer(idx)%zwt /= 999) then + cell%zwt = cell%layer(idx)%zwt + else + cell%zwt = -tmp_depth * CM_PER_M + endif + else + cell%zwt = cell%layer(idx)%zwt + endif + + ! /** Compute total soil column's zwt_lumped; this will be the zwt of all N layers lumped together. **/ + tmp_moist = 0.0 + do lindex = 1, Nlayer + tmp_moist = tmp_moist + cell%layer(lindex)%moist + enddo + CALL compute_zwt(soil_con, Nlayer + 1, tmp_moist, cell%zwt_lumped) + + if (cell%zwt_lumped == 999) then + cell%zwt_lumped = -total_depth * CM_PER_M ! // in cm; + endif + END SUBROUTINE wrap_compute_zwt +END MODULE MOD_Hydro_VIC diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC_Variables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC_Variables.F90 new file mode 100644 index 0000000000..4ece3c3d1e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_VIC_Variables.F90 @@ -0,0 +1,298 @@ +MODULE MOD_Hydro_VIC_Variables + USE MOD_Precision + IMPLICIT NONE + + ! /***** Define the number of layers used in VIC *****/ + integer, parameter :: Nlayer = 3 !/**< Number of soil moisture layers in model */ + integer :: Nfrost = 1 !/**< Number of frost subareas in model */ + + ! /***** Define maximum array sizes for model source code *****/ + integer, parameter :: MAX_LAYERS = 3 !/**< maximum number of soil moisture layers */ + integer, parameter :: MAX_FROST_AREAS = 3 !/**< maximum number of frost sub-areas */ + integer, parameter :: MAX_ZWTVMOIST = 11 !/**< maximum number of points in water table vs moisture curve for each soil layer; should include points at lower and upper boundaries of the layer */ + + ! /***** colm layers to vic layers *****/ + integer, parameter, dimension(:) :: colm2vic_lay(Nlayer) = [3, 6, 10] !/**< colm layers to vic layers */ + + ! /****************************************************************************** + ! * @brief This structure stores all soil variables for each layer in the + ! * soil column. + ! *****************************************************************************/ + type layer_data_struct + real(r8) :: ice(MAX_FROST_AREAS) ! /**< ice content of the frozen sublayer (mm) */ + real(r8) :: moist ! /**< moisture content of the unfrozen sublayer (mm) */ + real(r8) :: evap ! /**< evapotranspiration from soil layer (mm) */ + real(r8) :: zwt ! /**< water table position relative to soil surface within the layer (cm) */ + END type layer_data_struct + + ! /****************************************************************************** + ! * @brief This structure stores soil variables for the complete soil column + ! * for each grid cell. + ! *****************************************************************************/ + type cell_data_struct + real(r8) :: asat ! /**< saturated area fraction */ + real(r8) :: baseflow ! /**< baseflow from current cell (mm/TS) */ + real(r8) :: runoff ! /**< runoff from current cell (mm/TS) */ + type(layer_data_struct) :: layer(MAX_LAYERS) ! /**< structure containing soil variables for each layer (see above) */ + !!! for zwt calcaulation, not used + real(r8) :: zwt ! /**< average water table position [cm] - using lowest unsaturated layer */ + real(r8) :: zwt_lumped ! /**< average water table position [cm] - lumping all layers' moisture together */ + END type cell_data_struct + + ! /****************************************************************************** + ! * @brief This structure stores the soil parameters for a grid cell. + ! *****************************************************************************/ + type soil_con_struct + real(r8) :: frost_fract(MAX_FROST_AREAS) ! /**< spatially distributed frost coverage fractions */ + real(r8) :: max_moist(MAX_LAYERS) ! /**< Maximum moisture content (mm) per layer */ + real(r8) :: resid_moist(MAX_LAYERS) ! /**< Residual moisture content of soil layer (mm) */ + real(r8) :: Ksat(MAX_LAYERS) ! /**< Saturated hydraulic conductivity (mm/day) */ + real(r8) :: expt(MAX_LAYERS) ! /**< Layer-specific exponent n (=3+2/lambda) in Campbell's equation for hydraulic conductivity, HBH 5.6 */ + !!!! to be calibrated + real(r8) :: b_infilt ! /**< Infiltration parameter */ + real(r8) :: Ds ! /**< Fraction of maximum subsurface flow rate */ + real(r8) :: Ws ! /**< Fraction of maximum soil moisture */ + real(r8) :: Dsmax ! /**< Maximum subsurface flow rate (mm/day) */ + real(r8) :: c ! /**< Exponent in ARNO baseflow scheme */ + real(r8) :: depth(MAX_LAYERS) ! /**< Thickness of each soil moisture layer (m) */ + !!! for zwt calculation, not used + ! Bubbling pressure, HBH 5.15 (cm) + real(r8) :: bubble(MAX_LAYERS) + ! Zwt values in the zwt-v-moist curve for each layer. + real(r8) :: zwtvmoist_zwt(MAX_LAYERS + 2, MAX_ZWTVMOIST) + ! Moist values in the zwt-v-moist curve for each layer. + real(r8) :: zwtvmoist_moist(MAX_LAYERS + 2, MAX_ZWTVMOIST) + END type soil_con_struct + +CONTAINS + + + SUBROUTINE vic_para(porsl, theta_r, hksati, bsw, wice_soisno, wliq_soisno, fevpg, rootflux, & + b_infilt, Dsmax, Ds, Ws, c, & + soil_con, cell) + + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + + type(soil_con_struct) , intent(inout) :: soil_con + type(cell_data_struct), intent(inout) :: cell + + real(r8), intent(in) :: porsl(1:nl_soil), theta_r(1:nl_soil), hksati(1:nl_soil), bsw(1:nl_soil) + real(r8), intent(in) :: wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil) + real(r8), intent(in) :: fevpg + real(r8), intent(in) :: rootflux(1:nl_soil) + + real(r8), intent(in) :: b_infilt, Dsmax, Ds, Ws, c + real(r8) :: soil_tmp(Nlayer), ice_tmp(Nlayer) + integer :: lb, lp, k, ilay + + real(r8) :: dltime !int(DEF_simulation_time%timestep) + !-----------------------END Variable List------------------------------- + + dltime = DEF_simulation_time%timestep + + CALL CoLM2VIC(dz_soi, soil_tmp) + soil_con%depth = soil_tmp + + CALL CoLM2VIC_weight(porsl, soil_tmp) + ! convert - to mm + soil_con%max_moist = soil_tmp*soil_con%depth*1000 + + CALL CoLM2VIC_weight(theta_r, soil_tmp) + ! convert - to mm + soil_con%resid_moist = soil_tmp*soil_con%depth*1000 + + CALL CoLM2VIC_weight(hksati, soil_tmp) + ! convert mm/s to mm/day + soil_con%Ksat = soil_tmp*86400 + + CALL CoLM2VIC_weight(bsw, soil_tmp) + ! 2*lambda+3 + soil_con%expt = soil_tmp*2+3 + + soil_con%b_infilt = b_infilt + soil_con%Dsmax = Dsmax + soil_con%Ds = Ds + soil_con%Ws = Ws + soil_con%c = c + + soil_con%frost_fract = 1 + IF (sum(wice_soisno)>0) THEN + Nfrost = 3 + DO k = 1, Nfrost + IF (Nfrost == 1) THEN + soil_con%frost_fract(k) = 1.0 + ELSEIF (Nfrost == 2) THEN + soil_con%frost_fract(k) = 0.5 + ELSE + soil_con%frost_fract(k) = 1.0 / real(Nfrost - 1, kind=8) + IF (k == 1 .or. k == Nfrost) THEN + soil_con%frost_fract(k) = soil_con%frost_fract(k) / 2.0 + ENDIF + ENDIF + ENDDO + ENDIF + + CALL CoLM2VIC(wliq_soisno, soil_tmp) + DO ilay = 1, Nlayer + ! mm + cell%layer(ilay)%moist = soil_tmp(ilay) + ENDDO + + DO ilay=1, Nlayer + cell%layer(ilay)%ice(:) = 0 + ENDDO + + IF (sum(wice_soisno)>0) THEN + DO ilay = 1, Nlayer + lp = colm2vic_lay(ilay) + IF (ilay==1) THEN + lb = 1 + ELSE + lb = colm2vic_lay(ilay-1)+1 + ENDIF + CALL VIC_IceLay(lb, lp, wice_soisno(lb:lp), ice_tmp) + cell%layer(ilay)%ice(:) = ice_tmp + ENDDO + ! ELSE + ! DO ilay = 1, Nlayer + ! cell%layer(ilay)%ice(:) = 0 + ! ENDDO + ENDIF + + CALL CoLM2VIC(rootflux, soil_tmp) + ! mm/s*dltime to convert to mm + DO ilay = 1, Nlayer + cell%layer(ilay)%evap = soil_tmp(ilay)*dltime + ENDDO + cell%layer(1)%evap = cell%layer(1)%evap + fevpg*dltime + + END SUBROUTINE vic_para + + + SUBROUTINE VIC_IceLay(lb, lp, colm_ice, vic_ice) + + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + integer , intent(in ) :: lb + integer , intent(in ) :: lp + real(kind=8), intent(in ) :: colm_ice(lb:lp) + real(kind=8), intent(out) :: vic_ice(3) + !-----------------------Local variables--------------------------------- + integer :: idx, colm_lay + real(kind=8) :: totalSum + real(kind=8) :: multiplier + real(kind=8) :: ice_tmp(lp-lb+1) + integer :: vic_lay=3 + !-----------------------END Variable List------------------------------- + + colm_lay = lp - lb + 1 + ice_tmp = colm_ice + totalSum = sum(ice_tmp) + + IF (colm_lay == 1) THEN + vic_ice = totalSum / vic_lay + ELSEIF (colm_lay == 2) THEN + vic_ice(1) = ice_tmp(1) * 2.0 / vic_lay + vic_ice(3) = ice_tmp(2) * 2.0 / vic_lay + ELSEIF (colm_lay == 3) THEN + vic_ice = ice_tmp + ELSE + DO idx = 1, min(int((colm_lay-1)/vic_lay), vic_lay) + multiplier = merge(1.0, 0.0, colm_lay > idx*vic_lay) + vic_ice(1) = vic_ice(1) + ice_tmp(idx) * multiplier + vic_ice(3) = vic_ice(3) + ice_tmp(colm_lay-idx+1) * multiplier + ENDDO + multiplier = merge((colm_lay-idx*vic_lay)/vic_lay, 0, colm_lay <= (idx+1)*vic_lay) + vic_ice(1) = vic_ice(1) + ice_tmp(idx+1) * multiplier + vic_ice(3) = vic_ice(3) + ice_tmp(colm_lay-idx) * multiplier + ENDIF + vic_ice(2) = totalSum - vic_ice(1) - vic_ice(3) + + END SUBROUTINE VIC_Icelay + + + SUBROUTINE CoLM2VIC(colm_water, vic_water) + + USE MOD_Vars_Global + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + real, intent(in ) :: colm_water(1:nl_soil) + real, intent(out) :: vic_water(Nlayer) + !-----------------------Local variables--------------------------------- + integer :: i_colm, i_vic + !-----------------------END Variable List------------------------------- + + DO i_vic = 1, Nlayer + vic_water(i_vic) = 0 + IF (i_vic == 1) THEN + DO i_colm = 1, colm2vic_lay(i_vic) + vic_water(i_vic) = vic_water(i_vic) + colm_water(i_colm) + ENDDO + ELSE + DO i_colm = colm2vic_lay(i_vic-1)+1, colm2vic_lay(i_vic) + vic_water(i_vic) = vic_water(i_vic) + colm_water(i_colm) + ENDDO + ENDIF + ENDDO + + END SUBROUTINE CoLM2VIC + + + SUBROUTINE CoLM2VIC_weight(colm_water, vic_water) + + USE MOD_Vars_Global + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + real, intent(in ) :: colm_water(1:nl_soil) + real, intent(out) :: vic_water(Nlayer) + !-----------------------Local variables--------------------------------- + integer :: i_colm, i_vic + !-----------------------END Variable List------------------------------- + + DO i_vic = 1, Nlayer + vic_water(i_vic) = 0 + IF (i_vic == 1) THEN + DO i_colm = 1, colm2vic_lay(i_vic) + vic_water(i_vic) = vic_water(i_vic) + colm_water(i_colm)*dz_soi(i_colm) + ENDDO + vic_water(i_vic) = vic_water(i_vic)/sum(dz_soi(1:colm2vic_lay(i_vic))) + ELSE + DO i_colm = colm2vic_lay(i_vic-1)+1, colm2vic_lay(i_vic) + vic_water(i_vic) = vic_water(i_vic) + colm_water(i_colm)*dz_soi(i_colm) + ENDDO + vic_water(i_vic) = vic_water(i_vic)/sum(dz_soi(colm2vic_lay(i_vic-1)+1:colm2vic_lay(i_vic))) + ENDIF + ENDDO + + END SUBROUTINE CoLM2VIC_weight + + + SUBROUTINE VIC2CoLM(colm_water, vic_water) + + USE MOD_Vars_Global + IMPLICIT NONE + !-----------------------Arguments--------------------------------------- + real, intent(in ) :: vic_water(Nlayer) + real, intent(inout) :: colm_water(1:nl_soil) + !-----------------------Local variables--------------------------------- + integer :: i_colm, i_vic + !-----------------------END Variable List------------------------------- + + DO i_vic = 1, Nlayer + IF (i_vic == 1) THEN + DO i_colm = 1, colm2vic_lay(i_vic) + colm_water(i_colm) = vic_water(i_vic)*(dz_soi(i_colm)/sum(dz_soi(1:colm2vic_lay(i_vic)))) + ENDDO + ELSE + DO i_colm = colm2vic_lay(i_vic-1)+1, colm2vic_lay(i_vic) + colm_water(i_colm) = vic_water(i_vic)*(dz_soi(i_colm)/sum(dz_soi(colm2vic_lay(i_vic-1)+1:colm2vic_lay(i_vic)))) + ENDDO + ENDIF + ENDDO + + END SUBROUTINE VIC2CoLM + + +END MODULE MOD_Hydro_VIC_Variables diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_3DCanopyRadiation.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_3DCanopyRadiation.F90 new file mode 100644 index 0000000000..8fbfe86df5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_3DCanopyRadiation.F90 @@ -0,0 +1,1455 @@ +#include + +MODULE MOD_3DCanopyRadiation + +!----------------------------------------------------------------------- +! +! --- A 3D Canopy Radiation Transfer Model --- +! for Plant Community (PC) Simulation +! +! Sun +! /// +! /// +! _____ tree _____ --- Layer3 +! /||||||| ||||||| +! /||||||||| ||||||||| +! / \|||||// / \|||||// +! / | / / | / --- Layer2 +! / | / / | / /xx\ +! / shadow |/ grass / |/ shrub/\xx/ +! __/.........|_________\\//\/......|________/..|/__ --- Layer1 +! ///////////////////////////////////////////////////////////////////// +! +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: +#ifdef LULC_IGBP_PC + PUBLIC :: ThreeDCanopy_wrap +#endif + PUBLIC :: ThreeDCanopy + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + +#ifdef LULC_IGBP_PC + + SUBROUTINE ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! This is a wrap SUBROUTINE to CALL 3D canopy radiative model below +! CALL ThreeDCanopy() +! +! Created by Hua Yuan, 08/2019 +! +! !REFERENCES: +! Yuan, H., R. E. Dickinson, Y. Dai, M. J. Shaikh, L. Zhou, W. Shangguan, +! and D. Ji, 2014: A 3D canopy radiative transfer model for global climate +! modeling: Description, validation, and application. Journal of Climate, +! 27, 1168-1192, https://doi.org/10.1175/JCLI-D-13-00155.1. +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW, DEF_PC_CROP_SPLIT + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_Global + USE MOD_Const_PFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch + real(r8), intent(in) :: czen + real(r8), intent(in) :: albg(2,2) + real(r8), intent(out) :: albv(2,2) + real(r8), intent(out) :: tran(2,3) + real(r8), intent(out) :: ssun(2,2) + real(r8), intent(out) :: ssha(2,2) + +!-------------------------- Local Variables ---------------------------- + integer :: i, p, ps, pe, pn; + + ! sunlit absorption fraction calculation mode + ! .true. USE 3D model, otherwise USE 1D case + ! NOTE: The 3D version will be activated in the new release, + ! accompanied by a new set of canopy structure data. + logical, parameter :: fsun3D = .false. + + ! define allocatable variables + integer, allocatable :: canlay(:) + real(r8), allocatable :: albd(:,:), albi(:,:) + real(r8), allocatable :: fabd(:,:), fabi(:,:), fadd(:,:) + real(r8), allocatable :: ftdd(:,:), ftid(:,:), ftii(:,:) + real(r8), allocatable :: rho (:,:), tau (:,:) + real(r8), allocatable :: csiz(:), chgt(:), chil(:), lsai(:) + real(r8), allocatable :: fsun_id(:), fsun_ii(:), psun(:) + real(r8), allocatable :: phi1(:), phi2(:), gdir(:), fcover(:) + + ! vegetation snow optical properties, 1:vis, 2:nir + real(r8) :: rho_sno(2), tau_sno(2) + data rho_sno(1), rho_sno(2) /0.5, 0.2/ + data tau_sno(1), tau_sno(2) /0.3, 0.2/ +!----------------------------------------------------------------------- + + ! get patch PFT index + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + ! Calculate the end index of natrue PFT + DO i = ps, pe + pn = i + p = pftclass(i) + IF (DEF_PC_CROP_SPLIT .and. p.ge.15) THEN + pn = pn - 1 + EXIT + ENDIF + ENDDO + + ! If pn less than start index, there is no nature PFT + ! Otherwise, set the new end index + IF (pn.ge.ps) THEN + pe = pn + ELSE + RETURN + ENDIF + + ! allocate memory for defined variables + allocate (albd (ps:pe, 2) ) + allocate (albi (ps:pe, 2) ) + allocate (fabd (ps:pe, 2) ) + allocate (fabi (ps:pe, 2) ) + allocate (fadd (ps:pe, 2) ) + allocate (ftdd (ps:pe, 2) ) + allocate (ftid (ps:pe, 2) ) + allocate (ftii (ps:pe, 2) ) + allocate (rho (ps:pe, 2) ) + allocate (tau (ps:pe, 2) ) + allocate (csiz (ps:pe) ) + allocate (chgt (ps:pe) ) + allocate (chil (ps:pe) ) + allocate (lsai (ps:pe) ) + allocate (canlay (ps:pe) ) + allocate (fsun_id(ps:pe) ) + allocate (fsun_ii(ps:pe) ) + allocate (psun (ps:pe) ) + allocate (phi1 (ps:pe) ) + allocate (phi2 (ps:pe) ) + allocate (gdir (ps:pe) ) + allocate (fcover (ps:pe) ) + + ! initialization + albd=1.; albi=1.; fabd=0.; fabi=0.; + ftdd=1.; ftid=0.; ftii=1.; fadd=0.; + csiz(:) = (htop_p(ps:pe) - hbot_p(ps:pe)) / 2 + chgt(:) = (htop_p(ps:pe) + hbot_p(ps:pe)) / 2 + lsai(:) = lai_p(ps:pe) + sai_p(ps:pe) + fcover(ps:pe) = pftfrac(ps:pe) / sum(pftfrac(ps:pe)) + + ! calculate weighted plant optical properties + ! loop for each PFT + rho = 0. + tau = 0. + DO i = ps, pe + + p = pftclass(i) + canlay(i) = canlay_p(p) + chil(i) = chil_p(p) + + IF (lsai(i) > 0.) THEN + rho(i,:) = rho_p(:,1,p)*lai_p(i)/lsai(i) & + + rho_p(:,2,p)*sai_p(i)/lsai(i) + tau(i,:) = tau_p(:,1,p)*lai_p(i)/lsai(i) & + + tau_p(:,2,p)*sai_p(i)/lsai(i) + ENDIF + + ! account for snow on vegetation + IF ( DEF_VEG_SNOW ) THEN + ! modify rho, tau, USE: fwet_snow_p + rho(i,:) = (1-fwet_snow_p(i))*rho(i,:) + fwet_snow_p(i)*rho_sno(:) + tau(i,:) = (1-fwet_snow_p(i))*tau(i,:) + fwet_snow_p(i)*tau_sno(:) + ENDIF + + ENDDO + + ! CALL 3D canopy radiation transfer model + CALL ThreeDCanopy(ps, pe, canlay, fcover(ps:pe), csiz, chgt, chil, czen, & + lsai, rho, tau, albg(:,1), albg(:,2), albd, albi, & + fabd, fabi, ftdd, ftid, ftii, fadd, psun, fsun_id, fsun_ii, & + thermk_p(ps:pe), fshade_p(ps:pe) ) + + ! calculate extkb_p, extkd_p + ! applied for 1D case + extkd_p(ps:pe) = 0.719 !used for scaling-up coefficients from leaf to canopy + + ! 11/07/2018: calculate gee FUNCTION consider LAD + DO i = ps, pe + p = pftclass(i) + phi1(i) = 0.5 - 0.633 * chil_p(p) - 0.33 * chil_p(p) * chil_p(p) + phi2(i) = 0.877 * ( 1. - 2. * phi1(i) ) + ENDDO + + ! 11/07/2018: calculate gee FUNCTION consider LAD + gdir = phi1 + phi2*czen + extkb_p(ps:pe) = gdir/czen + + fsun_id(:) = 0. + fsun_ii(:) = 0. + + ! 1D sunlit leaves absorption fraction in diffuse format + ! Table 3, Yuan et al., (2014). + DO p = ps, pe + IF (lsai(p) > 0. .and. .not.fsun3D) THEN + fsun_id(p) = (1._r8 - exp(-2._r8*extkb_p(p)*lsai(p))) & + / (1._r8 - exp(-extkb_p(p)*lsai(p))) & + / 2.0_r8 * psun(p) + + fsun_ii(p) = (1._r8 - exp(-extkb_p(p)*lsai(p)-lsai(p))) & + / (1._r8 - exp(-lsai(p))) & + / (1._r8 + extkb_p(p)) * psun(p) + ENDIF + ENDDO + + ! Calculate albv, ssun, ssha and tran for PFTs + ! NOTE: CoLM (1/2,): vis/nir; (,1/2): dir/dif + albv(1,1) = albd(ps,1); albv(1,2) = albi(ps,1) + albv(2,1) = albd(ps,2); albv(2,2) = albi(ps,2) + + ! ssun(band, dir/dif, pft), fabd/fadd(pft, band) + ssun_p(1,1,ps:pe) = (fabd(:,1)-fadd(:,1)) * fsun_id + fadd(:,1) + ssun_p(2,1,ps:pe) = (fabd(:,2)-fadd(:,2)) * fsun_id + fadd(:,2) + ssha_p(1,1,ps:pe) = (fabd(:,1)-fadd(:,1)) * (1.-fsun_id) + ssha_p(2,1,ps:pe) = (fabd(:,2)-fadd(:,2)) * (1.-fsun_id) + ssun_p(1,2,ps:pe) = fabi(:,1) * fsun_ii + ssun_p(2,2,ps:pe) = fabi(:,2) * fsun_ii + ssha_p(1,2,ps:pe) = fabi(:,1) * (1.-fsun_ii) + ssha_p(2,2,ps:pe) = fabi(:,2) * (1.-fsun_ii) + + ssun(1,1) = sum( ssun_p(1,1,ps:pe) * pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe) * pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe) * pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe) * pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe) * pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe) * pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe) * pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe) * pftfrac(ps:pe) ) + + tran(1,1) = ftid(ps,1) + tran(2,1) = ftid(ps,2) + tran(1,3) = ftdd(ps,1) + tran(2,3) = ftdd(ps,2) + tran(1,2) = ftii(ps,1) + tran(2,2) = ftii(ps,2) + + ! deallocate memory for defined variables + deallocate (albd ) + deallocate (albi ) + deallocate (fabd ) + deallocate (fabi ) + deallocate (fadd ) + deallocate (ftdd ) + deallocate (ftid ) + deallocate (ftii ) + deallocate (rho ) + deallocate (tau ) + deallocate (csiz ) + deallocate (chgt ) + deallocate (chil ) + deallocate (lsai ) + deallocate (canlay ) + deallocate (fsun_id ) + deallocate (fsun_ii ) + deallocate (psun ) + deallocate (phi1 ) + deallocate (phi2 ) + deallocate (gdir ) + deallocate (fcover ) + + END SUBROUTINE ThreeDCanopy_wrap +#endif + + + SUBROUTINE ThreeDCanopy(ps, pe, canlay, fcover, csiz, chgt, chil, coszen, & + lsai, rho, tau, albgrd, albgri, albd, albi, & + fabd, fabi, ftdd, ftid, ftii, fadd, psun, & + fsun_id, fsun_ii, thermk, fshade) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! ThreeDCanopy based on Dickinson (2008) using three canopy layer +! to calculate fluxes absorbed by vegetation, reflected by vegetation, +! and transmitted through vegetation for unit incoming direct or +! diffuse flux given an underlying surface with known albedo. +! +! Created by Hua Yuan, 08/2019 +! +! !HISTORY: +! Before 2013: Robert E. Dickinson proposed the initial idea. Dickinson and +! Muhammad J. Shake contributed to the code writing. +! +! !REFERENCES: +! Yuan, H., R. E. Dickinson, Y. Dai, M. J. Shaikh, L. Zhou, W. Shangguan, +! and D. Ji, 2014: A 3D canopy radiative transfer model for global climate +! modeling: Description, validation, and application. Journal of Climate, +! 27, 1168-1192, https://doi.org/10.1175/JCLI-D-13-00155.1. +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + + integer, parameter :: numrad = 2 + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: ps, pe !pft index bounds + integer , intent(in) :: canlay(ps:pe) !canopy level for current pft + real(r8), intent(in) :: fcover(ps:pe) !fractional cover of pft within a patch + real(r8), intent(in) :: csiz (ps:pe) !crown size of vegetation + real(r8), intent(in) :: chgt (ps:pe) !central height of crown + ! NOTE: The 'cdcw' parameter will be activated in the new release, accompanied by + ! a new set of canopy structure data. Currently we set cdcw = 1, i.e., sphere + real(r8) :: cdcw (ps:pe) !crown depth to crown width + real(r8), intent(in) :: chil (ps:pe) !leaf angle distribution parameter + real(r8), intent(in) :: lsai (ps:pe) !LAI+SAI + real(r8), intent(in) :: rho (ps:pe,numrad) !leaf/stem refl weighted by fraction LAI and SAI + real(r8), intent(in) :: tau (ps:pe,numrad) !leaf/stem tran weighted by fraction LAI and SAI + + real(r8), intent(in) :: coszen !cosine solar zenith angle for next time step + real(r8), intent(in) :: albgrd(numrad) !ground albedo (direct) (column-level) + real(r8), intent(in) :: albgri(numrad) !ground albedo (diffuse)(column-level) + + real(r8), intent(out) :: albd(ps:pe,numrad) !surface albedo (direct) + real(r8), intent(out) :: albi(ps:pe,numrad) !surface albedo (diffuse) + real(r8), intent(out) :: fabd(ps:pe,numrad) !flux absorbed by veg per unit direct flux + real(r8), intent(out) :: fabi(ps:pe,numrad) !flux absorbed by veg per unit diffuse flux + real(r8), intent(out) :: ftdd(ps:pe,numrad) !down direct flux below veg per unit dir flx + real(r8), intent(out) :: ftid(ps:pe,numrad) !down diffuse flux below veg per unit dir flx + real(r8), intent(out) :: ftii(ps:pe,numrad) !down diffuse flux below veg per unit dif flx + real(r8), intent(out) :: fadd(ps:pe,numrad) !absorbed flux in direct mode per unit direct flux + real(r8), intent(out) :: psun (ps:pe) !percent sunlit vegetation cover + real(r8), intent(out) :: fsun_id (ps:pe) !frac of dif rad abs. by sunlit leaves incident dir + real(r8), intent(out) :: fsun_ii (ps:pe) !frac of dif rad abs. by sunlit leaves incident dif + real(r8), intent(out) :: thermk (ps:pe) !direct transmittance of diffuse radiation + real(r8), intent(out) :: fshade (ps:pe) !shadow in diffuse case of vegetation + +!-------------------------- Local Variables ---------------------------- + real(r8), parameter :: mpe = 1.0e-06_r8 !prevents overflow for division by zero + integer , parameter :: nlay=3 !number of canopy layers + real(r8), parameter :: D0=0.0_r8 !double accuracy real number + real(r8), parameter :: D1=1.0_r8 !double accuracy real number + real(r8), parameter :: D2=2.0_r8 !double accuracy real number + real(r8), parameter :: D3=3.0_r8 !double accuracy real number + real(r8), parameter :: D4=4.0_r8 !double accuracy real number + real(r8), parameter :: D6=6.0_r8 !double accuracy real number + real(r8), parameter :: D7=7.0_r8 !double accuracy real number + real(r8), parameter :: D8=8.0_r8 !double accuracy real number + real(r8), parameter :: D9=9.0_r8 !double accuracy real number + real(r8), parameter :: D10=10.0_r8 !double accuracy real number + real(r8), parameter :: D16=16.0_r8 !double accuracy real number + real(r8), parameter :: DH=0.5_r8 !quad accuracy real number + real(r16),parameter :: DDH=0.5_r16 !quad accuracy real number + real(r16),parameter :: DD0=0.0_r16 !quad accuracy real number + real(r16),parameter :: DD1=1.0_r16 !quad accuracy real number + real(r8) ,parameter :: pi=3.14159265358979323846_r8 !pi + + integer :: ib !band index 1:vis 2:nir + integer :: ip,ic,ig,kband !array indices for pft,column,grid + integer :: kfr !variable for layer radiation coming from + integer :: klay !variable for layer absorbing radiation + integer :: kto !variable for layer radiation is transmitted to + integer :: lev !do loop variable + integer :: nn !do loop variable + integer :: nsoilveg !number of pfts in gridcell with veg and cosz > 0 + integer :: nstep !time step index + integer :: clev !canopy level for current pft + + real(r8) :: albd_col(numrad) !surface reflection (direct) for column + real(r8) :: albi_col(numrad) !surface reflection (diffuse) for column + real(r8) :: hbot_lay(nlay) !average canopy bottom in layer + real(r8) :: chgt_lay(nlay) !average canopy height in layer + real(r8) :: csiz_lay(nlay) !average canopy size in layer + real(r8) :: cdcw_lay(nlay) !crown depth to crown width for layers + real(r8) :: omg_lay(nlay,numrad) !average omega for all three layer + real(r8) :: rho_lay(nlay,numrad) !average rho for all three layer + real(r8) :: tau_lay(nlay,numrad) !average tau for all three layer + real(r8) :: lsai_lay(nlay) !average lsai for each layer + real(r8) :: cosz_lay(nlay) !0.001 <= coszen <= 1.000 + real(r8) :: cosd_lay(nlay) !0.001 <= coszen <= 1.000 + real(r8) :: delta !variable for increment layer in loop + real(r8) :: dif !diffuse radiation transmitted + real(r8) :: dir !direct radiation transmitted + real(r8) :: fabd_col(numrad) !flux absorbed by veg per unit diffuse flux + real(r8) :: fabd_lay(nlay,numrad) !layer absorption for direct beam + real(r8) :: fabi_col(numrad) !flux absorbed by veg per unit diffuse flux + real(r8) :: fabi_lay(nlay,numrad) !layer absorption for diffuse beam + real(r8) :: fabs_lay(0:4,numrad) !layer absorption for all five layers + real(r8) :: fabs_leq(0:4,numrad) !layer absorption for all five layers + real(r8) :: A(6,6) !three-layer radiation transfer equation + !(EQ. 19, Yuan et al., 2014) + real(r8) :: B(6,2) !three-layer radiation transfer equation + !(EQ. 19, Yuan et al., 2014) + real(r8) :: X(6,2) !three-layer radiation transfer equation + !(EQ. 19, Yuan et al., 2014) + real(r8) :: fabsm !pft absorption for multiple reflections + real(r8) :: faid_lay(nlay) !layer diffused absorption for direct beam + real(r8) :: faid_p !pft absorption direct beam + real(r8) :: faii_lay(nlay) !layer diffused absorption for diffuse beam + real(r8) :: faii_p !pft absorption diffuse beam + real(r8) :: fc0(nlay) !canopy fraction for layers + real(r8) :: frid_lay(nlay) !layer reflection for direct beam + real(r8) :: frid_p !pft reflection direct beam + real(r8) :: frii_lay(nlay) !layer reflection for indirect beam + real(r8) :: ftdd_lay(nlay) !unscattered layer transmission for direct beam + real(r8) :: ftdi_lay(nlay) !unscattered layer transmission for indirect beam + real(r8) :: ftdd_lay_orig(nlay) !unscattered layer transmission for direct beam + !without lad/crown_shape calibration + real(r8) :: ftdi_lay_orig(nlay) !unscattered layer transmission for indirect beam + !without lad/crown_shape calibration + real(r8) :: psun_lay(nlay) !percent sunlit vegetation cover for layers + real(r8) :: fsun_id_lay(nlay) !frac of dif rad abs. by sunlit leaf incident dir + real(r8) :: fsun_ii_lay(nlay) !frac of dif rad abs. by sunlit leaf incident dif + real(r8) :: fsun_dd_lay(nlay) !frac of dif rad abs. by sunlit leaf incident downward dir + real(r8) :: fsun_dw_lay(nlay) !frac of dif rad abs. by sunlit leaf incident downward dif + real(r8) :: fsun_up_lay(nlay) !frac of dif rad abs. by sunlit leaf incident upward dif + real(r8) :: ftid_lay(nlay) !diffused layer transmission for direct beam + real(r8) :: ftii_lay(nlay) !diffused layer transmission for diffuse beam + real(r8) :: ftran !pft transmittance + real(r8) :: gee=0.5_r8 !Ross G factor geometric blocking + real(r8) :: gdir(ps:pe) !G factor considering LAD for incident direct radiation + real(r8) :: gdif(ps:pe) !G factor considering LAD for incident diffuse radiation + real(r8) :: gdir_lay(nlay) !G factor considering LAD for incident direct radiation + real(r8) :: gdif_lay(nlay) !G factor considering LAD for incident diffuse radiation + real(r8) :: fcad(ps:pe) !calibration factor for LAD for direct radiation + real(r8) :: fcai(ps:pe) !calibration factor for LAD for diffuse radiation + real(r8) :: fcad_lay(nlay) !calibration factor for LAD for direct radiation + real(r8) :: fcai_lay(nlay) !calibration factor for LAD for diffuse radiation + real(r8) :: pad !probability function for absorption after two scat + real(r8) :: pai !probability of absorption for diffuse incident beam + real(r8) :: pfc !contribution of current pft in layer + real(r8) :: probm !prob photon reflect diffusely from ground reach canopy + real(r8) :: ref(0:nlay+1,0:nlay+1) !radiation reflected between five layers + real(r8) :: fadd_lay(nlay,numrad) !layer absorbed flux in direct mode per unit direct flux + real(r8) :: shad_oa(nlay,nlay) !shadow overlaps (direct beam) + real(r8) :: shadow_d(nlay) !layer shadow for direct beam + real(r8) :: shadow_i(nlay) !layer shadow for diffuse beam + real(r8) :: sum_fabd(3) !sum of absorption for all pfts in grid (direct) + real(r8) :: sum_fabi(3) !sum of absorption for all pfts in grid (diffuse) + real(r8) :: sum_fadd(nlay) !sum of absorbed flux in direct mode per unit direct flux + real(r8) :: taud_lay(nlay) !direct transmission for a layer + real(r8) :: taui_lay(nlay) !diffuse transmission for a layer + real(r8) :: trd(0:nlay+1,0:nlay+1) !direct radiation transmitted between five layers + real(r8) :: tri(0:4,0:4) !diffuse radiation transmitted between five layers + real(r8) :: tt(0:4,0:4) !unscattered direct radiation available at layer + real(r8) :: wl !fraction of LAI+SAI that is LAI + real(r8) :: ws !fraction of LAI+SAI that is SAI + real(r8) :: zenith !zenith angle + real(r8) :: ftdd_col !unscattered column transmission for direct beam + real(r8) :: fsun_f !forward incident light sunlit leaf absorption fraction + real(r8) :: fsun_b !backward incident light sunlit leaf absorption fraction + real(r8) :: fsun_a !temp variable 0.5*(fsun_f+fsun_b) + real(r8) :: fsun_d !temp variable 0.5*(fsun_f-fsun_b) + + real(r8) :: shadow_pd(ps:pe) !sky shadow area + real(r8) :: shadow_pi(ps:pe) !sky shadow area + real(r8) :: shadow_sky(ps:pe) !sky shadow area + real(r8) :: taud(ps:pe) !transmission to direct beam + real(r8) :: taui(ps:pe) !transmission to diffuse beam + real(r8) :: omega(ps:pe,numrad) !leaf/stem transmittance weighted by frac veg + real(r8) :: ftdi(ps:pe,numrad) !leaf/stem transmittance weighted by frac veg + real(r8) :: ftdd_orig(ps:pe,numrad) !leaf/stem transmittance weighted by frac veg + real(r8) :: ftdi_orig(ps:pe,numrad) !leaf/stem transmittance weighted by frac veg + real(r8) :: cosz(ps:pe) !0.001 <= coszen <= 1.000 + real(r8) :: cosd(ps:pe) !0.001 <= coszen <= 1.000 + logical :: soilveg(ps:pe) !true if pft over soil with veg and cosz > 0 + + real(r8) :: phi1(ps:pe), phi2(ps:pe) +!----------------------------------------------------------------------- + + ! 11/07/2018: calculate gee FUNCTION consider LAD + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + cdcw = 1. + cosz = coszen + zenith = acos(coszen) + cosz = cosz * sqrt(1 / (cdcw**2*sin(zenith)**2 + cos(zenith)**2)) + + cosd = cos(60._r8/180._r8*pi) + zenith = 60._r8/180._r8*pi + cosd = cosd * sqrt(1 / (cdcw**2*sin(zenith)**2 + cos(zenith)**2)) + + ! 11/07/2018: calculate gee FUNCTION consider LAD + gdir = phi1 + phi2*cosz + gdif = phi1 + phi2*cosd + + nsoilveg = 0 + + fc0 = D0 + omg_lay = D0; rho_lay = D0; tau_lay = D0 + chgt_lay = D0; cdcw_lay = D0; hbot_lay = D0 + csiz_lay = D0; lsai_lay = D0 + cosz_lay = D0; cosd_lay = D0 + gdir_lay = D0; gdif_lay = D0 + + DO ip = ps, pe + shadow_sky(ip) = D1 + + ! check elai and pft weight are non-zero + IF ( lsai(ip)>1.e-6_r8 .and. fcover(ip)>D0 ) THEN + + soilveg(ip) = .true. + nsoilveg = nsoilveg + 1 + + clev = canlay(ip) + fc0(clev) = fc0(clev) + fcover(ip) + + csiz_lay(clev) = csiz_lay(clev) + fcover(ip)*csiz(ip) + chgt_lay(clev) = chgt_lay(clev) + fcover(ip)*chgt(ip) + cdcw_lay(clev) = cdcw_lay(clev) + fcover(ip)*cdcw(ip) + lsai_lay(clev) = lsai_lay(clev) + fcover(ip)*lsai(ip) + cosz_lay(clev) = cosz_lay(clev) + fcover(ip)*cosz(ip) + cosd_lay(clev) = cosd_lay(clev) + fcover(ip)*cosd(ip) + gdir_lay(clev) = gdir_lay(clev) + fcover(ip)*gdir(ip) + gdif_lay(clev) = gdif_lay(clev) + fcover(ip)*gdif(ip) + + ! set optical properties + DO ib = 1, numrad + omega(ip,ib) = rho(ip,ib) + tau(ip,ib) + + ! sum of tau,rho and omega for pfts in a layer + tau_lay(clev,ib) = tau_lay(clev,ib) + fcover(ip)*(tau(ip,ib)) + rho_lay(clev,ib) = rho_lay(clev,ib) + fcover(ip)*(rho(ip,ib)) + omg_lay(clev,ib) = omg_lay(clev,ib) + fcover(ip)*(omega(ip,ib)) + + ENDDO ! ENDDO ib=1, numrad + ELSE + soilveg(ip) = .false. + ENDIF + ENDDO ! ENDDO ip + +!============================================================= +! layer average of lsai,tau,rho,omega... +!============================================================= + + DO lev = 1, 3 + IF (fc0(lev) > D0) THEN + csiz_lay(lev) = max(csiz_lay(lev)/fc0(lev),D0) + chgt_lay(lev) = max(chgt_lay(lev)/fc0(lev),D0) + hbot_lay(lev) = chgt_lay(lev) - csiz_lay(lev) + cdcw_lay(lev) = max(cdcw_lay(lev)/fc0(lev),D0) + lsai_lay(lev) = max(lsai_lay(lev)/fc0(lev),D0) + cosz_lay(lev) = max(cosz_lay(lev)/fc0(lev),D0) + cosd_lay(lev) = max(cosd_lay(lev)/fc0(lev),D0) + DO ib = 1, numrad + tau_lay(lev,ib) = max(tau_lay(lev,ib)/fc0(lev),D0) + rho_lay(lev,ib) = max(rho_lay(lev,ib)/fc0(lev),D0) + omg_lay(lev,ib) = max(omg_lay(lev,ib)/fc0(lev),D0) + ENDDO + gdir_lay(lev) = max(gdir_lay(lev)/fc0(lev),D0) + gdif_lay(lev) = max(gdif_lay(lev)/fc0(lev),D0) + ENDIF + ENDDO ! ENDDO ib + +!============================================================= +! layer shadows +!============================================================= + + shadow_d = D0 + shadow_i = D0 + DO lev =1, 3 + IF ( fc0(lev)>D0 .and. cosz_lay(lev)>D0 ) THEN + shadow_d(lev) = (D1 - exp(-D1*fc0(lev)/cosz_lay(lev))) & + / (D1 - fc0(lev)*exp(-D1/cosz_lay(lev))) + shadow_d(lev) = max(fc0(lev), shadow_d(lev)) + shadow_i(lev) = (D1 - exp(-D1*fc0(lev)/cosd_lay(lev))) & + / (D1 - fc0(lev)*exp(-D1/cosd_lay(lev))) + shadow_i(lev) = max(fc0(lev), shadow_i(lev)) + ENDIF + ENDDO + +!============================================================= +! taud and ftdd for layers +!============================================================= + + taud_lay = D0; taui_lay = D0 + ftdd_lay = D0; ftdi_lay = D0 + fcad_lay = D1; fcai_lay = D1 + ftdd_lay_orig = D0 + ftdi_lay_orig = D0 + + DO lev = 1, 3 + IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN + + taud_lay(lev) = D3/D4*gee*fc0(lev)*lsai_lay(lev) & + / (cosz_lay(lev)*shadow_d(lev)) + taui_lay(lev) = D3/D4*gee*fc0(lev)*lsai_lay(lev) & + / (cosd_lay(lev)*shadow_i(lev)) + + ! 11/07/2018: LAD calibration + ftdd_lay_orig(lev) = tee(DD1*taud_lay(lev)) + ftdi_lay_orig(lev) = tee(DD1*taui_lay(lev)) + + ! 11/07/2018: gdir/gdif = FUNCTION(xl, cos) + ftdd_lay(lev) = tee(DD1*taud_lay(lev)/gee*gdir_lay(lev)) + ftdi_lay(lev) = tee(DD1*taui_lay(lev)/gee*gdif_lay(lev)) + + ! calibration for chil + fcad_lay(lev) = (D1-ftdd_lay(lev)) / (D1-ftdd_lay_orig(lev)) + fcai_lay(lev) = (D1-ftdi_lay(lev)) / (D1-ftdi_lay_orig(lev)) + + ENDIF + ENDDO + + +!============================================================= +! absorption fraction in sunlit leaves in diffuse radiation format +! PART I +!============================================================= + + fsun_dd_lay(:) = D0 + fsun_dw_lay(:) = D0 + fsun_up_lay(:) = D0 + + DO lev = 1, 3 + IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN + + fsun_f = 0.5*(1. - tee(DD1*2.*taud_lay(lev))) & + / (1. - tee(DD1*taud_lay(lev))) + + fsun_b = 2.*(tee(DD1*taud_lay(lev)) - exp(-2.*taud_lay(lev))) & + / (1. - tee(DD1*taud_lay(lev))) + + fsun_a = 0.5*(fsun_f + fsun_b) + fsun_d = 0.5*(fsun_f - fsun_b) + + fsun_dd_lay(lev) = fsun_f + fsun_dw_lay(lev) = fsun_a + 0.5*cosz_lay(lev)*fsun_d + fsun_up_lay(lev) = fsun_a - 0.5*cosz_lay(lev)*fsun_d + ENDIF + ENDDO + +!============================================================= +! initialize local variables for layers +!============================================================= + + albd_col = D0; albi_col = D0 + fabd_col = D0; fabd_lay = D0 + fabi_col = D0; fabi_lay = D0 + frid_lay = D0; frii_lay = D0 + tt = D0 + +!============================================================= +! projection shadow overlapping fractions +!============================================================= + + zenith = acos(cosz_lay(3)) + shad_oa(3,2) = fc0(3)*OverlapArea(csiz_lay(3),chgt_lay(3)-hbot_lay(2), zenith) + shad_oa(3,1) = fc0(3)*OverlapArea(csiz_lay(3),chgt_lay(3)-hbot_lay(1), zenith) + zenith = acos(cosz_lay(2)) + shad_oa(2,1) = fc0(2)*OverlapArea(csiz_lay(2),chgt_lay(2)-hbot_lay(1), zenith) + +!============================================================= +! unscattered direct sunlight available at each layer +! 4:sky, 3:top 2:middle 1:bottom and 0:ground layer +!============================================================= + + ftdd_col = D0; tt = D0 + + tt(4,3) = shadow_d(3) + tt(4,3) = min(D1, max(D0, tt(4,3))) + tt(4,2) = shadow_d(2)*(D1-shadow_d(3)+shad_oa(3,2)) + tt(4,2) = min(1-tt(4,3), max(D0, tt(4,2))) + tt(4,1) = shadow_d(1)*(D1-(shadow_d(2)-shad_oa(2,1)) & + - (shadow_d(3)-shad_oa(3,1)) & + + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))) + tt(4,1) = min(1-tt(4,3)-tt(4,2), max(D0, tt(4,1))) + + tt(4,0) = D1-(shadow_d(1)+shadow_d(2)+shadow_d(3) & + - (shadow_d(2)-shad_oa(2,1))*shadow_d(1) & + - (shadow_d(3)-shad_oa(3,2))*shadow_d(2) & + - (shadow_d(3)-shad_oa(3,1))*shadow_d(1) & + + (shadow_d(2)-shad_oa(2,1))*(shadow_d(3)-shad_oa(3,2))*shadow_d(1)) + tt(4,0) = min(1-tt(4,3)-tt(4,2)-tt(4,1), max(D0, tt(4,0))) + + IF (tt(4,0) < 0) THEN + print *, abs(tt(4,0)) + ENDIF + + ! direct sunlight passing through top canopy layer + IF (shadow_d(3) > 0) THEN + tt(3,2) = shadow_d(2)*(shadow_d(3)-shad_oa(3,2)) + tt(3,2) = min(shadow_d(3), max(D0, tt(3,2))) + tt(3,1) = shadow_d(1)*(shadow_d(3)-shad_oa(3,1) & + - (shadow_d(3)-shad_oa(3,2))*(shadow_d(2)-shad_oa(2,1))) + tt(3,1) = min(shadow_d(3)-tt(3,2), max(D0, tt(3,1))) + tt(3,0) = shadow_d(3)-tt(3,2)-tt(3,1) + + tt(3,2) = tt(3,2)*ftdd_lay(3) + tt(3,1) = tt(3,1)*ftdd_lay(3) + tt(3,0) = tt(3,0)*ftdd_lay(3) + ENDIF + + ! direct sunlight passing through middle canopy layer + IF (shadow_d(2) > 0) THEN + tt(2,1) = shadow_d(1)*(shadow_d(2)-shad_oa(2,1)) + tt(2,1) = min(shadow_d(2), max(D0, tt(2,1))) + tt(2,0) = shadow_d(2)-tt(2,1) + + tt(2,1) = tt(2,1)*ftdd_lay(2)*(tt(4,2) + tt(3,2))/shadow_d(2) + tt(2,0) = tt(2,0)*ftdd_lay(2)*(tt(4,2) + tt(3,2))/shadow_d(2) + ENDIF + + ! direct sunlight passing through third canopy layer + IF (shadow_d(1) > 0) THEN + tt(1,0) = ftdd_lay(1)*(tt(4,1) + tt(3,1) + tt(2,1))!*shadow_d(1)/shadow_d(1) + ENDIF + +!============================================= +! Aggregate direct radiation to layers +!============================================= + + tt(4,3) = tt(4,3) + tt(3,2) = tt(4,2) + tt(3,2) + tt(2,1) = tt(4,1) + tt(3,1) + tt(2,1) + tt(1,0) = tt(4,0) + tt(3,0) + tt(2,0) + tt(1,0) + ftdd_col = tt(1,0) + + tt(0:4,4) = D0; tt(0:3,3) = D0 + tt(4:4,2) = D0; tt(0:2,2) = D0 + tt(3:4,1) = D0; tt(0:1,1) = D0 + tt(2:4,0) = D0; tt(0:0,0) = D0 + + +!======================================= +! start radiation beam loop +! ib=1:visible band 2:nir band +!======================================= + + DO ib = 1, numrad + + !=============================== + ! get pft level tau and ftdd + !=============================== + + ! 10/12/2017 + ftdi(:,ib) = D1 + + DO ip = ps, pe + + taud(ip) = D0 + taui(ip) = D0 + shadow_pd(ip) = D0 + shadow_pi(ip) = D0 + + IF (soilveg(ip)) THEN + clev = canlay(ip) + + !================================================ + ! fractional contribution of current pft in layer + !================================================ + + pfc = min( fcover(ip)/fc0(clev), D1) + shadow_pd(ip) = pfc*shadow_d(clev) + shadow_pi(ip) = pfc*shadow_i(clev) + + !===================================== + ! get taud,taui at pft level + !===================================== + + taud(ip) = D3/D4*gee*fcover(ip)*(lsai(ip)) & + / (cosz(ip)*shadow_pd(ip)) + + taui(ip) = D3/D4*gee*fcover(ip)*(lsai(ip)) & + / (cosd(ip)*shadow_pi(ip)) + + !==================================== + ! transmission at pft level + !==================================== + + ftdd_orig(ip,ib) = tee(DD1*taud(ip)) + ftdi_orig(ip,ib) = tee(DD1*taui(ip)) + + ! 11/07/2018: gdir/gdif = FUNCTION(xl, cos) + ftdd(ip,ib) = tee(DD1*taud(ip)/gee*gdir(ip)) + ftdi(ip,ib) = tee(DD1*taui(ip)/gee*gdif(ip)) + + ! calibration for chil + fcad(ip) = (D1-ftdd(ip,ib)) / (D1-ftdd_orig(ip,ib)) + fcai(ip) = (D1-ftdi(ip,ib)) / (D1-ftdi_orig(ip,ib)) + + ENDIF ! ENDIF soilveg + ENDDO ! ENDDO ip + + !=============================================================== + ! absorption, reflection and transmittance for three canopy layer + ! using average optical properties of layers + ! subroutine CanopyRad calculates fluxes for unit input radiation + !=============================================================== + + ftid_lay=D0; ftii_lay=D1 + frid_lay=D0; frii_lay=D0 + faid_lay=D0; faii_lay=D0 + + DO lev = 1, 3 + IF (shadow_d(lev) > D0) THEN + CALL CanopyRad(taud_lay(lev), taui_lay(lev), ftdd_lay_orig(lev),& + ftdi_lay_orig(lev), cosz_lay(lev), cosd_lay(lev), shadow_d(lev), & + shadow_i(lev), fc0(lev), omg_lay(lev,ib), lsai_lay(lev), & + tau_lay(lev,ib), rho_lay(lev,ib), ftid_lay(lev), & + ftii_lay(lev), frid_lay(lev), frii_lay(lev),& + faid_lay(lev), faii_lay(lev)) + ENDIF + ENDDO ! ENDDO lev + + ! 11/07/2018: calibration for LAD + ftid_lay(:) = fcad_lay(:)*ftid_lay(:) + ftii_lay(:) = fcai_lay(:)*(ftii_lay(:)-ftdi_lay_orig(:)) + ftdi_lay(:) + frid_lay(:) = fcad_lay(:)*frid_lay(:) + frii_lay(:) = fcai_lay(:)*frii_lay(:) + faid_lay(:) = fcad_lay(:)*faid_lay(:) + faii_lay(:) = fcai_lay(:)*faii_lay(:) + + !============================================= + ! Calculate layer direct beam radiation absorbed + ! in the sunlit canopy as direct + !============================================= + + fadd_lay(:,ib) = D0 + + DO lev = 1, nlay + IF ( fc0(lev)>D0 .and. lsai_lay(lev)>D0 ) THEN + fadd_lay(lev,ib) = tt(lev+1,lev) * & + (D1-ftdd_lay(lev)) * (D1-omg_lay(lev,ib)) + ENDIF + ENDDO + + A = D0; B = D0; + fabs_leq = D0 + + ! Calculate the coefficients matrix A + A(1,1) = 1.0; A(1,3) = -shadow_i(3)*ftii_lay(3) + shadow_i(3) - 1.0; + A(2,2) = 1.0; A(2,3) = -shadow_i(3)*frii_lay(3); + A(3,3) = 1.0; A(3,2) = -shadow_i(2)*frii_lay(2); + A(3,5) = -shadow_i(2)*ftii_lay(2) + shadow_i(2) - 1.0; + + A(4,4) = 1.0; A(4,5) = -shadow_i(2)*frii_lay(2); + A(4,2) = -shadow_i(2)*ftii_lay(2) + shadow_i(2) - 1.0; + + A(5,5) = 1.0; A(5,4) = -shadow_i(1)*frii_lay(1); + A(5,6) =(-shadow_i(1)*ftii_lay(1) + shadow_i(1) - 1.0) * albgri(ib); + + A(6,6) = 1.0 - albgri(ib)*shadow_i(1)*frii_lay(1); + A(6,4) = -shadow_i(1)*ftii_lay(1) + shadow_i(1) - 1.0; + + ! The constant vector B at right side + B(1,1) = tt(4,3)*frid_lay(3); B(1,2) = shadow_i(3)*frii_lay(3); + B(2,1) = tt(4,3)*ftid_lay(3); B(2,2) = shadow_i(3)*ftii_lay(3) - shadow_i(3) + 1.0; + B(3,1) = tt(3,2)*frid_lay(2); B(3,2) = 0.0; + B(4,1) = tt(3,2)*ftid_lay(2); B(4,2) = 0.0; + + B(5,1) = tt(2,1)*frid_lay(1) & + + tt(1,0)*albgrd(ib)*(shadow_i(1)*ftii_lay(1) - shadow_i(1) + 1.0); + B(5,2) = 0.0; + + B(6,1) = tt(2,1)*ftid_lay(1) + tt(1,0)*albgrd(ib)*shadow_i(1)*frii_lay(1); + B(6,2) = 0.0; + + ! Get the resolution + CALL mGauss(A, B, X) + + ! ==================================================== + ! Set back to the absorption for each layer and albedo + ! ==================================================== + + ! Albedo + fabs_leq(4,:) = X(1,:) + + ! Three layers' absorption for incident direct radiation + fabs_leq(3,1) = tt(4,3)*faid_lay(3) & + + X(3,1) *shadow_i(3)*faii_lay(3) + fabs_leq(2,1) = tt(3,2)*faid_lay(2) & + + (X(2,1) + X(5,1)) *shadow_i(2)*faii_lay(2) + fabs_leq(1,1) = tt(2,1)*faid_lay(1) & + + (X(4,1) + X(6,1)*albgri(ib) + tt(1,0)*albgrd(ib))*shadow_i(1)*faii_lay(1) + + ! Ground absorption + fabs_leq(0,1) = tt(1,0)*(1.0 - albgrd(ib)) + X(6,1)*(1.0 - albgri(ib)) + + + ! Three layers' absorption for incident diffuse radiation + fabs_leq(3,2) = (1. + X(3,2)) *shadow_i(3)*faii_lay(3) + fabs_leq(2,2) = (X(2,2) + X(5,2)) *shadow_i(2)*faii_lay(2) + fabs_leq(1,2) = (X(4,2) + X(6,2)*albgri(ib)) *shadow_i(1)*faii_lay(1) + + ! Ground absorption + fabs_leq(0,2) = X(6,2) * (1.0 - albgri(ib)) + + + ! IF everything is ok, substitute fabs_lay for fabs_leq + ! and delete the following line and the variables defined + ! but not used anymore + fabs_lay = fabs_leq + + ! set column absorption and reflection + fabd_lay(1:3,ib) = fabs_lay(1:3,1) + fabi_lay(1:3,ib) = fabs_lay(1:3,2) + fabd_col(ib) = fabs_lay(1,1) + fabs_lay(2,1) + fabs_lay(3,1) + fabi_col(ib) = fabs_lay(1,2) + fabs_lay(2,2) + fabs_lay(3,2) + albd_col(ib) = fabs_lay(4,1) + albi_col(ib) = fabs_lay(4,2) + + ! calculation for sunlit fraction and sunlit absorption for each layer + IF (ib == 1) THEN !visible band only + + psun_lay(:) = D0 + fsun_id_lay(:) = D0 + fsun_ii_lay(:) = D0 + + ! - layer 3 - + IF ( fc0(3)>D0 .and. lsai_lay(3)>D0 ) THEN + ! sunlit fraction for layers + psun_lay(3) = tt(4,3)/shadow_d(3) + ! absorption fraction in sunlit leaves in diffuse radiation format + ! PART II + fsun_id_lay(3) = (psun_lay(3)*fsun_dd_lay(3) + X(3,1)*fsun_up_lay(3)) & + / (psun_lay(3) + X(3,1)) + fsun_ii_lay(3) = (1.*fsun_dw_lay(3) + X(3,2)*fsun_up_lay(3)) & + / (1. + X(3,2)) + ENDIF + + ! - layer 2 - + IF ( fc0(2)>D0 .and. lsai_lay(2)>D0 ) THEN + ! sunlit fraction for layers + psun_lay(2) = tt(3,2)/shadow_d(2) + ! absorption fraction in sunlit leaves in diffuse radiation format + ! PART II + fsun_id_lay(2) = (psun_lay(2)*fsun_dd_lay(2) + X(2,1)*fsun_dw_lay(2) & + + X(5,1)*fsun_up_lay(2)) & + / (psun_lay(2) + X(2,1) + X(5,1)) + fsun_ii_lay(2) = (X(2,2)*fsun_dw_lay(2) + X(5,2)*fsun_up_lay(2)) & + / (X(2,2) + X(5,2)) + ENDIF + + ! - layer 1 - + IF ( fc0(1)>D0 .and. lsai_lay(1)>D0 ) THEN + ! sunlit fraction for layers + psun_lay(1) = tt(2,1)/shadow_d(1) + ! absorption fraction in sunlit leaves in diffuse radiation format + ! PART II + fsun_id_lay(1) = (psun_lay(1)*fsun_dd_lay(1) + X(4,1)*fsun_dw_lay(1) & + + (X(6,1)*albgri(ib) + tt(1,0)*albgrd(ib))*fsun_up_lay(1)) & + / (psun_lay(1) + X(4,1) + X(6,1)*albgri(ib) + tt(1,0)*albgrd(ib)) + fsun_ii_lay(1) = (X(4,2)*fsun_dw_lay(1) + X(6,2)*albgri(ib)*fsun_up_lay(1)) & + / (X(4,2) + X(6,2)*albgri(ib)) + ENDIF + ENDIF + + ! balance check + IF (abs(fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1) > 1e-6) THEN + print *, "Imbalance kband=1" + print *, fabd_col(ib)+albd_col(ib)+fabs_lay(0,1)-1 + ENDIF + IF (abs(fabi_col(ib)+albi_col(ib)+fabs_lay(0,2)-1) > 1e-6) THEN + print *, "Imbalance kband=2" + print *, fabi_col(ib)+albi_col(ib)+fabs_lay(0,2)-1 + ENDIF + + !==================================================== + ! Calculate individual PFT absorption + !==================================================== + + sum_fabd = D0 + sum_fabi = D0 + sum_fadd = D0 + + DO ip = ps, pe + clev = canlay(ip) + IF (clev == D0) CYCLE + IF ( shadow_d(clev)>D0 .and. soilveg(ip) ) THEN + + !================================================= + ! fractional contribution of current pft in layer + !================================================= + + pfc = min( fcover(ip)/fc0(clev), D1) + + !========================================= + ! shadow contribution from ground to sky + !========================================= + + shadow_sky(ip) = shadow_pi(ip) + + !======================================================= + ! absorption, reflection and transmittance fluxes for + ! unit incident radiation over pft. + !======================================================= + + CALL CanopyRad(taud(ip), taui(ip), ftdd_orig(ip,ib), ftdi_orig(ip,ib), & + cosz(ip),cosd(ip), shadow_pd(ip), shadow_pi(ip), fcover(ip),& + omega(ip,ib), lsai(ip), tau(ip,ib),& + rho(ip,ib), ftid(ip,ib), ftii(ip,ib), albd(ip,ib),& + albi(ip,ib), faid_p, faii_p) + + ! calibration for LAD + ! 11/07/2018: calibration for LAD + ftid(ip,ib) = fcad(ip)*ftid(ip,ib) + ftii(ip,ib) = fcai(ip)*(ftii(ip,ib)-ftdi_orig(ip,ib)) + ftdi(ip,ib) + albd(ip,ib) = fcad(ip)*albd(ip,ib) + albi(ip,ib) = fcai(ip)*albi(ip,ib) + faid_p = fcad(ip)*faid_p + faii_p = fcai(ip)*faii_p + + ! absorptions after multiple reflections for each pft + probm = albi(ip,ib)*shadow_sky(ip)*albgri(ib) + ftran = (D1-shadow_pd(ip)+shadow_pd(ip)*ftdd(ip,ib))*albgrd(ib) & + + shadow_pd(ip)*ftid(ip,ib)*albgri(ib) + fabsm = ftran*faii_p*shadow_sky(ip)/(D1-probm) + fabd(ip,ib) = shadow_pd(ip)*faid_p + fabsm + + probm = albi(ip,ib)*shadow_sky(ip)*albgri(ib) + ftran = D1-shadow_pi(ip)*(D1 -ftii(ip,ib)) + fabsm = ftran*albgri(ib)*faii_p*shadow_sky(ip)/(D1-probm) + fabi(ip,ib) = shadow_pi(ip)*faii_p + fabsm + + ! sum of pft absorptions in column + sum_fabd(clev) = sum_fabd(clev) + fabd(ip,ib) + sum_fabi(clev) = sum_fabi(clev) + fabi(ip,ib) + + ! pft absorption in sunlit as direct beam + fadd(ip,ib) = shadow_pd(ip) * (D1-ftdd(ip,ib)) * (D1-omega(ip,ib)) + + ! sum of pft absorption in sunlit as direct beam + sum_fadd(clev) = sum_fadd(clev) + fadd(ip,ib) + + ENDIF ! ENDIF shadow & soilveg + ENDDO ! ENDDO ip + + DO ip = ps, pe + clev = canlay(ip) + + !=========================================================== + ! adjust pft absorption for total column absorption per + ! unit column area + !=========================================================== + + IF (soilveg(ip)) THEN + fabd(ip,ib) = fabd(ip,ib)*fabd_lay(clev,ib) & + / sum_fabd(clev)/fcover(ip) + fabi(ip,ib) = fabi(ip,ib)*fabi_lay(clev,ib) & + / sum_fabi(clev)/fcover(ip) + + fadd(ip,ib) = fadd(ip,ib)*fadd_lay(clev,ib) & + / sum_fadd(clev)/fcover(ip) + + fadd(ip,ib) = min(fabd(ip,ib), fadd(ip,ib)) + + psun(ip) = psun_lay(clev) + fsun_id(ip) = fsun_id_lay(clev) + fsun_ii(ip) = fsun_ii_lay(clev) + + ELSE + fabd(ip,ib) = D0 + fabi(ip,ib) = D0 + fadd(ip,ib) = D0 + + psun(ip) = D0 + fsun_id(ip) = D0 + fsun_ii(ip) = D0 + ENDIF + + ! column albedo is assigned to each pft in column + ! Added by Yuan, 06/03/2012 + albd(ip,ib) = albd_col(ib) + albi(ip,ib) = albi_col(ib) + + ! adjust ftdd and ftii for multi reflections between layers + +! 03/06/2020, yuan: NOTE! there is no physical mean of ftdd, +! ftid, ftii anymore. they are the same for each PFT can only +! be used to calculate the ground absorption. + ftdd(ip,ib) = ftdd_col + ftid(ip,ib) = (D1-albd(ip,ib)-fabd_col(ib)-& + ftdd(ip,ib)*(D1-albgrd(ib))) /(D1-albgri(ib)) + ftii(ip,ib) = (D1-albi(ip,ib)-fabi_col(ib))/(D1-albgri(ib)) + + !ftdd(ip,ib) = min(max(ftdd(ip,ib),D0),D1) + !ftii(ip,ib) = min(max(ftii(ip,ib),D0),D1) + !ftid(ip,ib) = min(max(ftid(ip,ib),D0),D1) + + ! check energy balance + !fabd(ip,ib) = D1 - albd(ip,ib) & + ! - ftdd(ip,ib)*(D1-albgrd(ib)) & + ! - ftid(ip,ib)*(D1-albgri(ib)) + !fabi(ip,ib) = D1 - albi(ip,ib) & + ! - ftii(ip,ib)*(D1-albgri(ib)) + + ENDDO ! ENDDO ip + ENDDO !ENDDO ib + + ! set parameters for longwave calculation + fshade(:) = shadow_pi(:) + thermk(:) = ftdi(:,1) + + END SUBROUTINE ThreeDCanopy + +!----------------------------------------------------------------------- +! FUNCTION tee +!----------------------------------------------------------------------- + + real(selected_real_kind(12)) FUNCTION tee(tau) + + IMPLICIT NONE + + real(r16), parameter :: DDH = 0.50_r16 !128-bit accuracy real + real(r16), parameter :: DD1 = 1.0_r16 !128-bit accuracy real + real(r16), parameter :: DD2 = 2.0_r16 !128-bit accuracy real + real(r16) :: tau ! transmittance + + tee = DDH*(DD1/tau/tau-(DD1/tau/tau+DD2/tau)*exp(-DD2*tau)) + + END FUNCTION tee + +!----------------------------------------------------------------------- +! FUNCTION overlapArea +!----------------------------------------------------------------------- + + real(selected_real_kind(12)) FUNCTION OverlapArea(radius, hgt, zenith) + + IMPLICIT NONE + + real(r8), parameter :: rpi = 3.14159265358979323846_R8 !pi + real(r8), parameter :: D0 = 0.0_r8 !128-bit accuracy real + real(r8), parameter :: D1 = 1.0_r8 !128-bit accuracy real + + real(r8) :: radius !radius of bus + real(r8) :: hgt !height of canopy + real(r8) :: zenith !zenith angle + real(r8) :: cost !cosine of angle + real(r8) :: theta !angle + + IF (radius == D0) THEN + OverlapArea= D0 + RETURN + ENDIF + cost = hgt*tan(zenith)/radius/(D1+D1/cos(zenith)) + IF (cost >= 1) THEN + OverlapArea= D0 + RETURN + ENDIF + theta = acos(cost) + OverlapArea = (theta-cost*sin(theta))*(D1+D1/cos(zenith))/rpi + RETURN + END FUNCTION OverlapArea + +!----------------------------------------------------------------------- +! FUNCTION to calculate scattering, absorption, reflection and +! transmittance for unit input radiation +!----------------------------------------------------------------------- + + SUBROUTINE CanopyRad(tau_d, tau_i, ftdd, ftdi, cosz, cosd, & + shadow_d, shadow_i, fc, omg, lsai, tau_p, rho_p, & + ftid, ftii, frid, frii, faid, faii) + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8) :: cosz !0.001 <= coszen <= 1.000 + real(r8) :: cosd !0.001 <= coszen <= 1.000 + real(r8) :: faid !direct absorption + real(r8) :: faii !diffuse absorption + real(r8) :: fc !fraction of grid covered with canopy + real(r8) :: frid !direct reflectance + real(r8) :: frii !diffuse reflectance + real(r8) :: frio !diffuse reflectance + real(r8) :: ftdd !down direct flux below veg per unit dir flx + real(r8) :: ftdi !down direct flux below veg per unit dif flux + real(r8) :: ftid !direct transmittance + real(r8) :: ftii !diffuse transmittance + real(r8) :: omg !frac of intercepted rad that is scattered + real(r8) :: rho_p !leaf/stem reflectance weighted by fract of LAI and SAI + real(r8) :: shadow_d !canopy shadow for direct solar + real(r8) :: shadow_i !canopy shadow for diffuse solar + real(r8) :: tau_d !radial optical depth for direct beam + real(r8) :: tau_i !radial optical depth for indirect beam + real(r8) :: tau_p !leaf/stem transmission weighted by frac of LAI & SAI + real(r8) :: lsai !elai+esai + + ! output variables + real(r8) :: phi_dif_d !difference of rad scattered forward-backward per direct beam + real(r8) :: phi_dif_i !difference of rad scattered forward-backward per direct beam + real(r8) :: phi_tot_d !total rad scattered in all direction per direct beam + real(r8) :: phi_tot_i !total rad scattered in all direction per diffuse beam + real(r8) :: phi_tot_o !total rad scattered in all direction per direct beam + real(r8) :: phi_dif_o !total rad scattered in all direction per diffuse beam + real(r8) :: pa2 !total rad scattered in all direction per direct beam + +!-------------------------- Local Variables ---------------------------- + logical :: runmode = .true. + real(r8) :: tau + real(r8) :: muv !forward frac of 3D scat rad in all direction for diffuse + real(r8) :: ac !forward frac of 3D scat rad in all direction for diffuse + real(r8) :: ald !forward frac of 3D scat rad in all direction for diffuse + real(r8) :: ali !forward frac of 3D scat rad in all direction for diffuse + + real(r8) :: wb !EQ. (2.14), Dickinson 1983, omega*beta + real(r8) :: alpha !EQ. (2.14), Dickinson 1983, alpha + real(r8) :: nd !EQ. (4), Appendix 1, Yuan, dissertation + real(r8) :: ni !EQ. (4), Appendix 1, Yuan, dissertation + real(r8) :: gee=0.5_r8 !Ross factor geometric blocking + + real(r8) , parameter :: D0 = 0.0_r8 !64-bit real number + real(r8) , parameter :: D1 = 1.0_r8 !64-bit real number + real(r8) , parameter :: D2 = 2.0_r8 !64-bit real number + real(r8) , parameter :: D3 = 3.0_r8 !64-bit real number + real(r8) , parameter :: D4 = 4.0_r8 !64-bit real number + real(r8) , parameter :: D6 = 6.0_r8 !64-bit real number + real(r8) , parameter :: DH = 0.5_r8 !64-bit real number + real(r16), parameter :: DD1 = 1.0_r16 !128-bit real number + + real(r8) , parameter :: pi = 3.14159265358979323846_R8 !pi +!----------------------------------------------------------------------- + + tau = D3/D4*gee*lsai + + CALL phi(runmode, tau_d, omg, tau_p, rho_p, phi_tot_d, phi_dif_d, pa2) + CALL phi(runmode, tau_i, omg, tau_p, rho_p, phi_tot_i, phi_dif_i, pa2) + CALL phi(runmode, tau , omg, tau_p, rho_p, phi_tot_o, phi_dif_o, pa2) + + IF (runmode) THEN + ! NOTE: modified + frio = DH*(phi_tot_o - DH*phi_dif_o) + frio = max(min(frio,D1),D0) + + muv = D3*( D1 - sqrt(D1-sqrt(D3)*fc/(D2*pi)) ) + & + D3*( D1 - sqrt(D1-sqrt(D3)*fc/(D6*pi)) ) + + wb = D2/D3*rho_p + D1/D3*tau_p + alpha = sqrt(D1-omg) * sqrt(D1-omg+D2*wb) + nd = (D1 + D2*alpha) / (D1 + D2*alpha*cosz) + ni = (D1 + D2*alpha) / (D1 + D2*alpha*cosd) + + ac = phi_tot_o * muv * (D1-tee(DD1*tau)) * (D1-omg) / (D1-omg*pa2) + ald = (nd-D1) * frio * fc * (D1/shadow_d - cosz/fc) + ali = (ni-D1) * frio * fc * (D1/shadow_i - cosd/fc) + ENDIF + +!----------------------------------------------------------------------- +!frac indirect downward rad through canopy for black soil & direct solar +!----------------------------------------------------------------------- + frid = DH*(phi_tot_d - DH*cosz*phi_dif_d) + frii = DH*(phi_tot_i - DH*cosd*phi_dif_i) + + IF (runmode) THEN + frid = frid + ald - DH*ac + frii = frii + ali - DH*ac + ENDIF + + frid = max(min(frid,D1),D0) + frii = max(min(frii,D1),D0) + +!--------------------------------------------------------------------- +!downward diffuse fraction from direct and diffuse sun +!--------------------------------------------------------------------- + ftid = DH*(phi_tot_d + DH*cosz*phi_dif_d) + ftii = DH*(phi_tot_i + DH*cosd*phi_dif_i) + ftdi + + IF (runmode) THEN + ftid = ftid - DH*ald - DH*ac + ftii = ftii - DH*ali - DH*ac + ENDIF + + ftid = max(min(ftid,D1),D0) + ftii = max(min(ftii,D1),D0) + +!--------------------------------------------------------------------- +! canopy absorption for direct or diffuse beams +!--------------------------------------------------------------------- + IF (.not. runmode) THEN + faid = D1 - ftdd - phi_tot_d + faii = D1 - ftdi - phi_tot_i + ELSE + faid = D1 - ftdd - frid - ftid + faii = D1 - frii - ftii + ENDIF + + faid = max(min(faid,D1),D0) + faii = max(min(faii,D1),D0) + + IF (shadow_d == D0) THEN + ! NOTE: corrected from D1 -> D0 + ftid = D0 + frid = D0 + faid = D0 + ENDIF + IF (shadow_i == D0) THEN + ftii = D1 + frii = D0 + faii = D0 + ENDIF + + END SUBROUTINE CanopyRad + + + SUBROUTINE phi(runmode, tau, omg, tau_p, rho_p, phi_tot, phi_dif, pa2) + + IMPLICIT NONE + + ! input variables + logical :: runmode + real(r8) :: omg !frac of intercepted rad that is scattered + real(r8) :: rho_p !leaf/stem reflectance weighted by frac of LAI and SAI + real(r8) :: tau !radial optical depth for direct beam + real(r8) :: tau_p !leaf/stem transmission weighted by frac of LAI & SAI + + ! output variables + real(r8) :: phi_dif !difference of rad scattered forward-backward + real(r8) :: phi_tot !total rad scattered in all direction + real(r8) :: pa2 !total rad scattered in all direction + + ! local variables + real(r8) :: pac !probability of absorption after two scatterings + real(r8) :: phi_1b !backward single scattered radiation + real(r8) :: phi_1f !forward single scattered radiation + real(r8) :: phi_2a !average second-order scattered radiation + real(r8) :: phi_2b !backward second-order scattered radiation + real(r8) :: phi_2f !forward second-order scattered radiation + real(r8) :: phi_mb !backward multiple scattered radiation + real(r8) :: phi_mf !forward multiple scattered radiation + real(r8) :: phi_tb !backward frac of 3D scat rad in all direction + real(r8) :: phi_tf !forward frac of 3D scat rad in all direction + real(r8) :: aa,bb !temporary constants + + real(r8) , parameter :: D0 = 0.0_r8 !64-bit real number + real(r8) , parameter :: D1 = 1.0_r8 !64-bit real number + + real(r16), parameter :: DD1 = 1.0_r16 !128-bit real number + real(r16), parameter :: DD2 = 2.0_r16 !128-bit real number + real(r16), parameter :: DD3 = 3.0_r16 !128-bit real number + real(r16), parameter :: DD4 = 4.0_r16 !128-bit real number + real(r16), parameter :: DD9 = 9.0_r16 !128-bit real number + real(r16), parameter :: DD10 = 10.0_r16 !128-bit real number + real(r16), parameter :: DDH = 0.5_r16 !128-bit real number + +!---------------------------------------------------------------------- +! single scattering terms for sphere with overlap corrections to path +! for direct and diffuse beams +!---------------------------------------------------------------------- + + ! forward first order normalized scattering + phi_1f = (DD1/tau/tau - (DD1/tau/tau + DD2/tau + DD2)*exp(-DD2*tau)) + + ! backward first order normalized scattering + phi_1b = DDH*(DD1 - tee(DD2*tau)) + +!---------------------------------------------------------------------- +! sphere double scattering terms (RED 2008 Eqs. 19,20) +!---------------------------------------------------------------------- + + IF (.not. runmode) THEN + + ! forward double scattering + phi_2f = DDH*(DD4*phi_1f/DD3 + tee(DD2*tau) + tee(DD4*tau)/DD9 - & + DD10*tee(DD1*tau)/DD9) + + ! backward double scattering + phi_2b = DDH*(DD1/DD3 - tee(DD2*tau) + DD2*tee(DD3*tau)/DD3) + + ELSE + ! fitting FUNCTION for second order scattering + aa = 0.70_r8 + bb = 1.74_r8 + + phi_2b = aa*( DD1/(bb+DD1) -DD1/(bb-D1)*tee(DD2*tau) + & + DD2/(bb+DD1)/(bb-DD1)*tee((DD1+bb)*tau) ) + + phi_2f = aa*( DD2*bb/(bb*bb-DD1)*phi_1f - & + (DD1/(bb+DD1)/(bb+DD1) + DD1/(bb-DD1)/(bb-DD1))*tee(DD1*tau) + & + DD1/(bb-DD1)/(bb-DD1)*tee(DD1*tau*bb) + & + DD1/(bb+DD1)/(bb+DD1)*tee(DD1*(bb+DD2)*tau) ) + ENDIF + + ! second order average scattering + phi_2a = DDH*(phi_2b + phi_2f) + +!---------------------------------------------------------------------- +! probability of absorption after two scattering +!---------------------------------------------------------------------- + + ! probability of absorption for diffuse beam + ! corrected probability of absorption for direct beam + pac = DD1-phi_2a / & + (DD1 - tee(DD1*tau) - (rho_p*phi_1b + tau_p*phi_1f)/(tau_p+rho_p)) + + pac = max(min(pac,D1),D0) + pa2 = pac + +!---------------------------------------------------------------------- +!third order and higher order scatterings +!---------------------------------------------------------------------- + + phi_mf = phi_2f + omg*pac*phi_2a/(DD1-omg*pac) + phi_mb = phi_2b + omg*pac*phi_2a/(DD1-omg*pac) + +!---------------------------------------------------------------------- +! total sphere scattering,forward,backward, avg & diff for direct beam +!---------------------------------------------------------------------- + + phi_tf = tau_p*phi_1f + DDH*omg*omg*phi_mf + phi_tb = rho_p*phi_1b + DDH*omg*omg*phi_mb + + phi_tot = phi_tf + phi_tb + phi_dif = phi_tf - phi_tb + + END SUBROUTINE phi + + SUBROUTINE mGauss(A, B, X) + + IMPLICIT NONE + + real(r8), intent(inout) :: A(6,6) + real(r8), intent(inout) :: B(6,2) + real(r8), intent(out) :: X(6,2) + + integer :: i, j + integer :: nstep(5) = (/0, 2, 1, 2, 1/) + + real(r8) :: f + + ! Elimination + DO i = 1, 5 + DO j = i+1, i+nstep(i) + IF (abs(A(i,i)) < 1.e-10) THEN + print *, "Error in Gauss's solution" + RETURN + ENDIF + f = - A(j,i)/A(i,i) + A(j,:) = A(j,:) + f*A(i,:) + B(j,:) = B(j,:) + f*B(i,:) + ENDDO + ENDDO + + ! Back substitution + X(6,:) = B(6,:)/A(6,6) + DO i = 5, 1, -1 + X(i,1) = (B(i,1) - sum(A(i,i+1:6)*X(i+1:6,1))) / A(i,i) + X(i,2) = (B(i,2) - sum(A(i,i+1:6)*X(i+1:6,2))) / A(i,i) + ENDDO + + END SUBROUTINE mGauss + +END MODULE MOD_3DCanopyRadiation +! --------- EOP ---------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Aerosol.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Aerosol.F90 new file mode 100644 index 0000000000..3f943a1504 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Aerosol.F90 @@ -0,0 +1,434 @@ +#include + +MODULE MOD_Aerosol + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_Vars_Global, only: maxsnl + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: AerosolMasses + PUBLIC :: AerosolFluxes + PUBLIC :: AerosolDepInit + PUBLIC :: AerosolDepReadin + +! PUBLIC DATA MEMBERS: +!----------------------------------------------------------------------- + + logical, parameter :: use_extrasnowlayers = .false. + real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius + ! (also "fresh snow" value) [microns] + real(r8), parameter :: fresh_snw_rds_max = 204.526_r8 ! maximum warm fresh snow effective radius + + character(len=256) :: file_aerosol + + type(grid_type) :: grid_aerosol + type(block_data_real8_2d) :: f_aerdep + type(spatial_mapping_type) :: mg2p_aerdep + + integer, parameter :: start_year = 1849 + integer, parameter :: end_year = 2001 + + integer :: month_p + +CONTAINS + + SUBROUTINE AerosolMasses( dtime ,snl ,do_capsnow ,& + h2osno_ice ,h2osno_liq ,qflx_snwcp_ice ,snw_rds ,& + + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate column-integrated aerosol masses, and +! mass concentrations for radiative calculations and output +! (based on new snow level state, after SnowFilter is rebuilt. +! NEEDS TO BE AFTER SnowFiler is rebuilt in Hydrology2, otherwise there +! can be zero snow layers but an active column in filter) +!----------------------------------------------------------------------- + + IMPLICIT NONE + + ! !ARGUMENTS: + ! + real(r8),intent(in) :: dtime ! seconds in a time step [second] + integer, intent(in) :: snl ! number of snow layers + + logical, intent(in) :: do_capsnow ! true => do snow capping + real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens (kg/m2) + real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water (kg/m2) + real(r8), intent(in) :: qflx_snwcp_ice ! excess snowfall due to snow capping (mm H2O /s) + + real(r8), intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective snow grain radius + ! [microns, m^-6] + + real(r8), intent(inout) :: mss_bcpho ( maxsnl+1:0 ) ! mass of hydrophobic BC in snow [kg] + real(r8), intent(inout) :: mss_bcphi ( maxsnl+1:0 ) ! mass of hydrophillic BC in snow [kg] + real(r8), intent(inout) :: mss_ocpho ( maxsnl+1:0 ) ! mass of hydrophobic OC in snow [kg] + real(r8), intent(inout) :: mss_ocphi ( maxsnl+1:0 ) ! mass of hydrophillic OC in snow [kg] + real(r8), intent(inout) :: mss_dst1 ( maxsnl+1:0 ) ! mass of dust species 1 in snow [kg] + real(r8), intent(inout) :: mss_dst2 ( maxsnl+1:0 ) ! mass of dust species 2 in snow [kg] + real(r8), intent(inout) :: mss_dst3 ( maxsnl+1:0 ) ! mass of dust species 3 in snow [kg] + real(r8), intent(inout) :: mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow [kg] + + real(r8), intent(out) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of BC 1 [kg/kg] + real(r8), intent(out) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of BC 2 [kg/kg] + real(r8), intent(out) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of OC 1 [kg/kg] + real(r8), intent(out) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of OC 2 [kg/kg] + real(r8), intent(out) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust 1 [kg/kg] + real(r8), intent(out) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust 2 [kg/kg] + real(r8), intent(out) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust 3 [kg/kg] + real(r8), intent(out) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust 4 [kg/kg] + + ! !LOCAL VARIABLES: + integer :: c,j ! indices + real(r8) :: snowmass ! liquid+ice snow mass in a layer [kg/m2] + real(r8) :: snowcap_scl_fct ! temporary factor used to correct for snow capping + + !----------------------------------------------------------------------- + + DO j = maxsnl+1, 0 + + ! layer mass of snow: + snowmass = h2osno_ice(j) + h2osno_liq(j) + + IF (.not. use_extrasnowlayers) THEN + ! Correct the top layer aerosol mass to account for snow capping. + ! This approach conserves the aerosol mass concentration + ! (but not the aerosol mass) when snow-capping is invoked + + IF (j == snl+1) THEN + IF (do_capsnow) THEN + + snowcap_scl_fct = snowmass / (snowmass + (qflx_snwcp_ice*dtime)) + + mss_bcpho(j) = mss_bcpho(j)*snowcap_scl_fct + mss_bcphi(j) = mss_bcphi(j)*snowcap_scl_fct + mss_ocpho(j) = mss_ocpho(j)*snowcap_scl_fct + mss_ocphi(j) = mss_ocphi(j)*snowcap_scl_fct + + mss_dst1(j) = mss_dst1(j)*snowcap_scl_fct + mss_dst2(j) = mss_dst2(j)*snowcap_scl_fct + mss_dst3(j) = mss_dst3(j)*snowcap_scl_fct + mss_dst4(j) = mss_dst4(j)*snowcap_scl_fct + ENDIF + ENDIF + ENDIF + + IF (j >= snl+1) THEN + + mss_cnc_bcphi(j) = mss_bcphi(j) / snowmass + mss_cnc_bcpho(j) = mss_bcpho(j) / snowmass + + mss_cnc_ocphi(j) = mss_ocphi(j) / snowmass + mss_cnc_ocpho(j) = mss_ocpho(j) / snowmass + + mss_cnc_dst1(j) = mss_dst1(j) / snowmass + mss_cnc_dst2(j) = mss_dst2(j) / snowmass + mss_cnc_dst3(j) = mss_dst3(j) / snowmass + mss_cnc_dst4(j) = mss_dst4(j) / snowmass + + ELSE + ! 01/10/2023, yuan: set empty snow layers to snw_rds_min + snw_rds(j) = snw_rds_min + + mss_bcpho(j) = 0._r8 + mss_bcphi(j) = 0._r8 + mss_cnc_bcphi(j) = 0._r8 + mss_cnc_bcpho(j) = 0._r8 + + mss_ocpho(j) = 0._r8 + mss_ocphi(j) = 0._r8 + mss_cnc_ocphi(j) = 0._r8 + mss_cnc_ocpho(j) = 0._r8 + + mss_dst1(j) = 0._r8 + mss_dst2(j) = 0._r8 + mss_dst3(j) = 0._r8 + mss_dst4(j) = 0._r8 + mss_cnc_dst1(j) = 0._r8 + mss_cnc_dst2(j) = 0._r8 + mss_cnc_dst3(j) = 0._r8 + mss_cnc_dst4(j) = 0._r8 + ENDIF + ENDDO + + END SUBROUTINE AerosolMasses + + + + SUBROUTINE AerosolFluxes( dtime, snl, forc_aer, & + mss_bcphi ,mss_bcpho ,mss_ocphi ,mss_ocpho ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Compute aerosol fluxes through snowpack and aerosol deposition fluxes +! into top layer +! +!----------------------------------------------------------------------- + IMPLICIT NONE + ! + !----------------------------------------------------------------------- + ! !ARGUMENTS: + real(r8),intent(in) :: dtime ! seconds in a time step [second] + integer, intent(in) :: snl ! number of snow layers + + real(r8), intent(in) :: forc_aer (14 ) ! aerosol deposition from atmosphere [kg m-1 s-1] + + real(r8), intent(inout) :: mss_bcphi (maxsnl+1:0 ) ! hydrophillic BC mass in snow [kg] + real(r8), intent(inout) :: mss_bcpho (maxsnl+1:0 ) ! hydrophobic BC mass in snow [kg] + real(r8), intent(inout) :: mss_ocphi (maxsnl+1:0 ) ! hydrophillic OC mass in snow [kg] + real(r8), intent(inout) :: mss_ocpho (maxsnl+1:0 ) ! hydrophobic OC mass in snow [kg] + real(r8), intent(inout) :: mss_dst1 (maxsnl+1:0 ) ! mass of dust species 1 in snow [kg] + real(r8), intent(inout) :: mss_dst2 (maxsnl+1:0 ) ! mass of dust species 2 in snow [kg] + real(r8), intent(inout) :: mss_dst3 (maxsnl+1:0 ) ! mass of dust species 3 in snow [kg] + real(r8), intent(inout) :: mss_dst4 (maxsnl+1:0 ) ! mass of dust species 4 in snow [kg] + + ! !LOCAL VARIABLES: + real(r8) :: flx_bc_dep ! total BC deposition (col) [kg m-2 s-1] + real(r8) :: flx_bc_dep_phi ! hydrophillic BC deposition (col) [kg m-1 s-1] + real(r8) :: flx_bc_dep_pho ! hydrophobic BC deposition (col) [kg m-1 s-1] + real(r8) :: flx_oc_dep ! total OC deposition (col) [kg m-2 s-1] + real(r8) :: flx_oc_dep_phi ! hydrophillic OC deposition (col) [kg m-1 s-1] + real(r8) :: flx_oc_dep_pho ! hydrophobic OC deposition (col) [kg m-1 s-1] + real(r8) :: flx_dst_dep ! total dust deposition (col) [kg m-2 s-1] + + real(r8) :: flx_dst_dep_wet1 ! wet dust (species 1) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry1 ! dry dust (species 1) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_wet2 ! wet dust (species 2) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry2 ! dry dust (species 2) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_wet3 ! wet dust (species 3) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry3 ! dry dust (species 3) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_wet4 ! wet dust (species 4) deposition (col) [kg m-2 s-1] + real(r8) :: flx_dst_dep_dry4 ! dry dust (species 4) deposition (col) [kg m-2 s-1] + + integer :: c + + !----------------------------------------------------------------------- + ! set aerosol deposition fluxes from forcing array + ! The forcing array is either set from an external file + ! or from fluxes received from the atmosphere model +#ifdef MODAL_AER + ! Mapping for modal aerosol scheme where within-hydrometeor and + ! interstitial aerosol fluxes are differentiated. Here, "phi" + ! flavors of BC and OC correspond to within-hydrometeor + ! (cloud-borne) aerosol, and "pho" flavors are interstitial + ! aerosol. "wet" and "dry" fluxes of BC and OC specified here are + ! purely diagnostic + ! + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + + + flx_bc_dep_phi = forc_aer(3) + flx_bc_dep_pho = forc_aer(1) + forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(6) + flx_oc_dep_pho = forc_aer(4) + forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) +#else + + ! Original mapping for bulk aerosol deposition. phi and pho BC/OC + ! species are distinguished in model, other fluxes (e.g., dry and + ! wet BC/OC) are purely diagnostic. + + flx_bc_dep_phi = forc_aer(1) + forc_aer(3) + flx_bc_dep_pho = forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(4) + forc_aer(6) + flx_oc_dep_pho = forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) +#endif + + ! aerosol deposition fluxes into top layer + ! This is done after the inter-layer fluxes so that some aerosol + ! is in the top layer after deposition, and is not immediately + ! washed out before radiative calculations are done + + mss_bcphi(snl+1) = mss_bcphi(snl+1) + (flx_bc_dep_phi*dtime) + mss_bcpho(snl+1) = mss_bcpho(snl+1) + (flx_bc_dep_pho*dtime) + mss_ocphi(snl+1) = mss_ocphi(snl+1) + (flx_oc_dep_phi*dtime) + mss_ocpho(snl+1) = mss_ocpho(snl+1) + (flx_oc_dep_pho*dtime) + + mss_dst1(snl+1) = mss_dst1(snl+1) + (flx_dst_dep_dry1 + flx_dst_dep_wet1)*dtime + mss_dst2(snl+1) = mss_dst2(snl+1) + (flx_dst_dep_dry2 + flx_dst_dep_wet2)*dtime + mss_dst3(snl+1) = mss_dst3(snl+1) + (flx_dst_dep_dry3 + flx_dst_dep_wet3)*dtime + mss_dst4(snl+1) = mss_dst4(snl+1) + (flx_dst_dep_dry4 + flx_dst_dep_wet4)*dtime + + END SUBROUTINE AerosolFluxes + + + SUBROUTINE AerosolDepInit () + + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + IMPLICIT NONE + + real(r8), allocatable :: lat(:), lon(:) + + IF (DEF_Aerosol_Clim) THEN + ! climatology data + file_aerosol = trim(DEF_dir_runtime) // & + '/aerosol/aerosoldep_monthly_2000_mean_0.9x1.25_c090529.nc' + ELSE + ! yearly change data + file_aerosol = trim(DEF_dir_runtime) // & + '/aerosol/aerosoldep_monthly_1849-2001_0.9x1.25_c090529.nc' + ENDIF + + CALL ncio_read_bcast_serial (file_aerosol, 'lat', lat) + CALL ncio_read_bcast_serial (file_aerosol, 'lon', lon) + + CALL grid_aerosol%define_by_center (lat, lon) + + CALL allocate_block_data (grid_aerosol, f_aerdep) + + CALL mg2p_aerdep%build_arealweighted (grid_aerosol, landpatch) + + month_p = -1 + + END SUBROUTINE AerosolDepInit + + + SUBROUTINE AerosolDepReadin (idate) + + USE MOD_TimeManager + USE MOD_NetCDFBlock + USE MOD_Namelist + USE MOD_Vars_1DForcing +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + IMPLICIT NONE + + integer, intent(in) :: idate(3) + + integer :: itime, year, month, mday + + year = idate(1) + CALL julian2monthday (idate(1), idate(2), month, mday) + + ! data before the start year, will use the start year + IF (year < start_year) year = start_year + ! data after the end year, will use the end year + IF (year > end_year ) year = end_year + + IF (month.eq.month_p) RETURN + + month_p = month + + ! calculate itime + ! NOTE: aerosol deposition is monthly data + IF (DEF_Aerosol_Clim) THEN + ! for climatology data + itime = month + ELSE + ! for yearly change data + itime = (year-start_year)*12 + month + ENDIF + + ! BCPHIDRY , hydrophilic BC dry deposition + CALL ncio_read_block_time (file_aerosol, 'BCPHIDRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(1,:)) + + ! BCPHODRY , hydrophobic BC dry deposition + CALL ncio_read_block_time (file_aerosol, 'BCPHODRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(2,:)) + + ! BCDEPWET , hydrophilic BC wet deposition + CALL ncio_read_block_time (file_aerosol, 'BCDEPWET', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(3,:)) + + ! OCPHIDRY , hydrophilic OC dry deposition + CALL ncio_read_block_time (file_aerosol, 'OCPHIDRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(4,:)) + + ! OCPHODRY , hydrophobic OC dry deposition + CALL ncio_read_block_time (file_aerosol, 'OCPHODRY', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(5,:)) + + ! OCDEPWET , hydrophilic OC wet deposition + CALL ncio_read_block_time (file_aerosol, 'OCDEPWET', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(6,:)) + + ! DSTX01WD , DSTX01 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX01WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(7,:)) + + ! DSTX01DD , DSTX01 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX01DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(8,:)) + + ! DSTX02WD , DSTX02 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX02WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(9,:)) + + ! DSTX02DD , DSTX02 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX02DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(10,:)) + + ! DSTX03WD , DSTX03 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX03WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(11,:)) + + ! DSTX03DD , DSTX03 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX03DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(12,:)) + + ! DSTX04WD , DSTX04 wet deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX04WD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(13,:)) + + ! DSTX04DD , DSTX04 dry deposition flux at bottom + CALL ncio_read_block_time (file_aerosol, 'DSTX04DD', grid_aerosol, itime, f_aerdep) + CALL mg2p_aerdep%grid2pset (f_aerdep, forc_aerdep(14,:)) + +#ifdef RangeCheck + !CALL check_block_data ('aerosol', f_aerdep) + CALL check_vector_data (' aerosol [kg/m/s]', forc_aerdep) +#endif + + + END SUBROUTINE AerosolDepReadin + +END MODULE MOD_Aerosol diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo.F90 new file mode 100644 index 0000000000..fd5dd381ec --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo.F90 @@ -0,0 +1,2079 @@ +#include + +MODULE MOD_Albedo + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: albland + PUBLIC :: snowage + PUBLIC :: SnowAlbedo + PUBLIC :: albocean + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: twostream +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + PRIVATE :: twostream_mod + PRIVATE :: twostream_wrap +#endif + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE albland (ipatch,patchtype,deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno,dz_soisno,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd) + +!======================================================================= +! Calculates fragmented albedos (direct and diffuse) in +! wavelength regions split at 0.7um. +! +! (1) soil albedos: as in BATS formulations, which are the function of +! soil color and moisture in the surface soil layer +! (2) snow albedos: as in BATS formulations, which are inferred from +! the calculations of Wiscombe and Warren (1980) and the snow model +! and data of Anderson(1976), and the function of snow age, grain +! size, solar zenith angle, pollution, the amount of the fresh snow +! (3) canopy albedo: two-stream approximation model +! (4) glacier albedos: as in BATS, which are set to constants (0.8 for +! visible beam, 0.55 for near-infrared) +! (5) lake and wetland albedos: as in BATS, which depend on cosine solar +! zenith angle, based on data in Henderson-Sellers (1986). The +! frozen lake and wetland albedos are set to constants (0.6 for +! visible beam, 0.4 for near-infrared) +! (6) over the snow covered tile, the surface albedo is estimated by a +! linear combination of albedos for snow, canopy and bare soil (or +! lake, wetland, glacier). +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002, 03/2014 +! +! !REVISIONS: +! 12/2019, Hua Yuan: added a wrap FUNCTION for PFT calculation, details +! see twostream_wrap() added a wrap FUNCTION for PC (3D) +! calculation, details see ThreeDCanopy_wrap() +! +! 03/2020, Hua Yuan: added an improved two-stream model, details see +! twostream_mod() +! +! 08/2020, Hua Yuan: account for stem optical property effects in +! twostream model +! +! 01/2023, Hua Yuan: CALL SNICAR model to calculate snow +! albedo&absorption, added SNICAR related variables +! +! 04/2024, Hua Yuan: add option to account for vegetation snow process +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_Vars_TimeInvariants, only: patchclass +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif + USE MOD_Aerosol, only: AerosolMasses + USE MOD_SnowSnicar, only: SnowAge_grain +#ifdef LULC_IGBP_PC + USE MOD_3DCanopyRadiation, only: ThreeDCanopy_wrap +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- +! ground cover index + integer, intent(in) :: & + ipatch, &! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=water body) + integer, intent(in) :: & + snl ! number of snow layers + + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + soil_s_v_alb, &! albedo of visible of the saturated soil + soil_d_v_alb, &! albedo of visible of the dry soil + soil_s_n_alb, &! albedo of near infrared of the saturated soil + soil_d_n_alb, &! albedo of near infrared of the dry soil + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + fveg, &! fractional vegetation cover [-] + green, &! green leaf fraction + lai, &! leaf area index (LAI+SAI) [m2/m2] + sai, &! stem area index (LAI+SAI) [m2/m2] + fwet_snow, &! vegetation snow fractional cover [-] + + coszen, &! cosine of solar zenith angle [-] + wt, &! fraction of vegetation covered by snow [-] + fsno, &! fraction of soil covered by snow [-] + ssw, &! water volumetric content of soil surface layer [m3/m3] + scv, &! snow cover, water equivalent [mm] + scvold, &! snow cover for previous time step [mm] + pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] + forc_t, &! atmospheric temperature [K] + t_grnd ! ground surface temperature [K] + + real(r8), intent(in) :: & + wliq_soisno ( maxsnl+1:0 ), &! liquid water (kg/m2) + wice_soisno ( maxsnl+1:0 ), &! ice lens (kg/m2) + snofrz ( maxsnl+1:0 ), &! snow freezing rate (col,lyr) [kg m-2 s-1] + t_soisno ( maxsnl+1:1 ), &! soil + snow layer temperature [K] + dz_soisno ( maxsnl+1:1 ) ! layer thickness (m) + + real(r8), intent(inout) :: & + snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] + mss_bcpho ( maxsnl+1:0 ), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi ( maxsnl+1:0 ), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho ( maxsnl+1:0 ), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi ( maxsnl+1:0 ), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 ( maxsnl+1:0 ), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 ( maxsnl+1:0 ), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 ( maxsnl+1:0 ), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] + + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + + real(r8), intent(out) :: & + alb(2,2), &! averaged albedo [-] + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2), &! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd ! diffuse and scattered diffuse PAR extinction coefficient + + real(r8), intent(out) :: & + ssoi(2,2), &! ground soil absorption [-] + ssno(2,2), &! ground snow absorption [-] + ssno_lyr(2,2,maxsnl+1:1) ! ground snow layer absorption, by SNICAR [-] + +!-------------------------- Local Variables ---------------------------- + + real(r8) :: &! + age, &! factor to reduce visible snow alb due to snow age [-] + albg0, &! temporary variable [-] + albsoi(2,2), &! soil albedo [-] + albsno(2,2), &! snow albedo [-] + albsno_pur(2,2), &! snow albedo [-] + albsno_bc (2,2), &! snow albedo [-] + albsno_oc (2,2), &! snow albedo [-] + albsno_dst(2,2), &! snow albedo [-] + albg(2,2), &! albedo, ground + albv(2,2), &! albedo, vegetation [-] + alb_s_inc, &! decrease in soil albedo due to wetness [-] + beta0, &! upscattering parameter for direct beam [-] + cff, &! snow alb correction factor for zenith angle > 60 [-] + conn, &! constant (=0.5) for visible snow alb calculation [-] + cons, &! constant (=0.2) for nir snow albedo calculation [-] + czen, &! cosine of solar zenith angle > 0 [-] + czf, &! solar zenith correction for new snow albedo [-] + dfalbl, &! snow albedo for diffuse nir radiation [-] + dfalbs, &! snow albedo for diffuse vis radiation [-] + dralbl, &! snow albedo for direct nir radiation [-] + dralbs, &! snow albedo for direct vis radiation [-] + lsai, &! leaf and stem area index (LAI+SAI) [m2/m2] + sl, &! factor that helps control alb zenith dependence [-] + snal0, &! alb for visible,incident on new snow (zen ang<60) [-] + snal1, &! alb for NIR, incident on new snow (zen angle<60) [-] + upscat, &! upward scattered fraction for direct beam [-] + tran(2,3) ! canopy transmittances for solar radiation + + integer ps, pe + logical do_capsnow !true => DO snow capping + logical use_snicar_frc !true: IF radiative forcing is calculated, + !first estimate clean-snow albedo + logical use_snicar_ad !true: use SNICAR_AD_RT, false: use SNICAR_RT + + real(r8) snwcp_ice !excess precipitation due to snow capping [kg m-2 s-1] + real(r8) mss_cnc_bcphi ( maxsnl+1:0 ) !mass concentration of hydrophilic BC [kg/kg] + real(r8) mss_cnc_bcpho ( maxsnl+1:0 ) !mass concentration of hydrophobic BC [kg/kg] + real(r8) mss_cnc_ocphi ( maxsnl+1:0 ) !mass concentration of hydrophilic OC [kg/kg] + real(r8) mss_cnc_ocpho ( maxsnl+1:0 ) !mass concentration of hydrophobic OC [kg/kg] + real(r8) mss_cnc_dst1 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 1 [kg/kg] + real(r8) mss_cnc_dst2 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 2 [kg/kg] + real(r8) mss_cnc_dst3 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 3 [kg/kg] + real(r8) mss_cnc_dst4 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 4 [kg/kg] + +! ---------------------------------------------------------------------- +! 1. Initial set +! ---------------------------------------------------------------------- + +! visible and near infrared band albedo for new snow + snal0 = 0.85 !visible band + snal1 = 0.65 !near infrared + +! ---------------------------------------------------------------------- +! set default soil and vegetation albedos and solar absorption + alb (:,:) = 1. !averaged + albg(:,:) = 1. !ground + albv(:,:) = 1. !vegetation + ssun(:,:) = 0. !sunlit leaf absorption + ssha(:,:) = 0. !shaded leaf absorption + tran(:,1) = 0. !incident direct radiation diffuse transmittance + tran(:,2) = 1. !incident diffuse radiation diffuse transmittance + tran(:,3) = 1. !incident direct radiation direct transmittance + + ! 07/06/2023, yuan: use the values of previous timestep + ! for nighttime longwave calculations. + !thermk = 1.e-3 + IF (lai+sai <= 1.e-6) THEN + thermk = 1. + ENDIF + extkb = 1. + extkd = 0.718 + + albsno (:,:) = 1. !set initial snow albedo + albsno_pur(:,:) = 1. !set initial pure snow albedo + albsno_bc (:,:) = 1. !set initial BC snow albedo + albsno_oc (:,:) = 1. !set initial OC snow albedo + albsno_dst(:,:) = 1. !set initial dust snow albedo + + ! soil and snow absorption + ssoi (:,:) = 0. !set initial soil absorption + ssno (:,:) = 0. !set initial snow absorption + ssno_lyr(:,:,:) = 0. !set initial snow layer absorption + +IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + ssun_p(:,:,ps:pe) = 0. + ssha_p(:,:,ps:pe) = 0. + ! 07/06/2023, yuan: use the values of previous timestep. + !thermk_p(ps:pe) = 1.e-3 + WHERE (lai_p(ps:pe)+sai_p(ps:pe) <= 1.e-6) thermk_p(ps:pe) = 1. + extkb_p(ps:pe) = 1. + extkd_p(ps:pe) = 0.718 +#endif +ENDIF + +! ---------------------------------------------------------------------- +! Calculate column-integrated aerosol masses, and +! mass concentrations for radiative calculations and output +! (based on new snow level state, after SnowFilter is rebuilt. +! NEEDS TO BE AFTER SnowFiler is rebuilt, otherwise there +! can be zero snow layers but an active column in filter) +IF (DEF_USE_SNICAR) THEN + snwcp_ice = 0.0 !excess precipitation due to snow capping [kg m-2 s-1] + do_capsnow = .false. !true => DO snow capping + + CALL AerosolMasses( deltim, snl ,do_capsnow ,& + wice_soisno(:0),wliq_soisno(:0),snwcp_ice ,snw_rds ,& + + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) + +! ---------------------------------------------------------------------- +! Snow aging routine based on Flanner and Zender (2006), Linking snowpack +! microphysics and albedo evolution, JGR, and Brun (1989), Investigation of +! wet-snow metamorphism in respect of liquid-water content, Ann. Glacial. + + CALL SnowAge_grain( deltim ,snl ,dz_soisno(:1) ,& + pg_snow ,snwcp_ice ,snofrz ,& + + do_capsnow ,fsno ,scv ,& + wliq_soisno(:0),wice_soisno(:0),t_soisno(:1) ,& + t_grnd ,forc_t ,snw_rds ) +ENDIF +! ---------------------------------------------------------------------- + + lsai = lai + sai + IF(coszen <= -0.3) THEN + RETURN !only DO albedo when coszen > -0.3 + ENDIF + + czen = max(coszen, 0.001) + +! ---------------------------------------------------------------------- +! 2. get albedo over land +! ---------------------------------------------------------------------- +! 2.1 soil albedos, depends on moisture + IF (patchtype <= 2) THEN !soil, urban and wetland + alb_s_inc = max(0.11-0.40*ssw, 0.) + albg(1,1) = min(soil_s_v_alb + alb_s_inc, soil_d_v_alb) + albg(2,1) = min(soil_s_n_alb + alb_s_inc, soil_d_n_alb) + albg(:,2) = albg(:,1) !diffused albedos setting + +! 2.2 albedos for permanent ice sheet. + ELSEIF (patchtype == 3) THEN !permanent ice sheet + albg(1,:) = 0.8 + albg(2,:) = 0.55 + +! 2.3 albedo for inland water + ELSEIF (patchtype >= 4) THEN + albg0 = 0.05/(czen+0.15) + albg(:,1) = albg0 + albg(:,2) = 0.1 !Subin (2012) + + IF(t_grnd < tfrz)THEN !frozen lake and wetland + albg(1,:) = 0.6 + albg(2,:) = 0.4 + ENDIF + ENDIF + + ! SAVE soil ground albedo + albsoi(:,:) = albg(:,:) + +! ---------------------------------------------------------------------- +! 3. albedo for snow cover. +! - Scheme 1: snow albedo depends on snow-age, zenith angle, and thickness +! of snow age gives reduction of visible radiation [CoLM2014]. +! - Scheme 2: SNICAR model +! ---------------------------------------------------------------------- + IF (scv > 0.) THEN + + IF (.not. DEF_USE_SNICAR) THEN + cons = 0.2 + conn = 0.5 + sl = 2.0 !sl helps control albedo zenith dependence + + ! 05/02/2023, Dai: move from CoLMMAIN.F90 + ! update the snow age + IF (snl == 0) sag=0. + CALL snowage (deltim,t_grnd,scv,scvold,sag) + + ! correction for snow age + age = 1.-1./(1.+sag) + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ELSE + + ! 01/09/2023, yuan: CALL SNICAR for snow albedo + use_snicar_frc = .false. ! true: IF radiative forcing is being calculated, + ! first estimate clean-snow albedo + use_snicar_ad = .true. ! use true: use SNICAR_AD_RT, false: use SNICAR_RT + + CALL SnowAlbedo( use_snicar_frc ,use_snicar_ad ,czen ,& + albg(:,1) ,albg(:,2) ,snl ,fsno ,& + scv ,wliq_soisno ,wice_soisno ,snw_rds ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ,& + + albsno (:,1),albsno (:,2),albsno_pur(:,1),albsno_pur(:,2),& + albsno_bc (:,1),albsno_bc (:,2),albsno_oc (:,1),albsno_oc (:,2),& + albsno_dst(:,1),albsno_dst(:,2),ssno_lyr(1,1,:),ssno_lyr(2,1,:),& + ssno_lyr(1,2,:),ssno_lyr(2,2,:)) + + ! IF no snow layer exist + IF (snl == 0) THEN + ssno_lyr(:,:,1) = ssno_lyr(:,:,1) + ssno_lyr(:,:,0) + ssno_lyr(:,:,0) = 0. + ENDIF + ENDIF + ENDIF + +! 3.1 correction due to snow cover + albg(:,:) = (1.-fsno)*albg(:,:) + fsno*albsno(:,:) + alb (:,:) = albg(:,:) + +! ---------------------------------------------------------------------- +! 4. canopy albedos: two stream approximation or 3D canopy radiation transfer +! ---------------------------------------------------------------------- + IF (lai+sai > 1e-6 .and. patchtype < 3) THEN + + ! initialization + albv(:,:) = albg(:,:) + + IF (patchtype == 0) THEN !soil patches + +#if (defined LULC_USGS || defined LULC_IGBP) + CALL twostream (chil,rho,tau,green,lai,sai,fwet_snow,& + czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) + + ! 08/31/2023, yuan: to be consistent with PFT and PC + alb(:,:) = albv(:,:) +#endif + ELSE !other patchtypes (/=0) + CALL twostream (chil,rho,tau,green,lai,sai,fwet_snow,& + czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) + + ! 08/31/2023, yuan: to be consistent with PFT and PC + alb(:,:) = albv(:,:) + + ENDIF + ENDIF + + + IF (patchtype == 0) THEN +#ifdef LULC_IGBP_PFT + CALL twostream_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + alb(:,:) = albv(:,:) +#endif + +#ifdef LULC_IGBP_PC + ! Only process nature PFTs using 3D model if set DEF_PC_CROP_SPLIT true + CALL ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + + ! Process crop PFTs using 1D model if set DEF_PC_CROP_SPLIT true + CALL twostream_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + + alb(:,:) = albv(:,:) +#endif + ENDIF + + ! treat soil/snow absorption in direct and diffuse respectively + ssoi(1,1) = tran(1,1)*(1.-albsoi(1,2)) + tran(1,3)*(1-albsoi(1,1)) + ssoi(2,1) = tran(2,1)*(1.-albsoi(2,2)) + tran(2,3)*(1-albsoi(2,1)) + ssoi(1,2) = tran(1,2)*(1.-albsoi(1,2)) + ssoi(2,2) = tran(2,2)*(1.-albsoi(2,2)) + + ssno(1,1) = tran(1,1)*(1.-albsno(1,2)) + tran(1,3)*(1-albsno(1,1)) + ssno(2,1) = tran(2,1)*(1.-albsno(2,2)) + tran(2,3)*(1-albsno(2,1)) + ssno(1,2) = tran(1,2)*(1.-albsno(1,2)) + ssno(2,2) = tran(2,2)*(1.-albsno(2,2)) + +!----------------------------------------------------------------------- + + END SUBROUTINE albland + + + SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! calculation of canopy albedos via two stream approximation (direct +! and diffuse ) and partition of incident solar +! +! Original author: Yongjiu Dai, June 11, 2001 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(2,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + lsai, &! lai+sai + sai_, &! sai=0 for USGS, no stem + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup(2,2), &! (integral of i_up*exp(-kx) ) + edown(2,2) ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band iterator + +!----------------------------------------------------------------------- +! projected area of photo elements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + proj = phi1 + phi2 * coszen + extkb = proj / coszen + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSEIF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSEIF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + +#if (defined LULC_USGS) + ! yuan: to be consistent with CoLM2014, no stem considered + ! for twostream and leaf optical property calculations + sai_ = 0. +#else + sai_ = sai +#endif + + lsai = lai + sai_ + power3 = (lai+sai) / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + IF (lsai <= 1e-6) RETURN + + DO iw = 1, 2 ! WAVE_BAND_LOOP + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! account for stem optical property effects + scat = lai/lsai * ( tau(iw,1) + rho(iw,1) ) & + + sai_/lsai * ( tau(iw,2) + rho(iw,2) ) + + as = scat / 2. * proj / ( proj + coszen * phi2 ) + as = as * ( 1. - coszen * phi1 / ( proj + coszen * phi2 ) * & + log ( ( proj + coszen * phi2 + coszen * phi1 ) / ( coszen * phi1 ) ) ) + +! account for stem optical property effects + upscat = lai/lsai*tau(iw,1) + sai_/lsai*tau(iw,2) + ! 09/12/2014, yuan: a bug, change 1. - chil -> 1. + chil + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albg(iw,2)*p1/ce + f2 = 1. - albg(iw,2)*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albg(iw,1) - ( hh1 - albg(iw,2) * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = hh1 + hh2 + hh3 + tran(iw,1) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup(iw,1) = hh1 * (1. - s2*s2) / (2.*extkb) & + + hh2 * (1. - s1*s2) / (extkb + psi) & + + hh3 * (1. - s2/s1) / (extkb - psi) + + edown(iw,1) = hh4 * (1. - s2*s2) / (2.*extkb) & + + hh5 * (1. - s1*s2) / (extkb + psi) & + + hh6 * (1. - s2/s1) / (extkb - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (2.*extkb) ) * s2 & + + albg(iw,2) / ce * ( - h1 / (2.*extkb) / zmu2 * & + ( p3*lsai + p4 / (2.*extkb) ) - de ) * s2 & + + albg(iw,1) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / (4.*extkb*extkb) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = - h1 / (2.*extkb*zmu2) + hh2 + hh3 + tran(iw,1) = 1./ce * ( -h1/(2.*extkb*zmu2) * (p3*lsai + p4/(2.*extkb)) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup(iw,1) = (hh2 - h1/(2.*extkb*zmu2)) * (1. - s2*s2) / (2.*extkb) & + + hh3 * (lsai - 0.) & + + h1/(2.*extkb*zmu2) * ( lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + edown(iw,1) = (hh5 - (h1*p4/(4.*extkb*extkb*zmu) + de)/ce) * (1. - s2*s2)/(2.*extkb) & + + hh6 * (lsai - 0.) & + + h1*p3/(ce*4.*extkb*extkb*zmu2) * (lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + ENDIF + + ssun(iw,1) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup(iw,1) + edown(iw,1)) ) + ssha(iw,1) = scat * (1.-s2) & + + ( albg(iw,2)*tran(iw,1) + albg(iw,1)*s2 - tran(iw,1) ) - albv(iw,1) & + - ( 1. - scat ) / zmu * ( eup(iw,1) + edown(iw,1) ) + +!----------------------------------------------------------------------- +! calculation of diffuse albedos and canopy transmittances +! albv(iw,2) ( i-up ) +! tran(iw,2) ( i-down ) +!----------------------------------------------------------------------- + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = 0. + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1. + + hh7 = -m2 / (m1*n2 - m2*n1) + hh8 = -m1 / (m2*n1 - m1*n2) + + hh9 = hh7 * p1 / ce + hh10 = hh8 * p2 / ce + + albv(iw,2) = hh7 + hh8 + tran(iw,2) = hh9 * s1 + hh10 / s1 + + IF (abs(sigma) .gt. 1.e-10) THEN + eup(iw,2) = hh7 * (1. - s1*s2) / (extkb + psi) & + + hh8 * (1. - s2/s1) / (extkb - psi) + edown(iw,2) = hh9 * (1. - s1*s2) / (extkb + psi) & + + hh10 * (1. - s2/s1) / (extkb - psi) + ELSE + eup(iw,2) = hh7 * (1. - s1*s2) / ( extkb + psi) + hh8 * (lsai - 0.) + edown(iw,2) = hh9 * (1. - s1*s2) / ( extkb + psi) + hh10 * (lsai - 0.) + ENDIF + + ssun(iw,2) = (1.-scat) / zmu * (eup(iw,2) + edown(iw,2)) + ssha(iw,2) = tran(iw,2) * ( albg(iw,2) -1. ) - ( albv(iw,2) - 1. ) & + - ( 1. - scat ) / zmu * ( eup(iw,2) + edown(iw,2) ) + + ENDDO ! WAVE_BAND_LOOP + + ! 03/06/2020, yuan: add direct transmittance (s2) to + ! tran for incident direct case + ! 03/14/2020, yuan: save direct T to 3rd position of tran + tran(:,3) = s2 + + END SUBROUTINE twostream + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! An improved two stream approximation +! +! Original author: Yongjiu Dai, June 11, 2001 +! Hua Yuan, 03/2020 +! +! !REFERENCES: +! 1) Yuan, H., Dai, Y., Dickinson, R. E., Pinty, B., Shangguan, W., +! Zhang, S., et al. (2017). Reexamination and further development of +! two-stream canopy radiative transfer models for global land modeling. +! Journal of Advances in Modeling Earth Systems, 9(1), 113-129. +! https://doi.org/10.1002/2016MS000773 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! cosine of solar zenith angle + albg(2,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + lsai, &! lai+sai + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup, &! (integral of i_up*exp(-kx) ) + edw ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscatter parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band loop index + integer ic ! direct/diffuse loop index + + ! variables for modified version + real(r8) :: cosz, theta, cosdif, albgblk + real(r8) :: tmptau, wrho, wtau + real(r8) :: s2d, extkbd, sall(2,2), q, ssun_rev + +!----------------------------------------------------------------------- +! projected area of photo elements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSEIF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSEIF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + + lsai = lai + sai + power3 = lsai / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + tmptau = 0.5_r8 * lsai + cosdif = - tmptau / log(exp(-0.87_r8*tmptau) / (1+0.92_r8*tmptau)) + + ! black ground case + albgblk = 1.e-6_r8 + + DO iw = 1, 2 ! WAVE_BAND_LOOP + + ! ic 1: incident direct; 2: incident diffuse + DO ic = 1, 2 + + IF (ic == 2) THEN + cosz = max(0.001_r8, cosdif) + theta = acos(cosz) + theta = theta/3.14159*180 + + theta = theta + chil*5._r8 + cosz = cos(theta/180*3.14159) + ELSE + cosz = coszen + ENDIF + + proj = phi1 + phi2 * cosz + extkb = proj / cosz + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! + stem optical properties + wtau = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + wrho = lai/lsai*rho(iw,1) + sai/lsai*rho(iw,2) + + scat = wtau + wrho + + as = scat / 2. * proj / ( proj + cosz * phi2 ) + as = as * ( 1. - cosz * phi1 / ( proj + cosz * phi2 ) * & + log ( ( proj + cosz * phi2 + cosz * phi1 ) / ( cosz * phi1 ) ) ) + +! + stem optical properties + ! scat ~ omega + ! upscat ~ betail*scat + ! beta0 ~ betadl + ! scat-2.*upscat ~ rho - tau + upscat = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + + ! [MODI 1] + beta0 = 0.5_r8 * ( scat + 1._r8/extkb*(1._r8+chil)**2/4._r8*(wrho-wtau) )/scat + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albgblk*p1/ce + f2 = 1. - albgblk*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (ic == 1) THEN + s2d = s2 + extkbd = extkb + ENDIF + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albgblk - ( hh1 - albgblk * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = hh1 + hh2 + hh3 + tran(iw,ic) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup = hh1 * (1. - s2*s2d) / (extkbd + extkb) & + + hh2 * (1. - s2d*s1) / (extkbd + psi) & + + hh3 * (1. - s2d/s1) / (extkbd - psi) + + edw = hh4 * (1. - s2*s2d) / (extkbd + extkb) & + + hh5 * (1. - s2d*s1) / (extkbd + psi) & + + hh6 * (1. - s2d/s1) / (extkbd - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (extkb+extkbd) ) * s2 & + + albgblk / ce * ( - h1 / (extkb+extkbd) / zmu2 * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + albgblk * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / ((extkb+extkbd)*(extkb+extkbd)) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = - h1 / ((extkb+extkbd)*zmu2) + hh2 + hh3 + tran(iw,ic) = 1./ce * ( -h1 / ((extkb+extkbd)*zmu2) * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup = (hh2 - h1/((extkb+extkbd)*zmu2)) * (1. - s2*s2d)/(extkb+extkbd) & + + hh3 * (lsai - 0.) & + + h1/((extkb+extkbd)*zmu2) * ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + edw = (hh5 - (h1*p4/((extkb+extkbd)*(extkb+extkbd)*zmu) + de)/ce) * & + (1. - s2*s2d) / (extkb+extkbd) + hh6 * (lsai - 0.) & + + h1*p3/(ce*(extkb+extkbd)*(extkb+extkbd)*zmu2) * & + ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + ENDIF + + sall(iw,ic) = 1. - albv(iw,ic) - (1.-albgblk)*(tran(iw,ic)+s2) + + IF (ic == 1) THEN + ssun(iw,ic) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup + edw) ) + ELSE + ssun(iw,ic) = (1.-scat) * ( extkb*(1.-s2*s2d)/(extkb+extkbd) + 1. / zmu * (eup + edw) ) + ENDIF + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ENDDO ! ic + + ! for reversed diffuse radiation back from ground + eup = hh1 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh2 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh3 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + edw = hh4 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh5 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh6 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + ssun_rev = s2d * (1._r8 - scat) * & + ( extkb*(1._r8-s2/s2d)/(extkb-extkbd) + 1._r8 / zmu * (eup + edw ) ) + + ! ----------------------------------------------------------- + ! consider the multiple reflectance between canopy and ground + ! ----------------------------------------------------------- + + ! common ratio for geometric series + q = albg(iw,2) * albv(iw,2) + + DO ic = 1, 2 ! from 1 to 2, cannot be reversed + + ! ----------------------------------------------------------- + ! re-calculate the absorption, transmission and albedo + ! for direct radiation + + ! 03/06/2020, yuan: tran originally meant diffuse flow, now the direct + ! transmittance is also included + ! 03/14/2020, yuan: treat soil albedo in direct/diffuse cases + IF (ic == 1) THEN + tran(iw,ic) = (s2d*albg(iw,1)*albv(iw,2) + tran(iw,ic)) / (1.-q) + tran(:,3) = s2d + + sall(iw,ic) = sall(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * sall(iw,2) + + albv(iw,ic) = 1. - sall(iw,ic) - & + (1.-albg(iw,2))*tran(iw,ic) - (1.-albg(iw,1))*s2d + + ssun(iw,ic) = ssun(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * ssun_rev + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ELSE + tran(iw,ic) = (s2 + tran(iw,ic)) / (1.-q) + + sall(iw,ic) = sall(iw,ic) + tran(iw,ic)*albg(iw,2)*sall(iw,2) + albv(iw,ic) = 1. - sall(iw,ic) - (1.-albg(iw,2))*tran(iw,ic) + + ssun(iw,ic) = ssun(iw,ic) + tran(iw,ic)*albg(iw,2)*ssun_rev + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + ENDIF + + ENDDO !ic + + ENDDO !iw + + ! restore extkb + extkb = extkbd + + END SUBROUTINE twostream_mod +#endif + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & + albv, tran, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! A Wrap subroutine to calculate PFT radiation using two-stream model +! +! Created by Hua Yuan, 03/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Const_PFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Namelist, only: DEF_USE_PC, DEF_PC_CROP_SPLIT + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ! patch index + + ! environmental variables + real(r8), intent(in) :: & + coszen, &! cosine of solar zenith angle + albg(2,2) ! albedos of ground + + ! output + real(r8), intent(inout) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- Local Variables ---------------------------- + integer :: i, p, ps, pe + real(r8), allocatable :: tran_p(:,:,:) + real(r8), allocatable :: albv_p(:,:,:) + +!----------------------------------------------------------------------- + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + allocate ( tran_p (2,3,ps:pe) ) + allocate ( albv_p (2,2,ps:pe) ) + + DO i = ps, pe + p = pftclass(i) + + ! If defined DEF_PC_CROP_SPLIT, for crop PFTs, use 1D twostream model; + ! Otherwise, set their value to PC 3D model results. + IF ( DEF_USE_PC .and. (.not.DEF_PC_CROP_SPLIT .or. p.lt.15) ) THEN + albv_p(:,:,i) = albv(:,:) + tran_p(:,:,i) = tran(:,:) + CYCLE + ENDIF + + IF (lai_p(i)+sai_p(i) > 1.e-6) THEN + CALL twostream_mod (chil_p(p),rho_p(:,:,p),tau_p(:,:,p),1.,lai_p(i),sai_p(i),& + fwet_snow_p(i),coszen,albg,albv_p(:,:,i),tran_p(:,:,i),thermk_p(i),& + extkb_p(i),extkd_p(i),ssun_p(:,:,i),ssha_p(:,:,i)) + ELSE + albv_p(:,:,i) = albg(:,:) + ssun_p(:,:,i) = 0. + ssha_p(:,:,i) = 0. + tran_p(:,1,i) = 0. + tran_p(:,2,i) = 1. + tran_p(:,3,i) = 1. + ENDIF + ENDDO + + albv(1,1) = sum( albv_p(1,1,ps:pe)*pftfrac(ps:pe) ) + albv(1,2) = sum( albv_p(1,2,ps:pe)*pftfrac(ps:pe) ) + albv(2,1) = sum( albv_p(2,1,ps:pe)*pftfrac(ps:pe) ) + albv(2,2) = sum( albv_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssun(1,1) = sum( ssun_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + tran(1,1) = sum( tran_p(1,1,ps:pe)*pftfrac(ps:pe) ) + tran(1,2) = sum( tran_p(1,2,ps:pe)*pftfrac(ps:pe) ) + tran(1,3) = sum( tran_p(1,3,ps:pe)*pftfrac(ps:pe) ) + tran(2,1) = sum( tran_p(2,1,ps:pe)*pftfrac(ps:pe) ) + tran(2,2) = sum( tran_p(2,2,ps:pe)*pftfrac(ps:pe) ) + tran(2,3) = sum( tran_p(2,3,ps:pe)*pftfrac(ps:pe) ) + + IF (ssun(1,1)<0 .or. ssun(1,2)<0 .or. ssun(2,1)<0 .or. ssun(2,2)<0) THEN + print *, 'Warning: negative ssun in albedo calculation!',ipatch + print *, ssun + ENDIF + + deallocate ( tran_p ) + deallocate ( albv_p ) + + END SUBROUTINE twostream_wrap +#endif + + + SUBROUTINE snowage ( deltim,tg,scv,scvold,sag ) + +!======================================================================= +! Original version: Robert Dickinson +! Update snow cover and snow age, based on BATS code +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: deltim ! seconds in a time step [second] + real(r8), intent(in) :: tg ! temperature of soil at surface [K] + real(r8), intent(in) :: scv ! snow cover, water equivalent [mm] + real(r8), intent(in) :: scvold ! snow cover for previous time step [mm] + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + +!-------------------------- Local Variables ---------------------------- + + real(r8) :: age1 ! snow aging factor due to crystal growth [-] + real(r8) :: age2 ! snow aging factor due to surface growth [-] + real(r8) :: age3 ! snow aging factor due to accum of other particles [-] + real(r8) :: arg ! temporary variable used in snow age calculation [-] + real(r8) :: arg2 ! temporary variable used in snow age calculation [-] + real(r8) :: dela ! temporary variable used in snow age calculation [-] + real(r8) :: dels ! temporary variable used in snow age calculation [-] + real(r8) :: sge ! temporary variable used in snow age calculation [-] + +!----------------------------------------------------------------------- + IF(scv <= 0.) THEN + sag = 0. +! +! Over Antarctica +! + ELSEIF (scv > 800.) THEN + sag = 0. +! +! Away from Antarctica +! + ELSE + age3 = 0.3 + arg = 5.e3*(1./tfrz-1./tg) + arg2 = min(0.,10.*arg) + age2 = exp(arg2) + age1 = exp(arg) + dela = 1.e-6*deltim*(age1+age2+age3) + dels = 0.1*max(0.0,scv-scvold) + sge = (sag+dela)*(1.0-dels) + sag = max(0.0,sge) + ENDIF + + END SUBROUTINE snowage + + + SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& + albsod ,albsoi ,snl ,frac_sno ,& + h2osno ,h2osno_liq ,h2osno_ice ,snw_rds ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ,& + + albgrd ,albgri ,albgrd_pur ,albgri_pur ,& + albgrd_bc ,albgri_bc ,albgrd_oc ,albgri_oc ,& + albgrd_dst ,albgri_dst ,flx_absdv ,flx_absdn ,& + flx_absiv ,flx_absin ) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! The calling sequence is: +! -> SNICAR_RT: snow albedos: direct beam (SNICAR) +! or +! SNICAR_AD_RT: snow albedos: direct beam (SNICAR-AD) +! -> SNICAR_RT: snow albedos: diffuse (SNICAR) +! or +! SNICAR_AD_RT: snow albedos: diffuse (SNICAR-AD) +! +! !ORIGINAL: +! 1) The Community Land Model version5.0 (CLM5.0) +! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land Model (ELM v2.0) +! +! !REFERENCES: +! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling spectral snow albedo. +! Geosci. Model Dev., 14, 7673-7704, https://doi.org/10.5194/gmd-14-7673-2021 +! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land model (version 2.0) +! and assessing its impacts on snow and surface fluxes over the Tibetan Plateau. +! Geosci. Model Dev., 16, 75-94, https://doi.org/10.5194/gmd-16-75-2023 +! +! !REVISIONS: +! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Vars_Global, only: maxsnl + USE MOD_SnowSnicar, only: SNICAR_RT, SNICAR_AD_RT + + ! and the evolution of snow effective radius + ! + ! DAI, Dec. 28, 2022 + + IMPLICIT NONE + +!------------------------------------------------------------------------- +! temporary setting + + integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir + integer, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + logical, parameter :: DO_SNO_OC = .true. ! to include organic carbon (OC) + logical, parameter :: DO_SNO_AER = .true. ! to include aerosols in snow radiative calculations + integer, parameter :: subgridflag = 1 ! = 0 USE subgrid fluxes, = 1 not USE subgrid fluxes + ! + ! !ARGUMENTS: + ! + logical , intent(in) :: use_snicar_frc ! true: IF radiative forcing is being calculated, + ! first estimate clean-snow albedo + logical , intent(in) :: use_snicar_ad ! true: USE SNICAR_AD_RT, false: USE SNICAR_RT + + real(r8), intent(in) :: coszen_col ! cosine of solar zenith angle + real(r8), intent(in) :: albsod ( numrad ) ! direct-beam soil albedo (col,bnd) [frc] + real(r8), intent(in) :: albsoi ( numrad ) ! diffuse soil albedo (col,bnd) [frc] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8), intent(in) :: frac_sno ! fraction of ground covered by snow (0-1) + real(r8), intent(in) :: h2osno ! snow water equivalent (mm H2O) + real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens content (col,lyr) [kg/m2] + real(r8), intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow grain radius (col,lyr) [microns] + + real(r8), intent(in) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass conc. of hydrophilic BC [kg/kg] + real(r8), intent(in) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass conc. of hydrophobic BC [kg/kg] + real(r8), intent(in) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass conc. of hydrophilic OC [kg/kg] + real(r8), intent(in) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass conc. of hydrophobic OC [kg/kg] + real(r8), intent(in) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass conc. of dust aerosol 1 [kg/kg] + real(r8), intent(in) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass conc. of dust aerosol 2 [kg/kg] + real(r8), intent(in) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass conc. of dust aerosol 3 [kg/kg] + real(r8), intent(in) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass conc. of dust aerosol 4 [kg/kg] + + real(r8), intent(out) :: albgrd ( numrad ) ! ground albedo (direct) + real(r8), intent(out) :: albgri ( numrad ) ! ground albedo (diffuse) + real(r8), intent(out) :: albgrd_pur ( numrad ) ! pure snow ground albedo (direct) + real(r8), intent(out) :: albgri_pur ( numrad ) ! pure snow ground albedo (diffuse) + real(r8), intent(out) :: albgrd_bc ( numrad ) ! ground albedo without BC (direct) + real(r8), intent(out) :: albgri_bc ( numrad ) ! ground albedo without BC (diffuse) + real(r8), intent(out) :: albgrd_oc ( numrad ) ! ground albedo without OC (direct) + real(r8), intent(out) :: albgri_oc ( numrad ) ! ground albedo without OC (diffuse) + real(r8), intent(out) :: albgrd_dst ( numrad ) ! ground albedo without dust (direct) + real(r8), intent(out) :: albgri_dst ( numrad ) ! ground albedo without dust (diffuse) + real(r8), intent(out) :: flx_absdv ( maxsnl+1:1 ) ! direct flux absorption factor VIS [frc] + real(r8), intent(out) :: flx_absdn ( maxsnl+1:1 ) ! direct flux absorption factor NIR [frc] + real(r8), intent(out) :: flx_absiv ( maxsnl+1:1 ) ! diffuse flux absorption factor VIS [frc] + real(r8), intent(out) :: flx_absin ( maxsnl+1:1 ) ! diffuse flux absorption factor NIR [frc] + + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + integer :: i ! index for layers [idx] + integer :: aer ! index for sno_nbr_aer + integer :: ib ! band index + integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse + integer :: flg_slr ! flag for SNICAR (=1 IF direct, =2 IF diffuse) + integer :: flg_snw_ice ! flag for SNICAR (=1 when called from ELM, =2 when called from sea-ice) + + ! mass concentration of aerosol species for forcing calculation (zero) (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_pur (maxsnl+1:0,sno_nbr_aer) + ! mass concentration of aerosol species for BC forcing (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_bc (maxsnl+1:0,sno_nbr_aer) + ! mass concentration of aerosol species for OC forcing (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_oc (maxsnl+1:0,sno_nbr_aer) + ! mass concentration of aerosol species for dust forcing (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_dst (maxsnl+1:0,sno_nbr_aer) + ! mass concentration of all aerosol species for feedback calculation (lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_fdb (maxsnl+1:0,sno_nbr_aer) + + real(r8) :: albsfc (numrad) ! albedo of surface underneath snow (col,bnd) + real(r8) :: albsnd (numrad) ! snow albedo (direct) + real(r8) :: albsni (numrad) ! snow albedo (diffuse) + real(r8) :: albsnd_pur (numrad) ! direct pure snow albedo + real(r8) :: albsni_pur (numrad) ! diffuse pure snow albedo + real(r8) :: albsnd_bc (numrad) ! direct snow albedo without BC + real(r8) :: albsni_bc (numrad) ! diffuse snow albedo without BC + real(r8) :: albsnd_oc (numrad) ! direct snow albedo without OC + real(r8) :: albsni_oc (numrad) ! diffuse snow albedo without OC + real(r8) :: albsnd_dst (numrad) ! direct snow albedo without dust + real(r8) :: albsni_dst (numrad) ! diffuse snow albedo without dust + real(r8) :: flx_absd_snw (maxsnl+1:1,numrad) ! flux absorption for just snow (direct) [frc] + real(r8) :: flx_absi_snw (maxsnl+1:1,numrad) ! flux absorption for just snow (diffuse) [frc] + real(r8) :: foo_snw (maxsnl+1:1,numrad) ! dummy array for forcing calls + + integer :: snw_rds_in (maxsnl+1:0) ! snow grain size sent to SNICAR (col,lyr) [microns] + + integer , parameter :: nband =numrad ! number of solar radiation waveband classes + + !----------------------------------------------------------------------- + + ! Initialize output because solar radiation only done IF coszen > 0 + + DO ib = 1, numrad + albgrd(ib) = 1._r8 + albgri(ib) = 1._r8 + albgrd_pur(ib) = 1._r8 + albgri_pur(ib) = 1._r8 + albgrd_bc(ib) = 1._r8 + albgri_bc(ib) = 1._r8 + albgrd_oc(ib) = 1._r8 + albgri_oc(ib) = 1._r8 + albgrd_dst(ib) = 1._r8 + albgri_dst(ib) = 1._r8 + DO i=maxsnl+1,1,1 + flx_absdv(i) = 0._r8 + flx_absdn(i) = 0._r8 + flx_absiv(i) = 0._r8 + flx_absin(i) = 0._r8 + ENDDO + ENDDO ! END of numrad loop + + ! set variables to pass to SNICAR. + + flg_snw_ice = 1 + albsfc(:) = albsoi(:) + snw_rds_in(:) = nint(snw_rds(:)) + + ! zero aerosol input arrays + DO aer = 1, sno_nbr_aer + DO i = maxsnl+1, 0 + mss_cnc_aer_in_frc_pur(i,aer) = 0._r8 + mss_cnc_aer_in_frc_bc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_oc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_dst(i,aer) = 0._r8 + mss_cnc_aer_in_fdb(i,aer) = 0._r8 + ENDDO + ENDDO + + ! If radiative forcing is being calculated, first estimate clean-snow albedo + + IF (use_snicar_frc) THEN + + ! 1. PURE SNOW ALBEDO CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 2. BC input array: + ! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_bc(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_bc(:,4) = mss_cnc_ocpho(:) + ENDIF + mss_cnc_aer_in_frc_bc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_bc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_bc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_bc(:,8) = mss_cnc_dst4(:) + + ! BC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 3. OC input array: + ! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_oc(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_oc(:,2) = mss_cnc_bcpho(:) + + mss_cnc_aer_in_frc_oc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_oc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_oc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_oc(:,8) = mss_cnc_dst4(:) + + ! OC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + ENDIF ! END IF (DO_SNO_OC) + + ! 4. DUST FORCING CALCULATIONS + ! DUST input array: + ! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)] + mss_cnc_aer_in_frc_dst(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_dst(:,2) = mss_cnc_bcpho(:) + + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_dst(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_dst(:,4) = mss_cnc_ocpho(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ENDIF !END IF use_snicar_frc + + + ! -------------------------------------------- + ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: + ! -------------------------------------------- + ! Set aerosol input arrays + ! feedback input arrays have been zeroed + ! set soot and dust aerosol concentrations: + IF (DO_SNO_AER) THEN + mss_cnc_aer_in_fdb(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_fdb(:,2) = mss_cnc_bcpho(:) + + ! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because: + ! 1) Knowledge of their optical properties is primitive + ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, + ! it has a negligible darkening effect. + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_fdb(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_fdb(:,4) = mss_cnc_ocpho(:) + ENDIF + + mss_cnc_aer_in_fdb(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_fdb(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_fdb(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_fdb(:,8) = mss_cnc_dst4(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + + ! ground albedos and snow-fraction weighting of snow absorption factors + DO ib = 1, nband + IF (coszen_col > 0._r8) THEN + ! ground albedo was originally computed in SoilAlbedo, but is now computed here + ! because the order of SoilAlbedo and SNICAR_RT/SNICAR_AD_RT + ! was switched for SNICAR/SNICAR_AD_RT. + ! 09/01/2023, yuan: change to only snow albedo, the same below + !albgrd(ib) = albsod(ib)*(1._r8-frac_sno) + albsnd(ib)*frac_sno + !albgri(ib) = albsoi(ib)*(1._r8-frac_sno) + albsni(ib)*frac_sno + albgrd(ib) = albsnd(ib) + albgri(ib) = albsni(ib) + + ! albedos for radiative forcing calculations: + IF (use_snicar_frc) THEN + ! pure snow albedo for all-aerosol radiative forcing + !albgrd_pur(ib) = albsod(ib)*(1.-frac_sno) + albsnd_pur(ib)*frac_sno + !albgri_pur(ib) = albsoi(ib)*(1.-frac_sno) + albsni_pur(ib)*frac_sno + albgrd_pur(ib) = albsnd_pur(ib) + albgri_pur(ib) = albsni_pur(ib) + + ! BC forcing albedo + !albgrd_bc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_bc(ib)*frac_sno + !albgri_bc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_bc(ib)*frac_sno + albgrd_bc(ib) = albsnd_bc(ib) + albgri_bc(ib) = albsni_bc(ib) + + IF (DO_SNO_OC) THEN + ! OC forcing albedo + !albgrd_oc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_oc(ib)*frac_sno + !albgri_oc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_oc(ib)*frac_sno + albgrd_oc(ib) = albsnd_oc(ib) + albgri_oc(ib) = albsni_oc(ib) + ENDIF + + ! dust forcing albedo + !albgrd_dst(ib) = albsod(ib)*(1.-frac_sno) + albsnd_dst(ib)*frac_sno + !albgri_dst(ib) = albsoi(ib)*(1.-frac_sno) + albsni_dst(ib)*frac_sno + albgrd_dst(ib) = albsnd_dst(ib) + albgri_dst(ib) = albsni_dst(ib) + ENDIF + + ! also in this loop (but optionally in a different loop for vectorized code) + ! weight snow layer radiative absorption factors based on snow fraction and soil albedo + ! (NEEDED FOR ENERGY CONSERVATION) + DO i = maxsnl+1,1,1 + IF (subgridflag == 0 ) THEN + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absiv(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + ELSEIF (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absin(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + ENDIF + ELSE + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)!*(1.-albsnd(ib)) + flx_absiv(i) = flx_absi_snw(i,ib)!*(1.-albsni(ib)) + ELSEIF (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)!*(1.-albsnd(ib)) + flx_absin(i) = flx_absi_snw(i,ib)!*(1.-albsni(ib)) + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + END SUBROUTINE SnowAlbedo + + + SUBROUTINE albocean (oro, scv, coszrs, alb) + +!----------------------------------------------------------------------- +! +! Compute surface albedos +! +! Computes surface albedos for direct/diffuse incident radiation for +! two spectral intervals: +! s = 0.2-0.7 micro-meters +! l = 0.7-5.0 micro-meters +! +! Albedos specified as follows: +! +! Ocean Uses solar zenith angle to compute albedo for direct +! radiation; diffuse radiation values constant; albedo +! independent of spectral interval and other physical +! factors such as ocean surface wind speed. +! +! Ocean with Surface albs specified; combined with overlying snow +! sea ice +! +! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington +! Approximation for Solar Radiation in the NCAR Community Climate Model, +! Journal of Geophysical Research, Vol 97, D7, pp7603-7612). +! +! Yongjiu Dai and Xin-Zhong Liang (08/01/2001) +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: oro ! /ocean(0)/seaice(2) flag + real(r8), intent(in) :: scv ! snow water equivalent) [mm] + real(r8), intent(in) :: coszrs ! Cosine solar zenith angle + + real(r8), intent(out) :: alb(2,2) ! srf alb for direct (diffuse) rad 0.2-0.7 micro-ms + ! Srf alb for direct (diffuse) rad 0.7-5.0 micro-ms + +!-------------------------- Local Variables ---------------------------- + + real(r8) frsnow ! horizontal fraction of snow cover + real(r8) snwhgt ! physical snow height + real(r8) rghsnw ! roughness for horizontal snow cover fractn + + real(r8) sasdir ! snow alb for direct rad 0.2-0.7 micro-ms + real(r8) saldir ! snow alb for direct rad 0.7-5.0 micro-ms + real(r8) sasdif ! snow alb for diffuse rad 0.2-0.7 micro-ms + real(r8) saldif ! snow alb for diffuse rad 0.7-5.0 micro-ms + + real(r8), parameter :: asices = 0.70 ! sea ice albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asicel = 0.50 ! sea ice albedo for 0.7-5.0 micro-meters [-] + real(r8), parameter :: asnows = 0.95 ! snow albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asnowl = 0.70 ! snow albedo for 0.7-5.0 micro-meters + +!----------------------------------------------------------------------- +! initialize all ocean/sea ice surface albedos to zero + + alb(:,:) = 0. + IF(coszrs<=0.0) RETURN + + IF(nint(oro)==2)THEN + alb(1,1) = asices + alb(2,1) = asicel + alb(1,2) = alb(1,1) + alb(2,2) = alb(2,1) + sasdif = asnows + saldif = asnowl + + IF(scv>0.)THEN + IF (coszrs<0.5) THEN + ! zenith angle regime 1 ( coszrs < 0.5 ). + ! set direct snow albedos (limit to 0.98 max) + sasdir = min(0.98,sasdif+(1.-sasdif)*0.5*(3./(1.+4.*coszrs)-1.)) + saldir = min(0.98,saldif+(1.-saldif)*0.5*(3./(1.+4.*coszrs)-1.)) + ELSE + ! zenith angle regime 2 ( coszrs >= 0.5 ) + sasdir = asnows + saldir = asnowl + ENDIF + + ! compute both diffuse and direct total albedos + snwhgt = 20.*scv / 1000. + rghsnw = 0.25 + frsnow = snwhgt/(rghsnw+snwhgt) + alb(1,1) = alb(1,1)*(1.-frsnow) + sasdir*frsnow + alb(2,1) = alb(2,1)*(1.-frsnow) + saldir*frsnow + alb(1,2) = alb(1,2)*(1.-frsnow) + sasdif*frsnow + alb(2,2) = alb(2,2)*(1.-frsnow) + saldif*frsnow + ENDIF + ENDIF + +! ice-free ocean albedos function of solar zenith angle only, and +! independent of spectral interval: + + IF(nint(oro)==0)THEN + alb(2,1) = .026/(coszrs**1.7+.065) & + + .15*(coszrs-0.1)*(coszrs-0.5)*(coszrs-1.) + alb(1,1) = alb(2,1) + alb(1,2) = 0.06 + alb(2,2) = 0.06 + ENDIF + + END SUBROUTINE albocean + +END MODULE MOD_Albedo +! --------- EOP ---------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo_HiRes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo_HiRes.F90 new file mode 100644 index 0000000000..2c9b2ef86c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Albedo_HiRes.F90 @@ -0,0 +1,3374 @@ +#include + +#ifdef HYPERSPECTRAL +MODULE MOD_Albedo_HiRes + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: albland_HiRes + PUBLIC :: snowage + PUBLIC :: SnowAlbedo + PUBLIC :: albocean + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: twostream + PRIVATE :: twostream_hires +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + PRIVATE :: twostream_mod + PRIVATE :: twostream_wrap + PRIVATE :: twostream_hires_mod + PRIVATE :: twostream_hires_wrap +#endif + PRIVATE :: BSM_soil_moisture, calculate_tav, calculate_wgt_variable + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE albland_HiRes (ipatch, patchtype, deltim,& + soil_s_v_alb,soil_d_v_alb,soil_s_n_alb,soil_d_n_alb,& + chil,rho,tau,fveg,green,lai,sai,fwet_snow,coszen,& + wt,fsno,scv,scvold,sag,ssw,pg_snow,forc_t,t_grnd,t_soisno,dz_soisno,& + snl,wliq_soisno,wice_soisno,snw_rds,snofrz,& + mss_bcpho,mss_bcphi,mss_ocpho,mss_ocphi,& + mss_dst1,mss_dst2,mss_dst3,mss_dst4,& + alb,ssun,ssha,ssoi,ssno,ssno_lyr,thermk,extkb,extkd,& + + ! new parameters for high res + alb_hires ,& + dir_frac , dif_frac, & + reflectance, transmittance, & + soil_alb, kw, nw, porsl, & + reflectance_out, transmittance_out,& + doy, patchlatr, patchlonr ,& + ! new parameters for urban + urban_albedo, mean_albedo ,& + lat_north, lat_south, lon_west, lon_east) + +!======================================================================= +! Calculates fragmented albedos (direct and diffuse) in +! wavelength regions split at 0.7um. +! +! (1) soil albedos: as in BATS formulations, which are the function of +! soil color and moisture in the surface soil layer +! (2) snow albedos: as in BATS formulations, which are inferred from +! the calculations of Wiscombe and Warren (1980) and the snow model +! and data of Anderson(1976), and the function of snow age, grain size, +! solar zenith angle, pollution, the amount of the fresh snow +! (3) canopy albedo: two-stream approximation model +! (4) glacier albedos: as in BATS, which are set to constants (0.8 for visible beam, +! 0.55 for near-infrared) +! (5) lake and wetland albedos: as in BATS, which depend on cosine solar zenith angle, +! based on data in Henderson-Sellers (1986). The frozen lake and wetland albedos +! are set to constants (0.6 for visible beam, 0.4 for near-infrared) +! (6) over the snow covered tile, the surface albedo is estimated by a linear +! combination of albedos for snow, canopy and bare soil (or lake, wetland, glacier). +! +! Original author : Yongjiu Dai, 09/15/1999; 08/30/2002, 03/2014 +! +! !REVISIONS: +! 12/2019, Hua Yuan: added a wrap FUNCTION for PFT calculation, details see +! twostream_wrap() added a wrap FUNCTION for PC (3D) calculation, +! details see ThreeDCanopy_wrap() +! +! 03/2020, Hua Yuan: added an improved two-stream model, details see +! twostream_mod() +! +! 08/2020, Hua Yuan: account for stem optical property effects in twostream +! model +! +! 01/2023, Hua Yuan: CALL SNICAR model to calculate snow albedo&absorption, +! added SNICAR related variables +! +! 04/2024, Hua Yuan: add option to account for vegetation snow process +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz + USE MOD_Namelist, only: DEF_USE_SNICAR, DEF_HighResSoil + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_HighRes_Parameters, only: rad2deg +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables +#endif + USE MOD_Aerosol, only: AerosolMasses + USE MOD_SnowSnicar_HiRes, only: SnowAge_grain +#ifdef LULC_IGBP_PC + USE MOD_3DCanopyRadiation, only: ThreeDCanopy_wrap +#endif + + ! IEEE arithmetic module for isnan function, only for debug + ! use, intrinsic :: IEEE_ARITHMETIC, only: IEEE_IS_NAN, IEEE_SUPPORT_DATATYPE + + IMPLICIT NONE + +!------------------------- Dummy Arguments ----------------------------- +! ground cover index + integer, intent(in) :: & + ipatch, &! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=deep lake) + integer, intent(in) :: & + snl, &! number of snow layers + doy + + real(r8), intent(in) :: & + patchlatr, &! patch latitude (radian) + patchlonr ! patch longitude (radian) + + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + soil_s_v_alb, &! albedo of visible of the saturated soil + soil_d_v_alb, &! albedo of visible of the dry soil + soil_s_n_alb, &! albedo of near infrared of the saturated soil + soil_d_n_alb, &! albedo of near infrared of the dry soil + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + fveg, &! fractional vegetation cover [-] + green, &! green leaf fraction + lai, &! leaf area index (LAI+SAI) [m2/m2] + sai, &! stem area index (LAI+SAI) [m2/m2] + fwet_snow, &! vegetation snow fractional cover [-] + + coszen, &! cosine of solar zenith angle [-] + wt, &! fraction of vegetation covered by snow [-] + fsno, &! fraction of soil covered by snow [-] + ssw, &! water volumetric content of soil surface layer [m3/m3] + scv, &! snow cover, water equivalent [mm] + scvold, &! snow cover for previous time step [mm] + pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] + forc_t, &! atmospheric temperature [K] + t_grnd, &! ground surface temperature [K] + porsl + + real(r8), intent(in) :: & + wliq_soisno ( maxsnl+1:0 ), &! liquid water (kg/m2) + wice_soisno ( maxsnl+1:0 ), &! ice lens (kg/m2) + snofrz ( maxsnl+1:0 ), &! snow freezing rate (col,lyr) [kg m-2 s-1] + t_soisno ( maxsnl+1:1 ), &! soil + snow layer temperature [K] + dz_soisno ( maxsnl+1:1 ), &! layer thickness (m) + + dir_frac (211) ,&! + dif_frac (211) ,&! + reflectance (0:15,211,2) ,&! reflectance (PFT, wavelength, dir/dif) + transmittance(0:15,211,2) ,&! transmittance (PFT, wavelength, dir/dif) + soil_alb (211) ,&! soil albedo [-] + kw (211) ,&! soil albedo [-] + nw (211) ! soil albedo [-] + + + real(r8), intent(inout) :: & + snw_rds ( maxsnl+1:0 ), &! effective grain radius (col,lyr) [microns, m-6] + mss_bcpho ( maxsnl+1:0 ), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi ( maxsnl+1:0 ), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho ( maxsnl+1:0 ), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi ( maxsnl+1:0 ), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 ( maxsnl+1:0 ), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 ( maxsnl+1:0 ), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 ( maxsnl+1:0 ), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 ( maxsnl+1:0 ) ! mass of dust species 4 in snow (col,lyr) [kg] + + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + + real(r8), intent(out) :: & + alb(2,2), &! averaged albedo [-] + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2), &! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd ! diffuse and scattered diffuse PAR extinction coefficient + + real(r8), intent(out) :: & + alb_hires (211, 2) ,&! high resolution albedo, (wavelength, dir/dif) + reflectance_out (211, 0:15) ,&! + transmittance_out(211, 0:15) + + real(r8), intent(out) :: & + ssoi(2,2), &! ground soil absorption [-] + ssno(2,2), &! ground snow absorption [-] + ssno_lyr(2,2,maxsnl+1:1) ! ground snow layer absorption, by SNICAR [-] + + ! New inout parameters for urban + real(r8), ALLOCATABLE, intent(in) :: & + urban_albedo(:,:,:), &! (cluster_id, season,wavelength) + mean_albedo(:, :), &! (season, wavelength) + lat_north(:), lat_south(:),& + lon_west (:), lon_east(:) + + +!-------------------------- Local variables ---------------------------- + + real(r8) :: &! + age, &! factor to reduce visible snow alb due to snow age [-] + albg0, &! temporary varaiable [-] + albsoi(2,2), &! soil albedo [-] + albsno(2,2), &! snow albedo [-] + albsno_pur(2,2), &! snow albedo [-] + albsno_bc (2,2), &! snow albedo [-] + albsno_oc (2,2), &! snow albedo [-] + albsno_dst(2,2), &! snow albedo [-] + albg(2,2), &! albedo, ground + albv(2,2), &! albedo, vegetation [-] + alb_s_inc, &! decrease in soil albedo due to wetness [-] + beta0, &! upscattering parameter for direct beam [-] + cff, &! snow alb correction factor for zenith angle > 60 [-] + conn, &! constant (=0.5) for visible snow alb calculation [-] + cons, &! constant (=0.2) for nir snow albedo calculation [-] + czen, &! cosine of solar zenith angle > 0 [-] + czf, &! solar zenith correction for new snow albedo [-] + dfalbl, &! snow albedo for diffuse nir radiation [-] + dfalbs, &! snow albedo for diffuse vis radiation [-] + dralbl, &! snow albedo for direct nir radiation [-] + dralbs, &! snow albedo for direct vis radiation [-] + lsai, &! leaf and stem area index (LAI+SAI) [m2/m2] + sl, &! factor that helps control alb zenith dependence [-] + snal0, &! alb for visible,incident on new snow (zen ang<60) [-] + snal1, &! alb for NIR, incident on new snow (zen angle<60) [-] + upscat, &! upward scattered fraction for direct beam [-] + tran(2,3) ! canopy transmittances for solar radiation + +!-------------------------- Local high resolution variables ---------------------------- + real(r8) :: &! + + ! sun fraction + fsds_vis_dir_frac(29 ) ,& + fsds_nir_dir_frac(182) ,& + fsds_vis_dif_frac(29 ) ,& + fsds_nir_dif_frac(182) ,& + + ! ground + albg_hires(211, 2) ,& + + ! soil + albsoi_hires(211, 2) ,& + + ! snow + alb_sno_hires(211, 2) ,&! high resolution albedo, (wavelength, dir/dif) + + alb_sno_5band (5, 2) ,& + albsno_pur_5band(5, 2) ,&! snow albedo [-] + albsno_bc_5band (5, 2) ,&! snow albedo [-] + albsno_oc_5band (5, 2) ,&! snow albedo [-] + albsno_dst_5band(5, 2) ,&! snow albedo [-] + + ! vegetation + rho_hires(211, 2) ,& + tau_hires(211, 2) ,& + albv_hires(211, 2) ,& + tran_hires(211, 3) ,& + scat_hires(211) ,& + ssun_hires(211, 2) ,& + ssha_hires(211, 2) + + INTEGER, PARAMETER, DIMENSION(6) :: band_index = (/ & + 1, 30, 60, 80, 110, 212 &! 400, 700, 1000, 1200, 1500, 2500 nm + /) + + real(r8) :: smc + integer :: i, j, ibnd, start_index, end_index ! index for 5 bands [idx] + + integer ps, pe + logical do_capsnow !true => DO snow capping + logical use_snicar_frc !true: IF radiative forcing is being calculated, first estimate clean-snow albedo + logical use_snicar_ad !true: use SNICAR_AD_RT, false: use SNICAR_RT + + real(r8) snwcp_ice !excess precipitation due to snow capping [kg m-2 s-1] + real(r8) mss_cnc_bcphi ( maxsnl+1:0 ) !mass concentration of hydrophilic BC (col,lyr) [kg/kg] + real(r8) mss_cnc_bcpho ( maxsnl+1:0 ) !mass concentration of hydrophobic BC (col,lyr) [kg/kg] + real(r8) mss_cnc_ocphi ( maxsnl+1:0 ) !mass concentration of hydrophilic OC (col,lyr) [kg/kg] + real(r8) mss_cnc_ocpho ( maxsnl+1:0 ) !mass concentration of hydrophobic OC (col,lyr) [kg/kg] + real(r8) mss_cnc_dst1 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] + real(r8) mss_cnc_dst2 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] + real(r8) mss_cnc_dst3 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] + real(r8) mss_cnc_dst4 ( maxsnl+1:0 ) !mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] + + logical :: has_nan + + real(r8) :: lat, lon + INTEGER :: num_urban_lat, num_urban_lon + INTEGER :: i_cluster + INTEGER :: season_index +! ---------------------------------------------------------------------- +! 1. Initial set +! ---------------------------------------------------------------------- +! set fsds + fsds_vis_dir_frac(:) = dir_frac(1:29) + fsds_nir_dir_frac(:) = dir_frac(30:211) + fsds_vis_dif_frac(:) = dif_frac(1:29) + fsds_nir_dif_frac(:) = dif_frac(30:211) + +! visible and near infrared band albedo for new snow + snal0 = 0.85 !visible band + snal1 = 0.65 !near infrared + +! ---------------------------------------------------------------------- +! set default soil and vegetation albedos and solar absorption + alb (:,:) = 1. !averaged + albg(:,:) = 1. !ground + albv(:,:) = 1. !vegetation + ssun(:,:) = 0. !sunlit leaf absorption + ssha(:,:) = 0. !shaded leaf absorption + + alb_hires (:,:) = 1. ! high resolution albedo + albg_hires(:,:) = 1. ! high resolution ground albedo + albv_hires(:,:) = 1. ! high resolution vegetation albedo + ssun_hires (:,:) = 0. + ssha_hires (:,:) = 0. + + ! albsoi_hires (:,:) = 1. + + tran(:,1) = 0. !incident direct radiation diffuse transmittance + tran(:,2) = 1. !incident diffuse radiation diffuse transmittance + tran(:,3) = 1. !incident direct radiation direct transmittance + + tran_hires(:,1) = 0. !incident direct radiation diffuse transmittance + tran_hires(:,2) = 1. !incident diffuse radiation diffuse transmittance + tran_hires(:,3) = 1. !incident direct radiation direct transmittance + + reflectance_out (:,:) = -999. + transmittance_out(:,:) = -999. + + ! 07/06/2023, yuan: use the values of previous timestep. + ! for nighttime longwave calculations. + !thermk = 1.e-3 + IF (lai+sai <= 1.e-6) THEN + thermk = 1. + ENDIF + extkb = 1. + extkd = 0.718 + + albsno (:,:) = 1. !set initial snow albedo + albsno_pur(:,:) = 1. !set initial pure snow albedo + albsno_bc (:,:) = 1. !set initial BC snow albedo + albsno_oc (:,:) = 1. !set initial OC snow albedo + albsno_dst(:,:) = 1. !set initial dust snow albedo + + alb_sno_hires (:,:) = 1.! high resolution albedo, (wavelength, dir/dif) + albsno_pur_5band(:,:) = 1. + albsno_bc_5band (:,:) = 1. + albsno_oc_5band (:,:) = 1. + albsno_dst_5band(:,:) = 1. + + ! soil and snow absorption + ssoi (:,:) = 0. !set initial soil absorption + ssno (:,:) = 0. !set initial snow absorption + ssno_lyr(:,:,:) = 0. !set initial snow layer absorption + +IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + ssun_p(:,:,ps:pe) = 0. + ssha_p(:,:,ps:pe) = 0. + + ssun_hires_p(:,:,ps:pe) = 0. + ssha_hires_p(:,:,ps:pe) = 0. + ! 07/06/2023, yuan: use the values of previous timestep. + !thermk_p(ps:pe) = 1.e-3 + WHERE (lai_p(ps:pe)+sai_p(ps:pe) <= 1.e-6) thermk_p(ps:pe) = 1. + extkb_p(ps:pe) = 1. + extkd_p(ps:pe) = 0.718 +#endif +ENDIF + +! ---------------------------------------------------------------------- +! Calculate column-integrated aerosol masses, and +! mass concentrations for radiative calculations and output +! (based on new snow level state, after SnowFilter is rebuilt. +! NEEDS TO BE AFTER SnowFiler is rebuilt, otherwise there +! can be zero snow layers but an active column in filter) +IF (DEF_USE_SNICAR) THEN + snwcp_ice = 0.0 !excess precipitation due to snow capping [kg m-2 s-1] + do_capsnow = .false. !true => DO snow capping + + CALL AerosolMasses( deltim, snl ,do_capsnow ,& + wice_soisno(:0),wliq_soisno(:0),snwcp_ice ,snw_rds ,& + + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ) + +! ---------------------------------------------------------------------- +! Snow aging routine based on Flanner and Zender (2006), Linking snowpack +! microphysics and albedo evolution, JGR, and Brun (1989), Investigation of +! wet-snow metamorphism in respect of liquid-water content, Ann. Glaciol. + + CALL SnowAge_grain( deltim ,snl ,dz_soisno(:1) ,& + pg_snow ,snwcp_ice ,snofrz ,& + + do_capsnow ,fsno ,scv ,& + wliq_soisno (:0),wice_soisno(:0),& + t_soisno (:1),t_grnd ,& + forc_t ,snw_rds ) +END IF +! ---------------------------------------------------------------------- + + lsai = lai + sai + IF(coszen <= -0.3) THEN + RETURN !only DO albedo when coszen > -0.3 + ENDIF + + czen = max(coszen, 0.001) + +! ---------------------------------------------------------------------- +! 2. get albedo over land +! ---------------------------------------------------------------------- +! 2.1 soil albedos, depends on moisture + + ! IF (patchtype <= 2) THEN !soil, urban and wetland + IF (patchtype == 0) THEN !soil + + ! calculate broadband albedos + alb_s_inc = max(0.11-0.40*ssw, 0.) + albg(1,1) = min(soil_s_v_alb + alb_s_inc, soil_d_v_alb) + albg(2,1) = min(soil_s_n_alb + alb_s_inc, soil_d_n_alb) + albg(:,2) = albg(:,1) !diffused albedos setting + + IF ( DEF_HighResSoil ) THEN + ! calculate high res soil albedos + CALL BSM_soil_moisture( ssw * 100., porsl * 100., soil_alb, kw, nw, albg_hires ) + + ! calculate broadband albedos + CALL calculate_wgt_variable(albg_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, albg(1,1), albg(2,1)) + CALL calculate_wgt_variable(albg_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, albg(1,2), albg(2,2)) + + ELSE + + ! calculate high res soil albedos + albg_hires(1 :29 ,1) = albg(1,1) + albg_hires(30:211,1) = albg(2,1) + albg_hires(1 :29 ,2) = albg(1,2) + albg_hires(30:211,2) = albg(2,2) + + END IF + + !DEBUG: Temporarily handle the missing values of soil albedo in certain grids + IF (soil_alb(1) < 0.01) THEN + albg_hires(1:29 ,1) = albg(1,1) + albg_hires(30:211 ,1) = albg(2,1) + albg_hires(1:29 ,2) = albg(1,2) + albg_hires(30:211 ,2) = albg(2,2) + END IF + + ELSE IF(patchtype == 1) THEN !urban + + ! select constant albedo for urban + lat = rad2deg(patchlatr) + lon = rad2deg(patchlonr) + + ! 根据lat、lon边界选择cluster_id + i_cluster = 0 + DO i = 1, SIZE(lat_north) + IF (lat >= lat_south(i) .and. lat <= lat_north(i) .and. & + lon >= lon_west(i) .and. lon <= lon_east(i)) THEN + i_cluster = i + EXIT + END IF + END DO + + ! 根据季节选择albedo + ! 季节指数: 1=冬季, 2=春季, 3=夏季, 4=秋季 + IF (doy >= 355 .or. doy < 80) THEN + season_index = 1 ! 冬季 + ELSE IF (doy >= 80 .and. doy < 172) THEN + season_index = 2 ! 春季 + ELSE IF (doy >= 172 .and. doy < 266) THEN + season_index = 3 ! 夏季 + ELSE + season_index = 4 ! 秋季 + END IF + + ! 提取反照率数据 + IF (i_cluster > 0 .and. allocated(urban_albedo)) THEN + albg_hires(:, 1) = urban_albedo(i_cluster, season_index, :) + albg_hires(:, 2) = urban_albedo(i_cluster, season_index, :) + ELSE + ! 如果未找到合适的cluster或数据未分配，使用mean_albedo + IF (allocated(mean_albedo)) THEN + albg_hires(:, 1) = mean_albedo(season_index, :) + albg_hires(:, 2) = mean_albedo(season_index, :) + ELSE + ! 如果都没有数据，使用默认值 + albg_hires(1 :29 ,1) = 0.12 + albg_hires(30:211,1) = 0.20 + albg_hires(1 :29 ,2) = 0.12 + albg_hires(30:211,2) = 0.20 + END IF + END IF + + ! 计算宽波段反照率 (VIS 和 NIR) + CALL calculate_wgt_variable(albg_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, albg(1,1), albg(2,1)) + CALL calculate_wgt_variable(albg_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, albg(1,2), albg(2,2)) + + ELSE IF (patchtype == 2) THEN !wetland + ! calculate broadband albedos + alb_s_inc = max(0.11-0.40*ssw, 0.) + albg(1,1) = min(soil_s_v_alb + alb_s_inc, soil_d_v_alb) + albg(2,1) = min(soil_s_n_alb + alb_s_inc, soil_d_n_alb) + albg(:,2) = albg(:,1) !diffused albedos setting + + albg_hires(1 :29 ,1) = albg(1,1) + albg_hires(1 :29 ,2) = albg(1,2) + albg_hires(30:211,1) = albg(2,1) + albg_hires(30:211,2) = albg(2,2) + +! 2.2 albedos for permanent ice sheet. + ELSE IF(patchtype == 3) THEN !permanent ice sheet + albg(1,:) = 0.8 + albg(2,:) = 0.55 + + albg_hires(1 :29 ,:) = 0.8 + albg_hires(30:211,:) = 0.55 + +! 2.3 albedo for inland water + ELSE IF(patchtype >= 4) THEN + albg0 = 0.05/(czen+0.15) + albg(:,1) = albg0 + albg(:,2) = 0.1 !Subin (2012) + + albg_hires(:,1) = albg0 + albg_hires(:,2) = 0.1 + + IF(t_grnd < tfrz)THEN !frozen lake and wetland + albg(1,:) = 0.6 + albg(2,:) = 0.4 + + albg_hires(1 :29 ,:) = 0.6 + albg_hires(30:211,:) = 0.4 + ENDIF + ENDIF + + ! SAVE soil ground albedo + albsoi (:,:) = albg (:,:) + albsoi_hires(:,:) = albg_hires(:,:) + + ! ---------------------------------------------------------------------- +! 3. albedo for snow cover. +! - Scheme 1: snow albedo depends on snow-age, zenith angle, and thickness +! of snow age gives reduction of visible radiation [CoLM2014]. +! - Scheme 2: SNICAR model +! ---------------------------------------------------------------------- + IF (scv > 0.) THEN + + IF (.not. DEF_USE_SNICAR) THEN + cons = 0.2 + conn = 0.5 + sl = 2.0 !sl helps control albedo zenith dependence + + ! 05/02/2023, Dai: move from CoLMMAIN.F90 + ! update the snow age + IF (snl == 0) sag=0. + CALL snowage (deltim,t_grnd,scv,scvold,sag) + + ! correction for snow age + age = 1.-1./(1.+sag) + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ELSE + + ! 01/09/2023, yuan: CALL SNICAR for snow albedo + use_snicar_frc = .false. ! true: IF radiative forcing is being calculated, first estimate clean-snow albedo + use_snicar_ad = .true. ! use true: use SNICAR_AD_RT, false: use SNICAR_RT + + CALL SnowAlbedo( use_snicar_frc ,use_snicar_ad ,coszen ,& + albg_hires(:,1),albg_hires(:,2),snl ,fsno ,& + scv ,wliq_soisno ,wice_soisno ,snw_rds ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ,& + + alb_sno_5band (:,1),alb_sno_5band (:,2),albsno_pur_5band(:,1),albsno_pur_5band(:,2),& + albsno_bc_5band (:,1),albsno_bc_5band (:,2),albsno_oc_5band (:,1),albsno_oc_5band (:,2),& + albsno_dst_5band(:,1),albsno_dst_5band(:,2),ssno_lyr(1,1,:) ,ssno_lyr(2,1,:) ,& + ssno_lyr(1,2,:) ,ssno_lyr(2,2,:) ,dir_frac ,dif_frac ) + + ! IF no snow layer exist + IF (snl == 0) THEN + ssno_lyr(:,:,1) = ssno_lyr(:,:,1) + ssno_lyr(:,:,0) + ssno_lyr(:,:,0) = 0. + ENDIF + ENDIF + ENDIF + +! 3.1 correction due to snow cover + ! albg(:,:) = (1.-fsno)*albg(:,:) + fsno*albsno(:,:) + ! alb (:,:) = albg(:,:) + + do ibnd = 1, 5 + start_index = band_index(ibnd) + end_index = band_index(ibnd+1) - 1 + + alb_sno_hires(start_index:end_index, 1) = alb_sno_5band(ibnd, 1) + alb_sno_hires(start_index:end_index, 2) = alb_sno_5band(ibnd, 2) + end do + + albg_hires(:,1) = (1.-fsno)*albg_hires(:,1) + fsno*alb_sno_hires(:,1) + albg_hires(:,2) = (1.-fsno)*albg_hires(:,2) + fsno*alb_sno_hires(:,2) + + alb_hires(:,1) = albg_hires(:,1) + alb_hires(:,2) = albg_hires(:,2) + + CALL calculate_wgt_variable(albg_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, albg(1,1), albg(2,1)) + CALL calculate_wgt_variable(albg_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, albg(1,2), albg(2,2)) + + alb (:,:) = albg(:,:) + +! ---------------------------------------------------------------------- +! 4. canopy albedos: two stream approximation or 3D canopy radiation transfer +! ---------------------------------------------------------------------- + IF (lai+sai > 1e-6 .and. patchtype < 3) THEN + ! initialization + albv(:,:) = albg(:,:) + + IF (patchtype == 0) THEN !soil patches + +#if (defined LULC_USGS || defined LULC_IGBP) + ! High resolution vegetation + write(*,*) "NOT SUPPORT NOW!!!!!!!" + CALL twostream_hires (chil,reflectance,transmittance,green,lai,sai, fwet_snow,& + czen,albg_hires,albv_hires,tran_hires,thermk,extkb,extkd,ssun_hires,ssha_hires) + + CALL calculate_wgt_variable(albg_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, alb(1,1), alb(2,1)) + CALL calculate_wgt_variable(albg_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, alb(1,2), alb(2,2)) + + CALL calculate_wgt_variable(ssun_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, ssun(1,1), ssun(2,1)) + CALL calculate_wgt_variable(ssun_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, ssun(1,2), ssun(2,2)) + + CALL calculate_wgt_variable(ssha_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, ssha(1,1), ssha(2,1)) + CALL calculate_wgt_variable(ssha_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, ssha(1,2), ssha(2,2)) + + alb_hires(:,:) = albv_hires(:,:) + + ! ! two-band albedo + ! CALL twostream (chil,rho,tau,green,lai,sai,fwet_snow,& + ! czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) + + ! 08/31/2023, yuan: to be consistent with PFT and PC + !albv(:,:) = (1.- wt)*albv(:,:) + wt*albsno(:,:) + !alb (:,:) = (1.-fveg)*albg(:,:) + fveg*albv(:,:) + + ! alb(:,:) = albv(:,:) + +#endif + ELSE !other patchtypes (/=0) + CALL twostream (chil,rho,tau,green,lai,sai,fwet_snow,& + czen,albg,albv,tran,thermk,extkb,extkd,ssun,ssha) + + ! 08/31/2023, yuan: to be consistent with PFT and PC + !albv(:,:) = (1.- wt)*albv(:,:) + wt*albsno(:,:) + !alb (:,:) = (1.-fveg)*albg(:,:) + fveg*albv(:,:) + alb(:,:) = albv(:,:) + + alb_hires(1:29 ,1) = albv_hires(1,1) + alb_hires(30:211,1) = albv_hires(2,1) + alb_hires(1:29 ,2) = albv_hires(1,2) + alb_hires(30:211,2) = albv_hires(2,2) + + tran_hires(1:29 ,1) = tran(1,1) + tran_hires(30:211,1) = tran(2,1) + tran_hires(1:29 ,2) = tran(1,2) + tran_hires(30:211,2) = tran(2,2) + tran_hires(1:29 ,3) = tran(1,3) + tran_hires(30:211,3) = tran(2,3) + ENDIF + ENDIF + + + IF (patchtype == 0) THEN + +#ifdef LULC_IGBP_PFT + CALL twostream_hires_wrap (ipatch, czen, albg_hires, & + albv_hires, tran_hires, ssun_hires, ssha_hires, & + reflectance, transmittance, & + fsds_vis_dir_frac, fsds_nir_dir_frac, & + fsds_vis_dif_frac, fsds_nir_dif_frac, & + ssw, reflectance_out, transmittance_out, doy) + + ! convert alb(:,:) = albv(:,:) -> hyperspectral + CALL calculate_wgt_variable(albv_hires(:,1), fsds_vis_dir_frac, fsds_nir_dir_frac, alb(1,1), alb(2,1)) + CALL calculate_wgt_variable(albv_hires(:,2), fsds_vis_dif_frac, fsds_nir_dif_frac, alb(1,2), alb(2,2)) + + alb_hires(:,:) = albv_hires(:,:) +#endif + +#ifdef LULC_IGBP_PC + !NOTE: if patchclass is CROPLAND, using twostream model + IF (patchclass(ipatch) == CROPLAND) THEN + CALL twostream_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + alb(:,:) = albv(:,:) + ELSE + CALL ThreeDCanopy_wrap (ipatch, czen, albg, albv, tran, ssun, ssha) + alb(:,:) = albv(:,:) + ENDIF +#endif + ENDIF + + ! treat soil/snow albedo in direct and diffuse respectively + CALL calculate_wgt_variable((tran_hires(:,1)*(1.-albsoi_hires(:,2)) + tran_hires(:,3)*(1.-albsoi_hires(:,1))), fsds_vis_dir_frac, fsds_nir_dir_frac, ssoi(1,1), ssoi(2,1)) + CALL calculate_wgt_variable((tran_hires(:,2)*(1.-albsoi_hires(:,2))), fsds_vis_dif_frac, fsds_nir_dif_frac, ssoi(1,2), ssoi(2,2)) + + CALL calculate_wgt_variable((tran_hires(:,1)*(1.-alb_sno_hires(:,2)) + tran_hires(:,3)*(1.-alb_sno_hires(:,1))), fsds_vis_dir_frac, fsds_nir_dir_frac, ssno(1,1), ssno(2,1)) + CALL calculate_wgt_variable((tran_hires(:,2)*(1.-alb_sno_hires(:,2))), fsds_vis_dif_frac, fsds_nir_dif_frac, ssno(1,2), ssno(2,2)) + +!----------------------------------------------------------------------- + + END SUBROUTINE albland_HiRes + + + SUBROUTINE twostream ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! calculation of canopy albedos via two stream approximation (direct +! and diffuse ) and partition of incident solar +! +! Original author: Yongjiu Dai, June 11, 2001 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +! parameters + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(2,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- local ----------------------------------- + real(r8) :: & + lsai, &! lai+sai + sai_, &! sai=0 for USGS, no stem + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup(2,2), &! (integral of i_up*exp(-kx) ) + edown(2,2) ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band iterator + +!----------------------------------------------------------------------- +! projected area of phytoelements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + proj = phi1 + phi2 * coszen + extkb = proj / coszen + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSE IF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSE IF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + +#if(defined LULC_USGS) + ! yuan: to be consistance with CoLM2014, no stem considered + ! for twostream and leaf optical property calculations + sai_ = 0. +#else + sai_ = sai +#endif + + lsai = lai + sai_ + power3 = (lai+sai) / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + IF (lsai <= 1e-6) RETURN + + DO iw = 1, 2 ! WAVE_BAND_LOOP + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! account for stem optical property effects + scat = lai/lsai * ( tau(iw,1) + rho(iw,1) ) & + + sai_/lsai * ( tau(iw,2) + rho(iw,2) ) + + as = scat / 2. * proj / ( proj + coszen * phi2 ) + as = as * ( 1. - coszen * phi1 / ( proj + coszen * phi2 ) * & + log ( ( proj + coszen * phi2 + coszen * phi1 ) / ( coszen * phi1 ) ) ) + +! account for stem optical property effects + !TODO-done: betao -> beta0 + upscat = lai/lsai*tau(iw,1) + sai_/lsai*tau(iw,2) + ! 09/12/2014, yuan: a bug, change 1. - chil -> 1. + chil + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albg(iw,2)*p1/ce + f2 = 1. - albg(iw,2)*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albg(iw,1) - ( hh1 - albg(iw,2) * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = hh1 + hh2 + hh3 + tran(iw,1) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup(iw,1) = hh1 * (1. - s2*s2) / (2.*extkb) & + + hh2 * (1. - s1*s2) / (extkb + psi) & + + hh3 * (1. - s2/s1) / (extkb - psi) + + edown(iw,1) = hh4 * (1. - s2*s2) / (2.*extkb) & + + hh5 * (1. - s1*s2) / (extkb + psi) & + + hh6 * (1. - s2/s1) / (extkb - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (2.*extkb) ) * s2 & + + albg(iw,2) / ce * ( - h1 / (2.*extkb) / zmu2 * & + ( p3*lsai + p4 / (2.*extkb) ) - de ) * s2 & + + albg(iw,1) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / (4.*extkb*extkb) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = - h1 / (2.*extkb*zmu2) + hh2 + hh3 + tran(iw,1) = 1./ce * ( -h1/(2.*extkb*zmu2) * (p3*lsai + p4/(2.*extkb)) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup(iw,1) = (hh2 - h1/(2.*extkb*zmu2)) * (1. - s2*s2) / (2.*extkb) & + + hh3 * (lsai - 0.) & + + h1/(2.*extkb*zmu2) * ( lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + edown(iw,1) = (hh5 - (h1*p4/(4.*extkb*extkb*zmu) + de)/ce) * (1. - s2*s2)/(2.*extkb) & + + hh6 * (lsai - 0.) & + + h1*p3/(ce*4.*extkb*extkb*zmu2) * (lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + ENDIF + + ssun(iw,1) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup(iw,1) + edown(iw,1)) ) + ssha(iw,1) = scat * (1.-s2) & + + ( albg(iw,2)*tran(iw,1) + albg(iw,1)*s2 - tran(iw,1) ) - albv(iw,1) & + - ( 1. - scat ) / zmu * ( eup(iw,1) + edown(iw,1) ) + +!----------------------------------------------------------------------- +! calculation of diffuse albedos and canopy transmittances +! albv(iw,2) ( i-up ) +! tran(iw,2) ( i-down ) +!----------------------------------------------------------------------- + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = 0. + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1. + + hh7 = -m2 / (m1*n2 - m2*n1) + hh8 = -m1 / (m2*n1 - m1*n2) + + hh9 = hh7 * p1 / ce + hh10 = hh8 * p2 / ce + + albv(iw,2) = hh7 + hh8 + tran(iw,2) = hh9 * s1 + hh10 / s1 + + IF (abs(sigma) .gt. 1.e-10) THEN + eup(iw,2) = hh7 * (1. - s1*s2) / (extkb + psi) & + + hh8 * (1. - s2/s1) / (extkb - psi) + edown(iw,2) = hh9 * (1. - s1*s2) / (extkb + psi) & + + hh10 * (1. - s2/s1) / (extkb - psi) + ELSE + eup(iw,2) = hh7 * (1. - s1*s2) / ( extkb + psi) + hh8 * (lsai - 0.) + edown(iw,2) = hh9 * (1. - s1*s2) / ( extkb + psi) + hh10 * (lsai - 0.) + ENDIF + + ssun(iw,2) = (1.-scat) / zmu * (eup(iw,2) + edown(iw,2)) + ssha(iw,2) = tran(iw,2) * ( albg(iw,2) -1. ) - ( albv(iw,2) - 1. ) & + - ( 1. - scat ) / zmu * ( eup(iw,2) + edown(iw,2) ) + + ENDDO ! WAVE_BAND_LOOP + +! 03/06/2020, yuan: add direct transmittance (s2) to +! tran for incident direct case +! 03/14/2020, yuan: save direct T to 3rd position of tran + tran(:,3) = s2 + + END SUBROUTINE twostream + + SUBROUTINE twostream_hires ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! calculation of canopy albedos via two stream approximation (direct +! and diffuse ) and partition of incident solar +! +! Original author: Yongjiu Dai, June 11, 2001 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +! parameters + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(211,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(211,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(211,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(211,2), &! albedo, vegetation [-] + tran(211,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(211,2), &! sunlit canopy absorption for solar radiation + ssha(211,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- local ----------------------------------- + real(r8) :: & + lsai, &! lai+sai + sai_, &! sai=0 for USGS, no stem + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup(211,2), &! (integral of i_up*exp(-kx) ) + edown(211,2) ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band iterator + +!----------------------------------------------------------------------- +! projected area of phytoelements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + proj = phi1 + phi2 * coszen + extkb = proj / coszen + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSE IF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSE IF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + +#if(defined LULC_USGS) + ! yuan: to be consistance with CoLM2014, no stem considered + ! for twostream and leaf optical property calculations + sai_ = 0. +#else + sai_ = sai +#endif + + lsai = lai + sai_ + power3 = (lai+sai) / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + IF (lsai <= 1e-6) RETURN + + DO iw = 1, 211 ! WAVE_BAND_LOOP ! loop from 1 to 211 + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! account for stem optical property effects + scat = lai/lsai * ( tau(iw,1) + rho(iw,1) ) & + + sai_/lsai * ( tau(iw,2) + rho(iw,2) ) + + as = scat / 2. * proj / ( proj + coszen * phi2 ) + as = as * ( 1. - coszen * phi1 / ( proj + coszen * phi2 ) * & + log ( ( proj + coszen * phi2 + coszen * phi1 ) / ( coszen * phi1 ) ) ) + +! account for stem optical property effects + !TODO-done: betao -> beta0 + upscat = lai/lsai*tau(iw,1) + sai_/lsai*tau(iw,2) + ! 09/12/2014, yuan: a bug, change 1. - chil -> 1. + chil + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albg(iw,2)*p1/ce + f2 = 1. - albg(iw,2)*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albg(iw,1) - ( hh1 - albg(iw,2) * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = hh1 + hh2 + hh3 + tran(iw,1) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup(iw,1) = hh1 * (1. - s2*s2) / (2.*extkb) & + + hh2 * (1. - s1*s2) / (extkb + psi) & + + hh3 * (1. - s2/s1) / (extkb - psi) + + edown(iw,1) = hh4 * (1. - s2*s2) / (2.*extkb) & + + hh5 * (1. - s1*s2) / (extkb + psi) & + + hh6 * (1. - s2/s1) / (extkb - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (2.*extkb) ) * s2 & + + albg(iw,2) / ce * ( - h1 / (2.*extkb) / zmu2 * & + ( p3*lsai + p4 / (2.*extkb) ) - de ) * s2 & + + albg(iw,1) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / (4.*extkb*extkb) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,1) = - h1 / (2.*extkb*zmu2) + hh2 + hh3 + tran(iw,1) = 1./ce * ( -h1/(2.*extkb*zmu2) * (p3*lsai + p4/(2.*extkb)) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup(iw,1) = (hh2 - h1/(2.*extkb*zmu2)) * (1. - s2*s2) / (2.*extkb) & + + hh3 * (lsai - 0.) & + + h1/(2.*extkb*zmu2) * ( lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + edown(iw,1) = (hh5 - (h1*p4/(4.*extkb*extkb*zmu) + de)/ce) * (1. - s2*s2)/(2.*extkb) & + + hh6 * (lsai - 0.) & + + h1*p3/(ce*4.*extkb*extkb*zmu2) * (lsai*s2*s2 - (1. - s2*s2)/(2.*extkb) ) + + ENDIF + + ssun(iw,1) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup(iw,1) + edown(iw,1)) ) + ssha(iw,1) = scat * (1.-s2) & + + ( albg(iw,2)*tran(iw,1) + albg(iw,1)*s2 - tran(iw,1) ) - albv(iw,1) & + - ( 1. - scat ) / zmu * ( eup(iw,1) + edown(iw,1) ) + +!----------------------------------------------------------------------- +! calculation of diffuse albedos and canopy transmittances +! albv(iw,2) ( i-up ) +! tran(iw,2) ( i-down ) +!----------------------------------------------------------------------- + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = 0. + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1. + + hh7 = -m2 / (m1*n2 - m2*n1) + hh8 = -m1 / (m2*n1 - m1*n2) + + hh9 = hh7 * p1 / ce + hh10 = hh8 * p2 / ce + + albv(iw,2) = hh7 + hh8 + tran(iw,2) = hh9 * s1 + hh10 / s1 + + IF (abs(sigma) .gt. 1.e-10) THEN + eup(iw,2) = hh7 * (1. - s1*s2) / (extkb + psi) & + + hh8 * (1. - s2/s1) / (extkb - psi) + edown(iw,2) = hh9 * (1. - s1*s2) / (extkb + psi) & + + hh10 * (1. - s2/s1) / (extkb - psi) + ELSE + eup(iw,2) = hh7 * (1. - s1*s2) / ( extkb + psi) + hh8 * (lsai - 0.) + edown(iw,2) = hh9 * (1. - s1*s2) / ( extkb + psi) + hh10 * (lsai - 0.) + ENDIF + + ssun(iw,2) = (1.-scat) / zmu * (eup(iw,2) + edown(iw,2)) + ssha(iw,2) = tran(iw,2) * ( albg(iw,2) -1. ) - ( albv(iw,2) - 1. ) & + - ( 1. - scat ) / zmu * ( eup(iw,2) + edown(iw,2) ) + + ENDDO ! WAVE_BAND_LOOP + +! 03/06/2020, yuan: add direct transmittance (s2) to +! tran for incident direct case +! 03/14/2020, yuan: save direct T to 3rd position of tran + tran(:,3) = s2 + + END SUBROUTINE twostream_hires + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE twostream_mod ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! An improved two stream approximation +! +! Original author: Yongjiu Dai, June 11, 2001 +! Hua Yuan, 03/2020 +! +! REFERENCES: +! 1) Yuan, H., Dai, Y., Dickinson, R. E., Pinty, B., Shangguan, W., Zhang, S., +! et al. (2017). Reexamination and further development of two-stream canopy +! radiative transfer models for global land modeling. Journal of Advances in +! Modeling Earth Systems, 9(1), 113–129. https://doi.org/10.1002/2016MS000773 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +! parameters + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(2,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- local ----------------------------------- + real(r8) :: & + lsai, &! lai+sai + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup, &! (integral of i_up*exp(-kx) ) + edw ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + + integer iw ! band loop index + integer ic ! direct/diffuse loop index + + ! variables for modified version + real(r8) :: cosz, theta, cosdif, albgblk + real(r8) :: tmptau, wrho, wtau + real(r8) :: s2d, extkbd, sall(2,2), q, ssun_rev + +!----------------------------------------------------------------------- +! projected area of phytoelements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSE IF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSE IF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + + lsai = lai + sai + power3 = lsai / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + tmptau = 0.5_r8 * lsai + cosdif = - tmptau / log(exp(-0.87_r8*tmptau) / (1+0.92_r8*tmptau)) + + ! black ground case + albgblk = 1.e-6_r8 + + DO iw = 1, 2 ! WAVE_BAND_LOOP + + ! ic 1: incident direct; 2: incident diffuse + DO ic = 1, 2 + + IF (ic == 2) THEN + cosz = max(0.001_r8, cosdif) + theta = acos(cosz) + theta = theta/3.14159*180 + + theta = theta + chil*5._r8 + cosz = cos(theta/180*3.14159) + ELSE + cosz = coszen + ENDIF + + proj = phi1 + phi2 * cosz + extkb = proj / cosz + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! + stem optical properties + wtau = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + wrho = lai/lsai*rho(iw,1) + sai/lsai*rho(iw,2) + + scat = wtau + wrho + + as = scat / 2. * proj / ( proj + cosz * phi2 ) + as = as * ( 1. - cosz * phi1 / ( proj + cosz * phi2 ) * & + log ( ( proj + cosz * phi2 + cosz * phi1 ) / ( cosz * phi1 ) ) ) + +! + stem optical properties + ! scat ~ omega + ! upscat ~ betail*scat + ! beta0 ~ betadl + ! scat-2.*upscat ~ rho - tau + upscat = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + + ! [MODI 1] + beta0 = 0.5_r8 * ( scat + 1._r8/extkb*(1._r8+chil)**2/4._r8*(wrho-wtau) )/scat + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno(iw) + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno(iw)*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno(iw)*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albgblk*p1/ce + f2 = 1. - albgblk*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (ic == 1) THEN + s2d = s2 + extkbd = extkb + ENDIF + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albgblk - ( hh1 - albgblk * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = hh1 + hh2 + hh3 + tran(iw,ic) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup = hh1 * (1. - s2*s2d) / (extkbd + extkb) & + + hh2 * (1. - s2d*s1) / (extkbd + psi) & + + hh3 * (1. - s2d/s1) / (extkbd - psi) + + edw = hh4 * (1. - s2*s2d) / (extkbd + extkb) & + + hh5 * (1. - s2d*s1) / (extkbd + psi) & + + hh6 * (1. - s2d/s1) / (extkbd - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (extkb+extkbd) ) * s2 & + + albgblk / ce * ( - h1 / (extkb+extkbd) / zmu2 * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + albgblk * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / ((extkb+extkbd)*(extkb+extkbd)) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = - h1 / ((extkb+extkbd)*zmu2) + hh2 + hh3 + tran(iw,ic) = 1./ce * ( -h1 / ((extkb+extkbd)*zmu2) * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup = (hh2 - h1/((extkb+extkbd)*zmu2)) * (1. - s2*s2d)/(extkb+extkbd) & + + hh3 * (lsai - 0.) & + + h1/((extkb+extkbd)*zmu2) * ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + edw = (hh5 - (h1*p4/((extkb+extkbd)*(extkb+extkbd)*zmu) + de)/ce) * & + (1. - s2*s2d) / (extkb+extkbd) + hh6 * (lsai - 0.) & + + h1*p3/(ce*(extkb+extkbd)*(extkb+extkbd)*zmu2) * & + ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + ENDIF + + sall(iw,ic) = 1. - albv(iw,ic) - (1.-albgblk)*(tran(iw,ic)+s2) + + IF (ic == 1) THEN + ssun(iw,ic) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup + edw) ) + ELSE + ssun(iw,ic) = (1.-scat) * ( extkb*(1.-s2*s2d)/(extkb+extkbd) + 1. / zmu * (eup + edw) ) + ENDIF + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ENDDO ! ic + + ! for reversed diffuse radiation back from ground + eup = hh1 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh2 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh3 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + edw = hh4 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh5 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh6 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + ssun_rev = s2d * (1._r8 - scat) * & + ( extkb*(1._r8-s2/s2d)/(extkb-extkbd) + 1._r8 / zmu * (eup + edw ) ) + + ! ----------------------------------------------------------- + ! consider the multiple reflectance between canopy and ground + ! ----------------------------------------------------------- + + ! common ratio for geometric series + q = albg(iw,2) * albv(iw,2) + + DO ic = 1, 2 ! from 1 to 2, cannot be reversed + + ! ----------------------------------------------------------- + ! re-calculate the absorption, transmission and albedo + ! for direct radiation + +! 03/06/2020, yuan: tran originally meant diffuse flow, now the direct +! transmittance is also included +! 03/14/2020, yuan: treat soil albedo in direct/diffuse cases + IF (ic == 1) THEN + tran(iw,ic) = (s2d*albg(iw,1)*albv(iw,2) + tran(iw,ic)) / (1.-q) + tran(:,3) = s2d + + sall(iw,ic) = sall(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * sall(iw,2) + + albv(iw,ic) = 1. - sall(iw,ic) - & + (1.-albg(iw,2))*tran(iw,ic) - (1.-albg(iw,1))*s2d + + ssun(iw,ic) = ssun(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * ssun_rev + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ELSE + tran(iw,ic) = (s2 + tran(iw,ic)) / (1.-q) + + sall(iw,ic) = sall(iw,ic) + tran(iw,ic)*albg(iw,2)*sall(iw,2) + albv(iw,ic) = 1. - sall(iw,ic) - (1.-albg(iw,2))*tran(iw,ic) + + ssun(iw,ic) = ssun(iw,ic) + tran(iw,ic)*albg(iw,2)*ssun_rev + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + ENDIF + + ENDDO !ic + + End DO !iw + + ! restore extkb + extkb = extkbd + + END SUBROUTINE twostream_mod + + + SUBROUTINE twostream_hires_mod ( chil, rho, tau, green, lai, sai, fwet_snow, & + coszen, albg, albv, tran, thermk, extkb, extkd, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! An improved two stream approximation +! +! Original author: Yongjiu Dai, June 11, 2001 +! Hua Yuan, 03/2020 +! +! REFERENCES: +! 1) Yuan, H., Dai, Y., Dickinson, R. E., Pinty, B., Shangguan, W., Zhang, S., +! et al. (2017). Reexamination and further development of two-stream canopy +! radiative transfer models for global land modeling. Journal of Advances in +! Modeling Earth Systems, 9(1), 113–129. https://doi.org/10.1002/2016MS000773 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_VEG_SNOW + IMPLICIT NONE + +! parameters + real(r8), intent(in) :: & + ! static parameters associated with vegetation type + chil, &! leaf angle distribution factor + rho(211,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(211,2), &! leaf transmittance (iw=iband, il=life and dead) + + ! time-space varying vegetation parameters + green, &! green leaf fraction + lai, &! leaf area index of exposed canopy (snow-free) + sai, &! stem area index + fwet_snow ! vegetation snow fractional cover [-] + +! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(211,2) ! albedos of ground + +! output + real(r8), intent(out) :: & + albv(211,2), &! albedo, vegetation [-] + tran(211,3), &! canopy transmittances for solar radiation + thermk, &! canopy gap fraction for tir radiation + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + ssun(211,2), &! sunlit canopy absorption for solar radiation + ssha(211,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + +!-------------------------- local ----------------------------------- + real(r8) :: & + lsai, &! lai+sai + phi1, &! (phi-1) + phi2, &! (phi-2) + scat, &! (omega) + proj, &! (g(mu)) + zmu, &! (int(mu/g(mu)) + zmu2, &! (zmu * zmu) + as, &! (a-s(mu)) + upscat, &! (omega-beta) + beta0, &! (beta-0) + psi, &! (h) + + be, &! (b) + ce, &! (c) + de, &! (d) + fe, &! (f) + + power1, &! (h*lai) + power2, &! (k*lai) + power3, &! + + sigma, &! + s1, &! + s2, &! + p1, &! + p2, &! + p3, &! + p4, &! + f1, &! + f2, &! + h1, &! + h4, &! + m1, &! + m2, &! + m3, &! + n1, &! + n2, &! + n3, &! + + hh1, &! (h1/sigma) + hh2, &! (h2) + hh3, &! (h3) + hh4, &! (h4/sigma) + hh5, &! (h5) + hh6, &! (h6) + hh7, &! (h7) + hh8, &! (h8) + hh9, &! (h9) + hh10, &! (h10) + + eup, &! (integral of i_up*exp(-kx) ) + edw ! (integral of i_down*exp(-kx) ) + + ! vegetation snow optical properties + real(r8) :: upscat_sno = 0.5 !upscat parameter for snow + real(r8) :: beta0_sno = 0.5 !beta0 parameter for snow + real(r8) :: scat_sno(2) !snow single scattering albedo + data scat_sno(1), scat_sno(2) /0.8, 0.4/ ! 1:vis, 2: nir + real(r8) :: scat_sno_tmp + + integer iw ! band loop index + integer ic ! direct/diffuse loop index + + ! variables for modified version + real(r8) :: cosz, theta, cosdif, albgblk + real(r8) :: tmptau, wrho, wtau + real(r8) :: s2d, extkbd, sall(211,2), q, ssun_rev + +!----------------------------------------------------------------------- +! projected area of phytoelements in direction of mu and +! average inverse diffuse optical depth per unit leaf area + + phi1 = 0.5 - 0.633 * chil - 0.33 * chil * chil + phi2 = 0.877 * ( 1. - 2. * phi1 ) + + extkd = 0.719 + + IF (abs(phi1).gt.1.e-6 .and. abs(phi2).gt.1.e-6) THEN + zmu = 1. / phi2 * ( 1. - phi1 / phi2 * log ( ( phi1 + phi2 ) / phi1 ) ) + ELSE IF (abs(phi1).le.1.e-6) THEN + zmu = 1./0.877 + ELSE IF (abs(phi2).le.1.e-6) THEN + zmu = 1./(2.*phi1) + ENDIF + zmu2 = zmu * zmu + + lsai = lai + sai + power3 = lsai / zmu + power3 = min( 50., power3 ) + power3 = max( 1.e-5, power3 ) + thermk = exp(-power3) + + tmptau = 0.5_r8 * lsai + cosdif = - tmptau / log(exp(-0.87_r8*tmptau) / (1+0.92_r8*tmptau)) + + ! black ground case + albgblk = 1.e-6_r8 + + DO iw = 1, 211 ! WAVE_BAND_LOOP + + ! ic 1: incident direct; 2: incident diffuse + DO ic = 1, 2 + + IF (ic == 2) THEN + cosz = max(0.001_r8, cosdif) + theta = acos(cosz) + theta = theta/3.14159*180 + + theta = theta + chil*5._r8 + cosz = cos(theta/180*3.14159) + ELSE + cosz = coszen + ENDIF + + proj = phi1 + phi2 * cosz + extkb = proj / cosz + +!----------------------------------------------------------------------- +! calculate average scattering coefficient, leaf projection and +! other coefficients for two-stream model. +!----------------------------------------------------------------------- + +! + stem optical properties + wtau = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + wrho = lai/lsai*rho(iw,1) + sai/lsai*rho(iw,2) + + scat = wtau + wrho + + as = scat / 2. * proj / ( proj + cosz * phi2 ) + as = as * ( 1. - cosz * phi1 / ( proj + cosz * phi2 ) * & + log ( ( proj + cosz * phi2 + cosz * phi1 ) / ( cosz * phi1 ) ) ) + +! + stem optical properties + ! scat ~ omega + ! upscat ~ betail*scat + ! beta0 ~ betadl + ! scat-2.*upscat ~ rho - tau + upscat = lai/lsai*tau(iw,1) + sai/lsai*tau(iw,2) + upscat = 0.5 * ( scat + (scat - 2.*upscat) * ((1. + chil) / 2.) ** 2 ) + beta0 = ( 1. + zmu * extkb ) / ( scat * zmu * extkb ) * as + + ! [MODI 1] + beta0 = 0.5_r8 * ( scat + 1._r8/extkb*(1._r8+chil)**2/4._r8*(wrho-wtau) )/scat + +! account for snow on vegetation + ! modify scat, upscat and beta0 + ! USE: fwet_snow, snow properties, scatter vis0.8, nir0.4, upscat0.5, beta0.5 + IF ( DEF_VEG_SNOW ) THEN + if (iw < 30) then + scat_sno_tmp = scat_sno(1) + else + scat_sno_tmp = scat_sno(2) + end if + scat = (1.-fwet_snow)*scat + fwet_snow*scat_sno_tmp + upscat = ( (1.-fwet_snow)*scat*upscat + fwet_snow*scat_sno_tmp*upscat_sno ) / scat + beta0 = ( (1.-fwet_snow)*scat*beta0 + fwet_snow*scat_sno_tmp*beta0_sno ) / scat + ENDIF + +!----------------------------------------------------------------------- +! intermediate variables identified in appendix of SE-85. +!----------------------------------------------------------------------- + + be = 1. - scat + upscat + ce = upscat + de = scat * zmu * extkb * beta0 + fe = scat * zmu * extkb * ( 1. - beta0 ) + + psi = sqrt(be**2 - ce**2)/zmu + power1 = min( psi*lsai, 50. ) + power2 = min( extkb*lsai, 50. ) + s1 = exp( - power1 ) + s2 = exp( - power2 ) + +!----------------------------------------------------------------------- +! calculation of direct albedos and canopy transmittances. +! albv(iw,1) ( i-up ) +! tran(iw,irad) ( i-down ) +!----------------------------------------------------------------------- + + p1 = be + zmu * psi + p2 = be - zmu * psi + p3 = be + zmu * extkb + p4 = be - zmu * extkb + + f1 = 1. - albgblk*p1/ce + f2 = 1. - albgblk*p2/ce + + h1 = - ( de * p4 + ce * fe ) + h4 = - ( fe * p3 + ce * de ) + + sigma = ( zmu * extkb ) ** 2 + ( ce**2 - be**2 ) + + IF (ic == 1) THEN + s2d = s2 + extkbd = extkb + ENDIF + + IF (abs(sigma) .gt. 1.e-10) THEN + + hh1 = h1 / sigma + hh4 = h4 / sigma + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = ( albgblk - ( hh1 - albgblk * hh4 ) ) * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = - hh4 + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = hh1 + hh2 + hh3 + tran(iw,ic) = hh4 * s2 + hh5 * s1 + hh6 / s1 + + eup = hh1 * (1. - s2*s2d) / (extkbd + extkb) & + + hh2 * (1. - s2d*s1) / (extkbd + psi) & + + hh3 * (1. - s2d/s1) / (extkbd - psi) + + edw = hh4 * (1. - s2*s2d) / (extkbd + extkb) & + + hh5 * (1. - s2d*s1) / (extkbd + psi) & + + hh6 * (1. - s2d/s1) / (extkbd - psi) + + ELSE + + m1 = f1 * s1 + m2 = f2 / s1 + m3 = h1 / zmu2 * ( lsai + 1. / (extkb+extkbd) ) * s2 & + + albgblk / ce * ( - h1 / (extkb+extkbd) / zmu2 * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + albgblk * s2 + + n1 = p1 / ce + n2 = p2 / ce + n3 = 1./ce * ( h1*p4 / ((extkb+extkbd)*(extkb+extkbd)) / zmu2 + de) + + hh2 = (m3*n2 - m2*n3) / (m1*n2 - m2*n1) + hh3 = (m3*n1 - m1*n3) / (m2*n1 - m1*n2) + + hh5 = hh2 * p1 / ce + hh6 = hh3 * p2 / ce + + albv(iw,ic) = - h1 / ((extkb+extkbd)*zmu2) + hh2 + hh3 + tran(iw,ic) = 1./ce * ( -h1 / ((extkb+extkbd)*zmu2) * & + ( p3*lsai + p4 / (extkb+extkbd) ) - de ) * s2 & + + hh5 * s1 + hh6 / s1 + + eup = (hh2 - h1/((extkb+extkbd)*zmu2)) * (1. - s2*s2d)/(extkb+extkbd) & + + hh3 * (lsai - 0.) & + + h1/((extkb+extkbd)*zmu2) * ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + edw = (hh5 - (h1*p4/((extkb+extkbd)*(extkb+extkbd)*zmu) + de)/ce) * & + (1. - s2*s2d) / (extkb+extkbd) + hh6 * (lsai - 0.) & + + h1*p3/(ce*(extkb+extkbd)*(extkb+extkbd)*zmu2) * & + ( lsai*s2*s2d - (1. - s2*s2d)/(extkb+extkbd) ) + + ENDIF + + sall(iw,ic) = 1. - albv(iw,ic) - (1.-albgblk)*(tran(iw,ic)+s2) + + IF (ic == 1) THEN + ssun(iw,ic) = (1.-scat) * ( 1.-s2 + 1. / zmu * (eup + edw) ) + ELSE + ssun(iw,ic) = (1.-scat) * ( extkb*(1.-s2*s2d)/(extkb+extkbd) + 1. / zmu * (eup + edw) ) + ENDIF + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ENDDO ! ic + + ! for reversed diffuse radiation back from ground + eup = hh1 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh2 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh3 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + edw = hh4 * (1._r8 - s2/s2d) / (extkb - extkbd) & + + hh5 * (1._r8 - s1/s2d) / (psi - extkbd) & + + hh6 * (1._r8/s1/s2d - 1._r8) / (psi + extkbd) + + ssun_rev = s2d * (1._r8 - scat) * & + ( extkb*(1._r8-s2/s2d)/(extkb-extkbd) + 1._r8 / zmu * (eup + edw ) ) + + ! ----------------------------------------------------------- + ! consider the multiple reflectance between canopy and ground + ! ----------------------------------------------------------- + + ! common ratio for geometric series + q = albg(iw,2) * albv(iw,2) + + DO ic = 1, 2 ! from 1 to 2, cannot be reversed + + ! ----------------------------------------------------------- + ! re-calculate the absorption, transmission and albedo + ! for direct radiation + +! 03/06/2020, yuan: tran originally meant diffuse flow, now the direct +! transmittance is also included +! 03/14/2020, yuan: treat soil albedo in direct/diffuse cases + IF (ic == 1) THEN + tran(iw,ic) = (s2d*albg(iw,1)*albv(iw,2) + tran(iw,ic)) / (1.-q) + tran(:,3) = s2d + + sall(iw,ic) = sall(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * sall(iw,2) + + albv(iw,ic) = 1. - sall(iw,ic) - & + (1.-albg(iw,2))*tran(iw,ic) - (1.-albg(iw,1))*s2d + + ssun(iw,ic) = ssun(iw,ic) + & + (tran(iw,ic)*albg(iw,2) + s2d*albg(iw,1)) * ssun_rev + + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + + ELSE + tran(iw,ic) = (s2 + tran(iw,ic)) / (1.-q) + + sall(iw,ic) = sall(iw,ic) + tran(iw,ic)*albg(iw,2)*sall(iw,2) + albv(iw,ic) = 1. - sall(iw,ic) - (1.-albg(iw,2))*tran(iw,ic) + + ssun(iw,ic) = ssun(iw,ic) + tran(iw,ic)*albg(iw,2)*ssun_rev + ssha(iw,ic) = sall(iw,ic) - ssun(iw,ic) + ENDIF + + ENDDO !ic + + End DO !iw + + ! restore extkb + extkb = extkbd + + END SUBROUTINE twostream_hires_mod +#endif + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE twostream_wrap ( ipatch, coszen, albg, & + albv, tran, ssun, ssha ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! A Wrap subroutine to calculate PFT radiation using two-stream model +! +! Created by Hua Yuan, 03/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Const_PFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + IMPLICIT NONE + + ! parameters + integer, intent(in) :: & + ipatch ! patch index + + ! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(2,2) ! albedos of ground + + ! output + real(r8), intent(out) :: & + albv(2,2), &! albedo, vegetation [-] + tran(2,3), &! canopy transmittances for solar radiation + ssun(2,2), &! sunlit canopy absorption for solar radiation + ssha(2,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + + integer :: i, p, ps, pe + real(r8), allocatable :: tran_p(:,:,:) + real(r8), allocatable :: albv_p(:,:,:) + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + allocate ( tran_p (2,3,ps:pe) ) + allocate ( albv_p (2,2,ps:pe) ) + + DO i = ps, pe + p = pftclass(i) + IF (lai_p(i)+sai_p(i) > 1.e-6) THEN + CALL twostream_mod (chil_p(p),rho_p(:,:,p),tau_p(:,:,p),1.,lai_p(i),sai_p(i),& + fwet_snow_p(i),coszen,albg,albv_p(:,:,i),tran_p(:,:,i),thermk_p(i),& + extkb_p(i),extkd_p(i),ssun_p(:,:,i),ssha_p(:,:,i)) + ELSE + albv_p(:,:,i) = albg(:,:) + ssun_p(:,:,i) = 0. + ssha_p(:,:,i) = 0. + tran_p(:,1,i) = 0. + tran_p(:,2,i) = 1. + tran_p(:,3,i) = 1. + ENDIF + ENDDO + + albv(1,1) = sum( albv_p(1,1,ps:pe)*pftfrac(ps:pe) ) + albv(1,2) = sum( albv_p(1,2,ps:pe)*pftfrac(ps:pe) ) + albv(2,1) = sum( albv_p(2,1,ps:pe)*pftfrac(ps:pe) ) + albv(2,2) = sum( albv_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssun(1,1) = sum( ssun_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + tran(1,1) = sum( tran_p(1,1,ps:pe)*pftfrac(ps:pe) ) + tran(1,2) = sum( tran_p(1,2,ps:pe)*pftfrac(ps:pe) ) + tran(1,3) = sum( tran_p(1,3,ps:pe)*pftfrac(ps:pe) ) + tran(2,1) = sum( tran_p(2,1,ps:pe)*pftfrac(ps:pe) ) + tran(2,2) = sum( tran_p(2,2,ps:pe)*pftfrac(ps:pe) ) + tran(2,3) = sum( tran_p(2,3,ps:pe)*pftfrac(ps:pe) ) + + !NOTE: fordebug only below + IF (ssun(1,1)<0 .or. ssun(1,2)<0 .or. ssun(2,1)<0 .or. ssun(2,2)<0) THEN + print *, 'Warning:negative albedo',ipatch + print *, ssun + ENDIF + + deallocate ( tran_p ) + deallocate ( albv_p ) + + END SUBROUTINE twostream_wrap + + SUBROUTINE twostream_hires_wrap ( ipatch, coszen, albg, & + albv, tran, ssun, ssha, & + reflectance, transmittance ,& + fsds_vis_dir_frac, fsds_nir_dir_frac,& + fsds_vis_dif_frac, fsds_nir_dif_frac,& + ssw, reflectance_out, transmittance_out, doy ) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! A Wrap subroutine to calculate PFT radiation using two-stream model +! +! Created by Hua Yuan, 03/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Const_PFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_HighRes_Parameters , only: update_params_PROSPECT!, satellite_PROSPECT + USE MOD_Namelist, only: DEF_HighResVeg, DEF_PROSPECT!, DEF_Satellite_Params + + IMPLICIT NONE + + ! parameters + integer, intent(in) :: & + ipatch, &! patch index + doy + + ! environmental variables + real(r8), intent(in) :: & + coszen, &! consine of solar zenith angle + albg(211,2) ! albedos of ground + + ! high resolution optical properties + real(r8), intent(in) :: & + reflectance (0:15,211,2), &! leaf reflectance + transmittance(0:15,211,2), &! leaf transmittance + fsds_vis_dir_frac(29 ) ,& + fsds_nir_dir_frac(182) ,& + fsds_vis_dif_frac(29 ) ,& + fsds_nir_dif_frac(182) ,& + ssw + + ! output + real(r8), intent(out) :: & + albv(211,2), &! albedo, vegetation [-] + tran(211,3), &! canopy transmittances for solar radiation + ssun(211,2), &! sunlit canopy absorption for solar radiation + ssha(211,2) ! shaded canopy absorption for solar radiation, + ! normalized by the incident flux + + real(r8), intent(inout) :: & + reflectance_out (211,0:15), &! leaf reflectance + transmittance_out(211,0:15) ! leaf transmittance + + integer :: i, p, ps, pe, iwl + real(r8) :: reflectance_p (211, 2) + real(r8) :: transmittance_p(211, 2) + + real(r8), allocatable :: tran_p(:,:,:) + real(r8), allocatable :: albv_p(:,:,:) + + real(r8) :: rho_hires(211), tau_hires(211) + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + allocate ( tran_p (211,3,ps:pe) ) + allocate ( albv_p (211,2,ps:pe) ) + + DO i = ps, pe + p = pftclass(i) + IF (lai_p(i)+sai_p(i) > 1.e-6) THEN + + ! IF use PROSPECT, update the high resolution optical properties + ! IF ( DEF_PROSPECT .AND. DEF_Satellite_Params ) THEN + ! CALL satellite_PROSPECT(p, reflectance, transmittance ,& + ! reflectance_p, transmittance_p,& + ! ssw, doy) + ! ELSE IF ( DEF_PROSPECT ) THEN + IF ( DEF_PROSPECT ) THEN + CALL update_params_PROSPECT(p, reflectance, transmittance ,& + reflectance_p, transmittance_p,& + ssw) + ELSE + reflectance_p = reflectance (p,:,:) + transmittance_p = transmittance(p,:,:) + ENDIF + + reflectance_out (:,p) = reflectance_p (:,1) + transmittance_out(:,p) = transmittance_p(:,1) + + CALL twostream_hires_mod (chil_p(p),reflectance_p,transmittance_p,1.,lai_p(i),sai_p(i),& + fwet_snow_p(i),coszen,albg,albv_p(:,:,i),tran_p(:,:,i),thermk_p(i),& + extkb_p(i),extkd_p(i),ssun_hires_p(:,:,i),ssha_hires_p(:,:,i)) + + CALL calculate_wgt_variable(ssun_hires_p(:,1,i), fsds_vis_dir_frac, fsds_nir_dir_frac, ssun_p(1,1,i), ssun_p(2,1,i)) + CALL calculate_wgt_variable(ssun_hires_p(:,2,i), fsds_vis_dif_frac, fsds_nir_dif_frac, ssun_p(1,2,i), ssun_p(2,2,i)) + + CALL calculate_wgt_variable(ssha_hires_p(:,1,i), fsds_vis_dir_frac, fsds_nir_dir_frac, ssha_p(1,1,i), ssha_p(2,1,i)) + CALL calculate_wgt_variable(ssha_hires_p(:,2,i), fsds_vis_dif_frac, fsds_nir_dif_frac, ssha_p(1,2,i), ssha_p(2,2,i)) + + ELSE + albv_p(:,:,i) = albg(:,:) + + ssun_hires_p(:,:,i) = 0. + ssha_hires_p(:,:,i) = 0. + + ssun_p(:,:,i) = 0. + ssha_p(:,:,i) = 0. + tran_p(:,1,i) = 0. + tran_p(:,2,i) = 1. + tran_p(:,3,i) = 1. + ENDIF + ENDDO + + DO iwl = 1, 211 + albv(iwl,1) = SUM( albv_p(iwl,1,ps:pe)*pftfrac(ps:pe) ) + albv(iwl,2) = SUM( albv_p(iwl,2,ps:pe)*pftfrac(ps:pe) ) + + ssun(iwl,1) = sum( ssun_hires_p(iwl,1,ps:pe)*pftfrac(ps:pe) ) + ssun(iwl,2) = sum( ssun_hires_p(iwl,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(iwl,1) = sum( ssha_hires_p(iwl,1,ps:pe)*pftfrac(ps:pe) ) + ssha(iwl,2) = sum( ssha_hires_p(iwl,2,ps:pe)*pftfrac(ps:pe) ) + + tran(iwl,1) = sum( tran_p(iwl,1,ps:pe)*pftfrac(ps:pe) ) + tran(iwl,2) = sum( tran_p(iwl,2,ps:pe)*pftfrac(ps:pe) ) + tran(iwl,3) = sum( tran_p(iwl,3,ps:pe)*pftfrac(ps:pe) ) + END DO + + !NOTE: fordebug only below + IF ( ANY(ssun < 0) ) THEN + print *, 'Warning:negative albedo',ipatch + print *, ssun + ENDIF + + deallocate ( tran_p ) + deallocate ( albv_p ) + + END SUBROUTINE twostream_hires_wrap +#endif + + + SUBROUTINE snowage ( deltim,tg,scv,scvold,sag ) + +!======================================================================= +! Original version: Robert Dickinson +! Update snow cover and snow age, based on BATS code +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only : tfrz + IMPLICIT NONE + +!-------------------------- Dummy Argument ----------------------------- + + real(r8), intent(in) :: deltim ! seconds in a time step [second] + real(r8), intent(in) :: tg ! temperature of soil at surface [K] + real(r8), intent(in) :: scv ! snow cover, water equivalent [mm] + real(r8), intent(in) :: scvold ! snow cover for previous time step [mm] + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + +!-------------------------- Local variables ---------------------------- + + real(r8) :: age1 ! snow aging factor due to crystal growth [-] + real(r8) :: age2 ! snow aging factor due to surface growth [-] + real(r8) :: age3 ! snow aging factor due to accum of other particles [-] + real(r8) :: arg ! temporary variable used in snow age calculation [-] + real(r8) :: arg2 ! temporary variable used in snow age calculation [-] + real(r8) :: dela ! temporary variable used in snow age calculation [-] + real(r8) :: dels ! temporary variable used in snow age calculation [-] + real(r8) :: sge ! temporary variable used in snow age calculation [-] + +!----------------------------------------------------------------------- + IF(scv <= 0.) THEN + sag = 0. +! +! Over antarctica +! + ELSE IF (scv > 800.) THEN + sag = 0. +! +! Away from antarctica +! + ELSE + age3 = 0.3 + arg = 5.e3*(1./tfrz-1./tg) + arg2 = min(0.,10.*arg) + age2 = exp(arg2) + age1 = exp(arg) + dela = 1.e-6*deltim*(age1+age2+age3) + dels = 0.1*max(0.0,scv-scvold) + sge = (sag+dela)*(1.0-dels) + sag = max(0.0,sge) + ENDIF + + END SUBROUTINE snowage + + + SUBROUTINE SnowAlbedo( use_snicar_frc,use_snicar_ad ,coszen_col ,& + albsod ,albsoi ,snl ,frac_sno ,& + h2osno ,h2osno_liq ,h2osno_ice ,snw_rds ,& + + mss_cnc_bcphi ,mss_cnc_bcpho ,mss_cnc_ocphi ,mss_cnc_ocpho ,& + mss_cnc_dst1 ,mss_cnc_dst2 ,mss_cnc_dst3 ,mss_cnc_dst4 ,& + + albgrd ,albgri ,albgrd_pur ,albgri_pur ,& + albgrd_bc ,albgri_bc ,albgrd_oc ,albgri_oc ,& + albgrd_dst ,albgri_dst ,flx_absdv ,flx_absdn ,& + flx_absiv ,flx_absin ,dir_frac ,dif_frac ) + + ! !DESCRIPTION: + ! The calling sequence is: + ! -> SNICAR_RT: snow albedos: direct beam (SNICAR) + ! or + ! SNICAR_AD_RT: snow albedos: direct beam (SNICAR-AD) + ! -> SNICAR_RT: snow albedos: diffuse (SNICAR) + ! or + ! SNICAR_AD_RT: snow albedos: diffuse (SNICAR-AD) + ! + ! ORIGINAL: + ! 1) The Community Land Model version5.0 (CLM5.0) + ! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land Model (ELM v2.0) + ! + ! REFERENCES: + ! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling spectral snow albedo. + ! Geosci. Model Dev., 14, 7673–7704, https://doi.org/10.5194/gmd-14-7673-2021 + ! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land model (version 2.0) + ! and assessing its impacts on snow and surface fluxes over the Tibetan Plateau. + ! Geosci. Model Dev., 16, 75–94, https://doi.org/10.5194/gmd-16-75-2023 + ! + ! REVISIONS: + ! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING + + !----------------------------------------------------------------------- + ! !USES: + USE MOD_Vars_Global, only: maxsnl + USE MOD_SnowSnicar_HiRes, only: SNICAR_RT, SNICAR_AD_RT + + ! and the evolution of snow effective radius + ! + ! DAI, Dec. 28, 2022 + + IMPLICIT NONE + +!------------------------------------------------------------------------- +! temporay setting + + integer, parameter :: numrad = 5 ! number of solar radiation bands: vis, nir + integer, parameter :: numhires = 211 ! number of solar radiation bands: vis, nir + integer, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + logical, parameter :: DO_SNO_OC = .true. ! parameter to include organic carbon (OC) + logical, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations + integer, parameter :: subgridflag = 1 ! = 0 USE subgrid fluxes, = 1 not USE subgrid fluxes + ! + ! !ARGUMENTS: + ! + logical , intent(in) :: use_snicar_frc ! true: IF radiative forcing is being calculated, first estimate clean-snow albedo + logical , intent(in) :: use_snicar_ad ! true: USE SNICAR_AD_RT, false: USE SNICAR_RT + + real(r8), intent(in) :: coszen_col ! cosine of solar zenith angle + real(r8), intent(in) :: albsod ( numhires ) ! direct-beam soil albedo (col,bnd) [frc] + real(r8), intent(in) :: albsoi ( numhires ) ! diffuse soil albedo (col,bnd) [frc] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8), intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + real(r8), intent(in) :: h2osno ! snow water equivalent (mm H2O) + real(r8), intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8), intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice lens content (col,lyr) [kg/m2] + real(r8), intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow grain radius (col,lyr) [microns] + + real(r8), intent(in) :: mss_cnc_bcphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic BC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_bcpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic BC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_ocphi ( maxsnl+1:0 ) ! mass concentration of hydrophilic OC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_ocpho ( maxsnl+1:0 ) ! mass concentration of hydrophobic OC (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst1 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 1 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst2 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst3 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg] + real(r8), intent(in) :: mss_cnc_dst4 ( maxsnl+1:0 ) ! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg] + + real(r8) , intent(in) :: dir_frac ( numhires ) ! + real(r8) , intent(in) :: dif_frac ( numhires ) ! + + real(r8), intent(out) :: albgrd ( numrad ) ! ground albedo (direct) + real(r8), intent(out) :: albgri ( numrad ) ! ground albedo (diffuse) + real(r8), intent(out) :: albgrd_pur ( numrad ) ! pure snow ground albedo (direct) + real(r8), intent(out) :: albgri_pur ( numrad ) ! pure snow ground albedo (diffuse) + real(r8), intent(out) :: albgrd_bc ( numrad ) ! ground albedo without BC (direct) + real(r8), intent(out) :: albgri_bc ( numrad ) ! ground albedo without BC (diffuse) + real(r8), intent(out) :: albgrd_oc ( numrad ) ! ground albedo without OC (direct) + real(r8), intent(out) :: albgri_oc ( numrad ) ! ground albedo without OC (diffuse) + real(r8), intent(out) :: albgrd_dst ( numrad ) ! ground albedo without dust (direct) + real(r8), intent(out) :: albgri_dst ( numrad ) ! ground albedo without dust (diffuse) + real(r8), intent(out) :: flx_absdv ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): VIS [frc] + real(r8), intent(out) :: flx_absdn ( maxsnl+1:1 ) ! direct flux absorption factor (col,lyr): NIR [frc] + real(r8), intent(out) :: flx_absiv ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): VIS [frc] + real(r8), intent(out) :: flx_absin ( maxsnl+1:1 ) ! diffuse flux absorption factor (col,lyr): NIR [frc] + + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + + integer :: i ! index for layers [idx] + integer :: ibnd, start_index, end_index ! index for 5 bands [idx] + integer :: aer ! index for sno_nbr_aer + integer :: ib ! band index + integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse + integer :: flg_slr ! flag for SNICAR (=1 IF direct, =2 IF diffuse) + integer :: flg_snw_ice ! flag for SNICAR (=1 when called from ELM, =2 when called from sea-ice) + + real(r8) :: mss_cnc_aer_in_frc_pur (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for forcing calculation (zero) (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_bc (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for BC forcing (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_oc (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for OC forcing (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_frc_dst (maxsnl+1:0,sno_nbr_aer) ! mass concentration of aerosol species for dust forcing (col,lyr,aer) [kg kg-1] + real(r8) :: mss_cnc_aer_in_fdb (maxsnl+1:0,sno_nbr_aer) ! mass concentration of all aerosol species for feedback calculation (col,lyr,aer) [kg kg-1] + + real(r8) :: albsfc (numrad) ! albedo of surface underneath snow (col,bnd) + real(r8) :: albsnd (numrad) ! snow albedo (direct) + real(r8) :: albsni (numrad) ! snow albedo (diffuse) + real(r8) :: albsnd_pur (numrad) ! direct pure snow albedo (radiative forcing) + real(r8) :: albsni_pur (numrad) ! diffuse pure snow albedo (radiative forcing) + real(r8) :: albsnd_bc (numrad) ! direct snow albedo without BC (radiative forcing) + real(r8) :: albsni_bc (numrad) ! diffuse snow albedo without BC (radiative forcing) + real(r8) :: albsnd_oc (numrad) ! direct snow albedo without OC (radiative forcing) + real(r8) :: albsni_oc (numrad) ! diffuse snow albedo without OC (radiative forcing) + real(r8) :: albsnd_dst (numrad) ! direct snow albedo without dust (radiative forcing) + real(r8) :: albsni_dst (numrad) ! diffuse snow albedo without dust (radiative forcing) + real(r8) :: flx_absd_snw (maxsnl+1:1,numrad) ! flux absorption factor for just snow (direct) [frc] + real(r8) :: flx_absi_snw (maxsnl+1:1,numrad) ! flux absorption factor for just snow (diffuse) [frc] + real(r8) :: foo_snw (maxsnl+1:1,numrad) ! dummy array for forcing calls + + integer :: snw_rds_in (maxsnl+1:0) ! snow grain size sent to SNICAR (col,lyr) [microns] + + integer , parameter :: nband =numrad ! number of solar radiation waveband classes + INTEGER, PARAMETER, DIMENSION(6) :: band_index = (/ & + 1, 30, 60, 80, 110, 212 &! 400, 700, 1000, 1200, 1500, 2500 nm + /) + + !----------------------------------------------------------------------- + + ! Initialize output because solar radiation only done IF coszen > 0 + + DO ib = 1, numrad + albgrd(ib) = 0._r8 + albgri(ib) = 0._r8 + albgrd_pur(ib) = 0._r8 + albgri_pur(ib) = 0._r8 + albgrd_bc(ib) = 0._r8 + albgri_bc(ib) = 0._r8 + albgrd_oc(ib) = 0._r8 + albgri_oc(ib) = 0._r8 + albgrd_dst(ib) = 0._r8 + albgri_dst(ib) = 0._r8 + DO i=maxsnl+1,1,1 + flx_absdv(i) = 0._r8 + flx_absdn(i) = 0._r8 + flx_absiv(i) = 0._r8 + flx_absin(i) = 0._r8 + ENDDO + ENDDO ! END of numrad loop + + ! set variables to pass to SNICAR. + + flg_snw_ice = 1 + + do ibnd = 1, 5 + start_index = band_index(ibnd) + end_index = band_index(ibnd+1) - 1 + + albsfc(ibnd) = SUM(albsoi (start_index:end_index) *& + dif_frac(start_index:end_index)) /& + SUM(dif_frac(start_index:end_index)) + end do + + snw_rds_in(:) = nint(snw_rds(:)) + + ! zero aerosol input arrays + DO aer = 1, sno_nbr_aer + DO i = maxsnl+1, 0 + mss_cnc_aer_in_frc_pur(i,aer) = 0._r8 + mss_cnc_aer_in_frc_bc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_oc(i,aer) = 0._r8 + mss_cnc_aer_in_frc_dst(i,aer) = 0._r8 + mss_cnc_aer_in_fdb(i,aer) = 0._r8 + ENDDO + ENDDO + + ! If radiative forcing is being calculated, first estimate clean-snow albedo + + IF (use_snicar_frc) THEN + + ! 1. PURE SNOW ALBEDO CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsnd_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_pur(:, :), & + albsfc(:), & + albsni_pur(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 2. BC input array: + ! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_bc(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_bc(:,4) = mss_cnc_ocpho(:) + ENDIF + mss_cnc_aer_in_frc_bc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_bc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_bc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_bc(:,8) = mss_cnc_dst4(:) + + ! BC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsnd_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_bc(:, :), & + albsfc(:), & + albsni_bc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ! 3. OC input array: + ! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)] + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_oc(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_oc(:,2) = mss_cnc_bcpho(:) + + mss_cnc_aer_in_frc_oc(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_frc_oc(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_frc_oc(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_frc_oc(:,8) = mss_cnc_dst4(:) + + ! OC FORCING CALCULATIONS + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsnd_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_oc(:, :), & + albsfc(:), & + albsni_oc(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + ENDIF ! END IF (DO_SNO_OC) + + ! 4. DUST FORCING CALCULATIONS + ! DUST input array: + ! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)] + mss_cnc_aer_in_frc_dst(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_frc_dst(:,2) = mss_cnc_bcpho(:) + + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_frc_dst(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_frc_dst(:,4) = mss_cnc_ocpho(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsnd_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ELSE + CALL SNICAR_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_frc_dst(:, :), & + albsfc(:), & + albsni_dst(:), & + foo_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + ENDIF !END IF use_snicar_frc + + + ! -------------------------------------------- + ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: + ! -------------------------------------------- + ! Set aerosol input arrays + ! feedback input arrays have been zeroed + ! set soot and dust aerosol concentrations: + IF (DO_SNO_AER) THEN + mss_cnc_aer_in_fdb(:,1) = mss_cnc_bcphi(:) + mss_cnc_aer_in_fdb(:,2) = mss_cnc_bcpho(:) + + ! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because: + ! 1) Knowledge of their optical properties is primitive + ! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow, + ! it has a negligible darkening effect. + IF (DO_SNO_OC) THEN + mss_cnc_aer_in_fdb(:,3) = mss_cnc_ocphi(:) + mss_cnc_aer_in_fdb(:,4) = mss_cnc_ocpho(:) + ENDIF + + mss_cnc_aer_in_fdb(:,5) = mss_cnc_dst1(:) + mss_cnc_aer_in_fdb(:,6) = mss_cnc_dst2(:) + mss_cnc_aer_in_fdb(:,7) = mss_cnc_dst3(:) + mss_cnc_aer_in_fdb(:,8) = mss_cnc_dst4(:) + ENDIF + + flg_slr = 1 ! direct-beam + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsnd(:), & + flx_absd_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + flg_slr = 2 ! diffuse + IF (use_snicar_ad) THEN + CALL SNICAR_AD_RT(flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ELSE + CALL SNICAR_RT (flg_snw_ice, & + flg_slr, & + coszen_col, & + snl, & + h2osno, & + frac_sno, & + h2osno_liq(:), & + h2osno_ice(:), & + snw_rds_in(:), & + mss_cnc_aer_in_fdb(:, :), & + albsfc(:), & + albsni(:), & + flx_absi_snw(:, :) ) + ENDIF ! END IF use_snicar_ad + + + ! ground albedos and snow-fraction weighting of snow absorption factors + DO ib = 1, nband + IF (coszen_col > 0._r8) THEN + ! ground albedo was originally computed in SoilAlbedo, but is now computed here + ! because the order of SoilAlbedo and SNICAR_RT/SNICAR_AD_RT was switched for SNICAR/SNICAR_AD_RT. + ! 09/01/2023, yuan: change to only snow albedo, the same below + !albgrd(ib) = albsod(ib)*(1._r8-frac_sno) + albsnd(ib)*frac_sno + !albgri(ib) = albsoi(ib)*(1._r8-frac_sno) + albsni(ib)*frac_sno + albgrd(ib) = albsnd(ib) + albgri(ib) = albsni(ib) + + ! albedos for radiative forcing calculations: + IF (use_snicar_frc) THEN + ! pure snow albedo for all-aerosol radiative forcing + !albgrd_pur(ib) = albsod(ib)*(1.-frac_sno) + albsnd_pur(ib)*frac_sno + !albgri_pur(ib) = albsoi(ib)*(1.-frac_sno) + albsni_pur(ib)*frac_sno + albgrd_pur(ib) = albsnd_pur(ib) + albgri_pur(ib) = albsni_pur(ib) + + ! BC forcing albedo + !albgrd_bc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_bc(ib)*frac_sno + !albgri_bc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_bc(ib)*frac_sno + albgrd_bc(ib) = albsnd_bc(ib) + albgri_bc(ib) = albsni_bc(ib) + + IF (DO_SNO_OC) THEN + ! OC forcing albedo + !albgrd_oc(ib) = albsod(ib)*(1.-frac_sno) + albsnd_oc(ib)*frac_sno + !albgri_oc(ib) = albsoi(ib)*(1.-frac_sno) + albsni_oc(ib)*frac_sno + albgrd_oc(ib) = albsnd_oc(ib) + albgri_oc(ib) = albsni_oc(ib) + ENDIF + + ! dust forcing albedo + !albgrd_dst(ib) = albsod(ib)*(1.-frac_sno) + albsnd_dst(ib)*frac_sno + !albgri_dst(ib) = albsoi(ib)*(1.-frac_sno) + albsni_dst(ib)*frac_sno + albgrd_dst(ib) = albsnd_dst(ib) + albgri_dst(ib) = albsni_dst(ib) + ENDIF + + ! also in this loop (but optionally in a different loop for vectorized code) + ! weight snow layer radiative absorption factors based on snow fraction and soil albedo + ! (NEEDED FOR ENERGY CONSERVATION) + DO i = maxsnl+1,1,1 + IF (subgridflag == 0 ) THEN + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absiv(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + elseif (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsod(ib))*(flx_absd_snw(i,ib)/(1.-albsnd(ib)))) + flx_absin(i) = flx_absi_snw(i,ib)*frac_sno + & + ((1.-frac_sno)*(1-albsoi(ib))*(flx_absi_snw(i,ib)/(1.-albsni(ib)))) + ENDIF + ELSE + IF (ib == 1) THEN + flx_absdv(i) = flx_absd_snw(i,ib)!*(1.-albsnd(ib)) + flx_absiv(i) = flx_absi_snw(i,ib)!*(1.-albsni(ib)) + elseif (ib == 2) THEN + flx_absdn(i) = flx_absd_snw(i,ib)!*(1.-albsnd(ib)) + flx_absin(i) = flx_absi_snw(i,ib)!*(1.-albsni(ib)) + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + END SUBROUTINE SnowAlbedo + + SUBROUTINE albocean (oro, scv, coszrs, alb) + +!----------------------------------------------------------------------- +! +! Compute surface albedos +! +! Computes surface albedos for direct/diffuse incident radiation for +! two spectral intervals: +! s = 0.2-0.7 micro-meters +! l = 0.7-5.0 micro-meters +! +! Albedos specified as follows: +! +! Ocean Uses solar zenith angle to compute albedo for direct +! radiation; diffuse radiation values constant; albedo +! independent of spectral interval and other physical +! factors such as ocean surface wind speed. +! +! Ocean with Surface albs specified; combined with overlying snow +! sea ice +! +! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington +! Approximation for Solar Radiation in the NCAR Community Climate Model, +! Journal of Geophysical Research, Vol 97, D7, pp7603-7612). +! +! yongjiu dai and xin-zhong liang (08/01/2001) +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!------------------------------Arguments-------------------------------- + + real(r8), intent(in) :: oro ! /ocean(0)/seaice(2) flag + real(r8), intent(in) :: scv ! snow water equivalent) [mm] + real(r8), intent(in) :: coszrs ! Cosine solar zenith angle + + real(r8), intent(out) :: alb(2,2) ! srf alb for direct (diffuse) rad 0.2-0.7 micro-ms + ! Srf alb for direct (diffuse) rad 0.7-5.0 micro-ms + +!---------------------------Local variables----------------------------- + + real(r8) frsnow ! horizontal fraction of snow cover + real(r8) snwhgt ! physical snow height + real(r8) rghsnw ! roughness for horizontal snow cover fractn + + real(r8) sasdir ! snow alb for direct rad 0.2-0.7 micro-ms + real(r8) saldir ! snow alb for direct rad 0.7-5.0 micro-ms + real(r8) sasdif ! snow alb for diffuse rad 0.2-0.7 micro-ms + real(r8) saldif ! snow alb for diffuse rad 0.7-5.0 micro-ms + + real(r8), parameter :: asices = 0.70 ! sea ice albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asicel = 0.50 ! sea ice albedo for 0.7-5.0 micro-meters [-] + real(r8), parameter :: asnows = 0.95 ! snow albedo for 0.2-0.7 micro-meters [-] + real(r8), parameter :: asnowl = 0.70 ! snow albedo for 0.7-5.0 micro-meters + +!----------------------------------------------------------------------- +! initialize all ocean/sea ice surface albedos to zero + + alb(:,:) = 0. + IF(coszrs<=0.0) RETURN + + IF(nint(oro)==2)THEN + alb(1,1) = asices + alb(2,1) = asicel + alb(1,2) = alb(1,1) + alb(2,2) = alb(2,1) + sasdif = asnows + saldif = asnowl + + IF(scv>0.)THEN + IF (coszrs<0.5) THEN + ! zenith angle regime 1 ( coszrs < 0.5 ). + ! set direct snow albedos (limit to 0.98 max) + sasdir = min(0.98,sasdif+(1.-sasdif)*0.5*(3./(1.+4.*coszrs)-1.)) + saldir = min(0.98,saldif+(1.-saldif)*0.5*(3./(1.+4.*coszrs)-1.)) + ELSE + ! zenith angle regime 2 ( coszrs >= 0.5 ) + sasdir = asnows + saldir = asnowl + ENDIF + + ! compute both diffuse and direct total albedos + snwhgt = 20.*scv / 1000. + rghsnw = 0.25 + frsnow = snwhgt/(rghsnw+snwhgt) + alb(1,1) = alb(1,1)*(1.-frsnow) + sasdir*frsnow + alb(2,1) = alb(2,1)*(1.-frsnow) + saldir*frsnow + alb(1,2) = alb(1,2)*(1.-frsnow) + sasdif*frsnow + alb(2,2) = alb(2,2)*(1.-frsnow) + saldif*frsnow + ENDIF + ENDIF + +! ice-free ocean albedos function of solar zenith angle only, and +! independent of spectral interval: + + IF(nint(oro)==0)THEN + alb(2,1) = .026/(coszrs**1.7+.065) & + + .15*(coszrs-0.1)*(coszrs-0.5)*(coszrs-1.) + alb(1,1) = alb(2,1) + alb(1,2) = 0.06 + alb(2,2) = 0.06 + ENDIF + + END SUBROUTINE albocean + + + pure function calculate_tav(alpha, nr) result(tav) + real(r8), intent(in) :: alpha + real(r8), dimension(211), intent(in) :: nr + real(r8) :: rd, n2(211), n_p(211), nm(211), a(211), k(211), sa + real(r8) :: b1(211), b2(211), b(211), b3(211), a3(211) + real(r8) :: ts(211), tp1(211), tp2(211), tp3(211), tp4(211), tp5(211), tp(211) + real(r8), dimension(211) :: tav + + rd = 3.141592653589793 / 180.0 + n2 = nr**2 + n_p = n2 + 1.0 + nm = n2 - 1.0 + a = (nr + 1.0) * (nr + 1.0) / 2.0 + k = -(n2 - 1.0) * (n2 - 1.0) / 4.0 + sa = sin(alpha * rd) + + b1 = 0.0 + if (alpha /= 90.0) then + b1 = sqrt((sa**2 - n_p / 2.0) * (sa**2 - n_p / 2.0) + k) + end if + + b2 = sa**2 - n_p / 2.0 + b = b1 - b2 + b3 = b**3 + a3 = a**3 + + ts = (k**2 / (6.0 * b3) + k / b - b / 2.0) - (k**2 / (6.0 * a3) + k / a - a / 2.0) + + tp1 = -2.0 * n2 * (b - a) / (n_p**2) + tp2 = -2.0 * n2 * n_p * log(b / a) / (nm**2) + tp3 = n2 * (1.0 / b - 1.0 / a) / 2.0 + tp4 = 16.0 * n2**2 * (n2**2 + 1.0) * log((2.0 * n_p * b - nm**2) / (2.0 * n_p * a - nm**2)) / (n_p**3 * nm**2) + tp5 = 16.0 * n2**3 * (1.0 / (2.0 * n_p * b - nm**2) - 1.0 / (2.0 * n_p * a - nm**2)) / n_p**3 + tp = tp1 + tp2 + tp3 + tp4 + tp5 + tav = (ts + tp) / (2.0 * sa**2) + + end function calculate_tav + + pure FUNCTION poisson_pmf(k, lambda) RESULT(pmf) + IMPLICIT NONE + INTEGER, INTENT(IN) :: k(:) + REAL(r8), INTENT(IN) :: lambda + REAL(r8) :: pmf(SIZE(k)) + INTEGER :: i + + DO i = 1, SIZE(k) + pmf(i) = EXP(-lambda) * lambda**REAL(k(i), KIND=r8) / FACTORIAL_R8( k(i) ) + END DO + + END FUNCTION poisson_pmf + + pure FUNCTION FACTORIAL_R8(k) RESULT(fact) + IMPLICIT NONE + INTEGER, INTENT(IN) :: k + INTEGER :: i + REAL(r8) :: fact + + fact = 1.0_r8 + IF (k <= 0) RETURN + DO i = 1, k + fact = fact * REAL(i, KIND=r8) + END DO + END FUNCTION FACTORIAL_R8 + + SUBROUTINE BSM_soil_moisture( & + ! input + soil_moisture, smc, albedo_dry, kw, nw, & + ! output + albedo_wet) + + IMPLICIT NONE + + ! Arguments + real(r8), intent(in) :: soil_moisture + real(r8), intent(in) :: smc + real(r8), intent(in) :: albedo_dry(211) + real(r8), intent(in) :: kw(211) + real(r8), intent(in) :: nw(211) + + real(r8), intent(out) :: albedo_wet(211, 2) + + ! Parameters + real(r8), parameter :: deleff = 0.0150 ! BSM soil model: film thickness not supplied, set to default of 0.015 m + + INTEGER, DIMENSION(7) :: k_arr = (/0, 1, 2, 3, 4, 5, 6/) + INTEGER :: nk, i + REAL(r8) :: mu + REAL(r8) :: rbac(211), p(211), Rw(211) + REAL(r8) :: fmul(7), tw(211, 7) + REAL(r8) :: Rwet_k(211, 7) + REAL(r8) :: kw_tmp(211, 7), numerator_tmp(211, 7), denominator_tmp(211, 7), dot_product_result(211) + + ! ===== Start of executable code ===== + nk = SIZE(k_arr) + + mu = (soil_moisture - 5.0) / smc + + IF (mu <= 0.0) THEN ! below 5 % SM -> model assumes no effect + albedo_wet(:, 1) = albedo_dry + albedo_wet(:, 2) = albedo_dry + ELSE + rbac = 1.0 - (1.0 - albedo_dry) * (albedo_dry * calculate_tav(90.0, 2.0 / nw) / calculate_tav(90.0, (/ (2.0, i = 1, 211) /)) + 1.0 - albedo_dry) + + p = 1.0 - calculate_tav(90.0, nw) / nw**2 + + Rw = 1.0 - calculate_tav(40.0, nw) + + fmul = poisson_pmf(k_arr, mu) + + do i = 1, nk + kw_tmp(:, i) = kw * k_arr(i) + tw(:, i) = exp(-2.0 * kw_tmp(:, i) * deleff) + + numerator_tmp(:, i) = Rw + (1.0 - Rw) * (1.0 - p) * tw(:, i) * rbac + denominator_tmp(:, i) = 1.0 - p * tw(:, i) * rbac + end do + + ! Rwet_k = Rw + (1.0 - Rw) * (1.0 - p) * tw * rbac / (1.0 - p * tw * rbac) + Rwet_k = numerator_tmp / denominator_tmp + + do i = 1, 211 + dot_product_result(i) = SUM(Rwet_k(i, 2:nk) * fmul(2:nk)) + end do + albedo_wet(:, 1) = (albedo_dry * fmul(1)) + dot_product_result + albedo_wet(:, 2) = albedo_wet(:, 1) + END IF + + END SUBROUTINE BSM_soil_moisture + + SUBROUTINE calculate_wgt_variable( variable, frac_vis, frac_nir, variable_vis, variable_nir ) + + ! Arguments + INTEGER, PARAMETER :: num_vis = 29 ! 400 - 690 nm + INTEGER, PARAMETER :: num_nir = 182 ! 700 - 2500 nm + + real(r8), intent(in) :: variable(211) + real(r8), intent(in) :: frac_vis(num_vis) + real(r8), intent(in) :: frac_nir(num_nir) + + real(r8), intent(out) :: variable_vis + real(r8), intent(out) :: variable_nir + + real(r8), parameter :: eps = 1.0e-12_r8 + real(r8) :: sum_vis, sum_nir + + sum_vis = SUM(frac_vis) + sum_nir = SUM(frac_nir) + + variable_vis = SUM(frac_vis * variable(1:num_vis)) / sum_vis + variable_nir = SUM(frac_nir * variable(num_vis+1:211)) / sum_nir + + END SUBROUTINE calculate_wgt_variable + +END MODULE MOD_Albedo_HiRes +#endif +! --------- EOP ---------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_AssimStomataConductance.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_AssimStomataConductance.F90 new file mode 100644 index 0000000000..e4df0a565b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_AssimStomataConductance.F90 @@ -0,0 +1,844 @@ +#include + +MODULE MOD_AssimStomataConductance + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: stomata + PUBLIC :: update_photosyn + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: sortin + PRIVATE :: calc_photo_params + PRIVATE :: WUE_solver + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE stomata (vmax25,effcon,c3c4,slti,hlti,shti, & + hhti,trda,trdm,trop,g1,g0,gradm,binter,tm, & + psrf,po2m,pco2m,pco2a,ea,ei,tlef,par, & +!Ozone stress variables + o3coefv,o3coefg, & +!End ozone stress variables +!WUE stomata model parameter + lambda, & +!End WUE stomata model parameter + rb,ra,rstfac,cint,assim,respc,rst ) + +!======================================================================= +! +! !DESCRIPTION: +! calculation of canopy photosynthetic rate using the integrated +! model relating assimilation and stomatal conductance. +! +! Original author: Yongjiu Dai, 08/11/2001 +! +! !REFERENCES: +! Dai et al., 2004: A two-big-leaf model for canopy temperature, +! photosynthesis and stomatal conductance. J. Climate, 17: 2281-2299. +! +! +! units are converted from mks to biological units in this routine. +! +! units +! ------- +! +! pco2m, pco2a, pco2i, po2m : pascals +! co2a, co2s, co2i, h2oa, h2os, h2oa : mol mol-1 +! vmax25, respcp, assim, gs, gb, ga : mol m-2 s-1 +! effcon : mol co2 mol quanta-1 +! 1/rb, 1/ra, 1/rst : m s-1 +! +! conversions +! ------------- +! +! 1 mol h2o = 0.018 kg +! 1 mol co2 = 0.044 kg +! h2o (mol mol-1) = ea / psrf ( pa pa-1 ) +! h2o (mol mol-1) = q*mm/(q*mm + 1) +! gs (co2) = gs (h2o) * 1./1.6 +! gs (mol m-2 s-1 ) = gs (m s-1) * 44.6*tf/t*p/po +! par (mol m-2 s-1 ) = par(w m-2) * 4.6*1.e-6 +! mm (molair/molh2o) = 1.611 +! +! !REVISIONS: +! 2021, Xingjie Lu: Add ozone stree and WUE model +! +!---------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: & + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm, &! temperature coefficient in gs-a model (328.16) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter ! conductance-photosynthesis intercept + integer, intent(in) :: & + c3c4 ! 1 for c3, 0 for c4 + real(r8),intent(in) :: & + tm, &! atmospheric air temperature (K) + psrf, &! surface atmospheric pressure (pa) + po2m, &! O2 concentration in atmos. (pascals) + pco2m, &! CO2 concentration in atmos. (pascals) + pco2a, &! CO2 concentration in canopy air space (pa) + ea, &! canopy air space vapor pressure (pa) + ei, &! saturation h2o vapor pressure in leaf stomata (pa) + tlef, &! leaf temperature (K) + par, &! photosynthetic active radiation (W m-2) +!Ozone stress variables + o3coefv, & + o3coefg, & +!End ozone stress variables + +!WUE stomata model parameter + lambda, &! marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + + rb, &! boundary resistance from canopy to cas (s m-1) + ra, &! aerodynamic resistance from cas to reference height (s m-1) + rstfac ! canopy resistance stress factors to soil moisture + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf + assim, &! canopy assimilation rate (mol m-2 s-1) + respc, &! canopy respiration (mol m-2 s-1) + rst ! canopy stomatal resistance (s m-1) + + real(r8) gammas + +!-------------------------- Local Variables ---------------------------- + + integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation + + real(r8) & + c3, &! c3 vegetation : 1; 0 for c4 + c4, &! c4 vegetation : 1; 0 for c3 + rrkk, &! kc (1+o2/ko) + + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + bintc, &! residual stomatal conductance for co2 (mol co2 m-2 s-1) + acp, &! temporary variable for stomata model (mol co2 m-2 s-1) + vpd, &! vapor pressure deficit (kpa) + + tprcor, &! coefficient for unit transfer + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gsh2o, &! canopy conductance (mol m-2 s-1) + + atheta, &! wc, we coupling parameter + btheta, &! wc & we, ws coupling parameter + omss, &! intermediate calculation for oms + omc, &! rubisco limited assimilation (omega-c: mol m-2 s-1) + ome, &! light limited assimilation (omega-e: mol m-2 s-1) + oms, &! sink limited assimilation (omega-s: mol m-2 s-1) + omp, &! intermediate calculation for omc, ome + + co2m, &! co2 concentration in atmos (mol mol-1) + co2a, &! co2 concentration at cas (mol mol-1) + co2s, &! co2 concentration at canopy surface (mol mol-1) + co2st, &! co2 concentration at canopy surface (mol mol-1) + co2i, &! internal co2 concentration (mol mol-1) + pco2in, &! internal co2 concentration at the new iteration (pa) + pco2i, &! internal co2 concentration (pa) + pco2i_c, &! internal co2 concentration when Rubisco is limited (pa) + pco2i_e, &! internal co2 concentration when RuBP regeneration is limited (pa) + es, &! canopy surface h2o vapor pressure (pa) + + sqrtin, &! intermediate calculation for quadratic + assmt, &! net assimilation with a positive limitation (mol co2 m-2 s-1) + assimn, &! net assimilation (mol co2 m-2 s-1) + hcdma, &! a-1 + aquad, &! a: ax^2 + bx + c = 0 + bquad, &! b: ax^2 + bx + c = 0 + cquad ! c: ax^2 + bx + c = 0 + + real(r8) :: & + eyy(iterationtotal), &! differnce of pco2i at two iteration step + pco2y(iterationtotal), &! adjusted to total iteration number + range ! + + integer ic +!----------------------------------------------------------------------- + + CALL calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, c3c4, & + trop, slti, hlti, shti, hhti, trda, trdm, cint, & + vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) + + bintc = binter * max( 0.1, rstfac ) + bintc = bintc * cint(3) + +!----------------------------------------------------------------------- +! first guess is midway between compensation point and maximum +! assimilation rate. ! pay attention on this iteration + + tprcor = 44.6*273.16*psrf/1.013e5 + + co2m = pco2m/psrf ! mol mol-1 + co2a = pco2a/psrf + + range = pco2m * ( 1. - 1.6/gradm ) - gammas + + DO ic = 1, iterationtotal ! loop for total iteration number + pco2y(ic) = 0. + eyy(ic) = 0. + ENDDO + + ITERATION_LOOP: DO ic = 1, iterationtotal + + !IF(.not. DEF_USE_WUEST .or. epar .lt. 1.e-12)THEN + IF(.not. DEF_USE_WUEST .or. abs(c4 - 1) .lt. 0.001)THEN + CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) + pco2i = pco2y(ic) + pco2i_c = pco2i + pco2i_e = pco2i + ELSE + CALL WUE_solver(gammas, lambda, co2a, ei, ea, psrf, pco2i_c, pco2i_e) + ENDIF + +!----------------------------------------------------------------------- +! NET ASSIMILATION +! the leaf assimilation (or gross photosynthesis) rate is described +! as the minimum of three limiting rates: +! omc: the efficiency of the photosynthetic enzyme system (Rubisco-limited); +! ome: the amount of PAR captured by leaf chlorophyll; +! oms: the capacity of the leaf to export or utilize the products of photosynthesis. +! to aviod the abrupt transitions, two quadratic equations are used: +! atheta*omp^2 - omp*(omc+ome) + omc*ome = 0 +! btheta*assim^2 - assim*(omp+oms) + omp*oms = 0 +!----------------------------------------------------------------------- + + atheta = 0.877 + btheta = 0.95 + + ! As if DEF_USE_WUEST=.false., pco2i_c=pco2i_e=pco2i + omc = vm * ( pco2i_c-gammas ) / ( pco2i_c + rrkk ) * c3 + vm * c4 + ome = epar * ( pco2i_e-gammas ) / ( pco2i_e+2.*gammas ) * c3 + epar * c4 + !IF(.not. DEF_USE_WUEST .or. epar .lt. 1.e-12)THEN + IF(.not. DEF_USE_WUEST .or. abs(c4 - 1) .lt. 0.001)THEN + oms = omss * c3 + omss*pco2i * c4 + + sqrtin= max( 0., ( (ome+omc)**2 - 4.*atheta*ome*omc ) ) + omp = ( ( ome+omc ) - sqrt( sqrtin ) ) / ( 2.*atheta ) + sqrtin= max( 0., ( (omp+oms)**2 - 4.*btheta*omp*oms ) ) + assim = max( 0., ( ( oms+omp ) - sqrt( sqrtin ) ) / ( 2.*btheta )) + ELSE + assim = max( 0., min(omc, ome)) + ENDIF + !print*,'assimn',assim,omc,ome + assimn= ( assim - respc) ! mol m-2 s-1 + +!----------------------------------------------------------------------- +! STOMATAL CONDUCTANCE +! +! (1) pathway for co2 flux +! co2m +! o +! | +! | +! < | +! 1.37/gsh2o > | Ac-Rd-Rsoil +! < v +! | +! <--- Ac-Rd | +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! co2i 1.6/gsh2o co2s 1.37/gbh2o co2a +! | ^ +! | | Rsoil +! | | +! +! (2) pathway for water vapor flux +! +! em +! o +! | +! | +! < ^ +! 1/gsh2o > | Ea +! < | +! | +! ---> Ec ! +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! ei 1/gsh2o es 1/gbh2o ea +! | ^ +! | | Eg +! | | +! +! (3) the relationship between net assimilation and tomatal conductance : +! gsh2o = m * An * [es/ei] / [pco2s/p] + b +! es = [gsh2o *ei + gbh2o * ea] / [gsh2o + gbh2o] +! ===> +! a*gsh2o^2 + b*gsh2o + c = 0 +! +!----------------------------------------------------------------------- + + co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 + + co2st = min( co2s, co2a ) + co2st = max( co2st,1.e-5 ) + + assmt = max( 1.e-12, assimn ) + + !IF(DEF_USE_WUEST .and. epar .ge. 1.e-12)THEN + IF(DEF_USE_WUEST .and. .not. abs(c4 - 1) .lt. 0.001)THEN + IF(omc .lt. ome)THEN + pco2i = pco2i_c + ELSE + pco2i = pco2i_e + ENDIF + gsh2o = assmt / (co2a - pco2i/psrf)*1.6 + pco2in = pco2i ! No need to iteratively solve pco2i for WUE model. + ! Let pco2in = pco2i to exit loop. + IF(pco2i .gt. pco2a)THEN + write(*,*) 'warning: pco2i greater than pco2a, use bb model' + ENDIF + ELSE + IF(DEF_USE_MEDLYNST)THEN + vpd = amax1((ei - ea),50._r8) * 1.e-3 ! in kpa + acp = 1.6*assmt/co2st ! in mol m-2 s-1 + aquad = 1._r8 + bquad = -2*(g0*1.e-6 + acp) - (g1*acp)**2/(gbh2o*vpd) ! in mol m-2 s-1 + cquad = (g0*1.e-6)**2 + (2*g0*1.e-6+acp*(1-g1**2)/vpd)*acp ! in (mol m-2 s-1)**2 + + sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) + gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) + + ELSE + hcdma = ei*co2st / ( gradm*assmt ) + + aquad = hcdma + bquad = gbh2o*hcdma - ei - bintc*hcdma + cquad = -gbh2o*( ea + hcdma*bintc ) + + sqrtin= max( 0., ( bquad**2 - 4.*aquad*cquad ) ) + gsh2o = ( -bquad + sqrt ( sqrtin ) ) / (2.*aquad) + + es = ( gsh2o-bintc ) * hcdma ! pa + es = min( es, ei ) + es = max( es, 1.e-2) + + gsh2o = es/hcdma + bintc ! mol m-2 s-1 + ENDIF + + pco2in = ( co2s - 1.6 * assimn / gsh2o )*psrf ! pa + ENDIF + eyy(ic) = pco2i - pco2in ! pa + +!----------------------------------------------------------------------- + + IF( abs(eyy(ic)) .lt. 0.1 ) EXIT + + ENDDO ITERATION_LOOP + +! convert gsh2o (mol m-2 s-1) to resistance rst ( s m-1) + rst = min( 1.e6, 1./(gsh2o*tlef/tprcor) ) ! s m-1 + + END SUBROUTINE stomata + + + + SUBROUTINE sortin( eyy, pco2y, range, gammas, ic, iterationtotal ) + +!----------------------------------------------------------------------- +! arranges successive pco2/error pairs in order of increasing pco2. +! estimates next guess for pco2 using combination of linear and +! quadratic fits. +! +! original author: P. J. Sellers (SiB2) +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ic,iterationtotal + real(r8), intent(in) :: range + real(r8), intent(in) :: gammas + real(r8), intent(inout), dimension(iterationtotal) :: eyy, pco2y + +!-------------------------- Local Variables ---------------------------- + integer i, j, n, i1, i2, i3, is, isp, ix + real(r8) a, b, pmin, emin, eyy_a + real(r8) pco2b, pco2yl, pco2yq + real(r8) ac1, ac2, bc1, bc2, cc1, cc2 + real(r8) bterm, aterm, cterm + +!----------------------------------------------------------------------- + + IF( ic .ge. 4 ) go to 500 + eyy_a = 1.0 + IF(eyy(1).lt.0.) eyy_a = -1.0 + pco2y(1) = gammas + 0.5*range + pco2y(2) = gammas + range*( 0.5 - 0.3*eyy_a ) + pco2y(3) = pco2y(1) - (pco2y(1)-pco2y(2))/(eyy(1)-eyy(2)+1.e-10)*eyy(1) + + pmin = min( pco2y(1), pco2y(2) ) + emin = min( eyy(1), eyy(2) ) + IF ( emin .gt. 0. .and. pco2y(3) .gt. pmin ) pco2y(3) = gammas + go to 200 +500 continue + + n = ic - 1 + DO 1000 j = 2, n + a = eyy(j) + b = pco2y(j) + DO 2000 i = j-1,1,-1 + IF(eyy(i) .le. a ) go to 100 + eyy(i+1) = eyy(i) + pco2y(i+1) = pco2y(i) +2000 continue + i = 0 +100 eyy(i+1) = a + pco2y(i+1) = b +1000 continue + + pco2b = 0. + is = 1 + DO 3000 ix = 1, n + IF( eyy(ix) .lt. 0. ) pco2b = pco2y(ix) + IF( eyy(ix) .lt. 0. ) is = ix +3000 continue + i1 = is-1 + i1 = max(1, i1) + i1 = min(n-2, i1) + i2 = i1 + 1 + i3 = i1 + 2 + isp = is + 1 + isp = min( isp, n ) + is = isp - 1 + + pco2yl=pco2y(is) - (pco2y(is)-pco2y(isp))/(eyy(is)-eyy(isp)+1.e-10)*eyy(is) + +!---------------------------------------------------------------------- +! method using a quadratic fit +!---------------------------------------------------------------------- + + ac1 = eyy(i1)*eyy(i1) - eyy(i2)*eyy(i2) + ac2 = eyy(i2)*eyy(i2) - eyy(i3)*eyy(i3) + bc1 = eyy(i1) - eyy(i2) + bc2 = eyy(i2) - eyy(i3) + cc1 = pco2y(i1) - pco2y(i2) + cc2 = pco2y(i2) - pco2y(i3) + bterm = (cc1*ac2-cc2*ac1)/(bc1*ac2-ac1*bc2+1.e-10) + aterm = (cc1-bc1*bterm)/(ac1+1.e-10) + cterm = pco2y(i2) - aterm*eyy(i2)*eyy(i2) - bterm*eyy(i2) + pco2yq= cterm + pco2yq= max( pco2yq, pco2b ) + pco2y(ic) = ( pco2yl+pco2yq)/2. + +200 continue + + pco2y(ic) = max ( pco2y(ic), 0.01 ) + + END SUBROUTINE sortin + + SUBROUTINE calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, c3c4, & + trop, slti, hlti, shti, hhti, trda, trdm, cint, & + vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: & + tlef, &! leaf temperature (K) + po2m, &! O2 concentration in atmos. (pascals) + par, &! photosynthetic active radiation (W m-2) + rstfac, &! canopy resistance stress factors to soil moisture + rb, &! boundary resistance from canopy to cas (s m-1) + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm, &! temperature coefficient in gs-a model (328.16) + psrf ! surface atmospheric pressure (pa) + + integer, intent(in) :: & + c3c4 ! 1 for c3, 0 for c4 + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: & + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + respc, &! canopy respiration (mol m-2 s-1) + omss, &! intermediate calcuation for oms + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gammas, &! CO2 compensation point + rrkk, &! kc (1+o2/ko) + c3, &! c3 vegetation : 1; 0 for c4 + c4 ! c4 vegetation : 1; 0 for c3 + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + qt, &! (tleaf - 298.16) / 10 + kc, &! Michaelis-Menten constant for co2 + ko, &! Michaelis-Menten constant for o2 + templ, &! intermediate value + temph, &! intermediate value + rgas, &! universal gas contant (8.314 J mol-1 K-1) + jmax25, &! potential rate of whole-chain electron transport at 25 C + jmax, &! potential rate of whole-chain electron transport (mol electron m-2 s-1) + respcp, &! respiration fraction of vmax (mol co2 m-2 s-1) + tprcor ! coefficient for unit transfer + +!----------------------------------------------------------------------- + + c3 = 0. + IF (c3c4.eq.1) c3 = 1. + c4 = 1. - c3 + +!----------------------------------------------------------------------- +! dependence on leaf temperature +! gammas - CO2 compensation point in the absence of day respiration +! ko - Michaelis-Menton constant for carboxylation by Rubisco +! kc - Michaelis-Menton constant for oxygenation by Rubisco +!----------------------------------------------------------------------- + + qt = 0.1*( tlef - trop ) + + kc = 30. * 2.1**qt + ko = 30000. * 1.2**qt + gammas = 0.5 * po2m / (2600. * 0.57**qt) * c3 ! = 0. for c4 plant ??? + + rrkk = kc * ( 1. + po2m/ko ) * c3 + +!---------------------------------------------------------------------- +! maximun capacity +! vm - maximum catalytic activity of Rubisco in the presence of +! saturating level of RuP2 and CO2 (mol m-2s-1) +! jmax - potential rate of whole-chain electron transport (mol m-2s-1) +! epar - electron transport rate for a given absorbed photon radiation +! respc - dark resipration (mol m-2s-1) +! omss - capacity of the leaf to export or utilize the products of photosynthesis. +! binter - coefficient from observation, 0.01 for c3 plant, 0.04 for c4 plant +!----------------------------------------------------------------------- + + vm = vmax25 * 2.1**qt ! (mol m-2 s-1) + templ = 1. + exp(slti*(hlti-tlef)) + temph = 1. + exp(shti*(tlef-hhti)) + vm = vm / temph * rstfac * c3 + vm / (templ*temph) * rstfac * c4 + vm = vm * cint(1) + + rgas = 8.314467591 ! universal gas constant (J mol-1 K-1) +!---> jmax25 = 2.39 * vmax25 - 14.2e-6 ! (mol m-2 s-1) +!---> jmax25 = 2.1 * vmax25 ! (mol m-2 s-1) +!/05/2014/ + jmax25 = 1.97 * vmax25 ! (mol m-2 s-1) + jmax = jmax25 * exp( 37.e3 * (tlef - trop) / (rgas*trop*tlef) ) * & + ( 1. + exp( (710.*trop-220.e3)/(rgas*trop) ) ) / & + ( 1. + exp( (710.*tlef-220.e3)/(rgas*tlef) ) ) + ! 37000 (J mol-1) + ! 220000 (J mol-1) + ! 710 (J K-1) + + jmax = jmax * rstfac + jmax = jmax * cint(2) + +!---> epar = min(4.6e-6 * par * effcon, 0.25*jmax) +! /05/2014/ + epar = min(4.6e-6 * par * effcon, jmax) + + respcp = 0.015 * c3 + 0.025 * c4 + respc = respcp * vmax25 * 2.0**qt / ( 1. + exp( trda*(tlef-trdm )) ) * rstfac +! respc = 0.7e-6 * 2.0**qt / ( 1. + exp( trda*(tlef-trdm )) ) * rstfac + respc = respc * cint(1) + + omss = ( vmax25/2. ) * (1.8**qt) / templ * rstfac * c3 & + + ( vmax25/5. ) * (1.8**qt) * rstfac * c4 + omss = omss * cint(1) + +!----------------------------------------------------------------------- + tprcor = 44.6*273.16*psrf/1.013e5 + +! one side leaf boundary layer conductance for water vapor [=1/(2*rb)] +! ATTENTION: rb in CLM is for one side leaf, but for SiB2 rb for +! 2-side leaf, so the gbh2o shold be " 0.5/rb * tprcor/tlef " +! gbh2o = 0.5/rb * tprcor/tlef ! mol m-2 s-1 + gbh2o = 1./rb * tprcor/tlef ! mol m-2 s-1 + +! rb is for single leaf, but here the flux is for canopy, thus + ! Xingjie Lu: rb has already been converted to canopy scale, + ! thus, there is no need for gbh2o *cint(3) (sunlit/shaded LAI) +! gbh2o = gbh2o * cint(3) + + END SUBROUTINE calc_photo_params + + SUBROUTINE update_photosyn(tlef, po2m, pco2m, pco2a, par, psrf, rstfac, rb, gsh2o,& + effcon, vmax25, c3c4, gradm, trop, slti, hlti, shti, hhti, trda, trdm, cint,& + assim, respc) + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: & + tlef, &! leaf temperature (K) + po2m, &! O2 concentration in atmos. (pascals) + pco2m, &! CO2 concentration in atmos. (pascals) + pco2a, &! CO2 concentration in canopy air space (pa) + par, &! photosynthetic active radiation (W m-2) + psrf, &! surface atmospheric pressure (pa) + rstfac, &! canopy resistance stress factors to soil moisture + rb, &! boundary resistance from canopy to cas (s m-1) + gsh2o, &! canopy conductance (mol m-2 s-1) + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + gradm, &! conductance-photosynthesis slope parameter + trop, &! temperature coefficient in gs-a model (298.16) + slti, &! slope of low temperature inhibition function (0.2) + hlti, &! 1/2 point of low temperature inhibition function (288.16) + shti, &! slope of high temperature inhibition function (0.3) + hhti, &! 1/2 point of high temperature inhibition function (313.16) + trda, &! temperature coefficient in gs-a model (1.3) + trdm ! temperature coefficient in gs-a model (328.16) + + integer, intent(in) :: & + c3c4 ! 1 for c3, 0 for c4 + + real(r8),intent(in), dimension(3) :: & + cint ! scaling up from leaf to canopy + + real(r8),intent(out) :: & + assim, &! canopy assimilation rate (mol m-2 s-1) + respc ! canopy respiration (mol m-2 s-1) + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + vm, &! maximum catalytic activity of Rubison (mol co2 m-2 s-1) + epar, &! electron transport rate (mol electron m-2 s-1) + gbh2o, &! one side leaf boundary layer conductance (mol m-2 s-1) + gammas, &! CO2 compensation point + rrkk, &! kc (1+o2/ko) + c3, &! c3 vegetation : 1; 0 for c4 + c4 ! c4 vegetation : 1; 0 for c3 + + real(r8) :: & + atheta, &! wc, we coupling parameter + btheta, &! wc & we, ws coupling parameter + omss, &! intermediate calcuation for oms + omc, &! rubisco limited assimilation (omega-c: mol m-2 s-1) + ome, &! light limited assimilation (omega-e: mol m-2 s-1) + oms, &! sink limited assimilation (omega-s: mol m-2 s-1) + omp, &! intermediate calcuation for omc, ome + + co2a, &! co2 concentration at cas (mol mol-1) + co2s, &! co2 concentration at canopy surface (mol mol-1) + co2st, &! co2 concentration at canopy surface (mol mol-1) + co2i, &! internal co2 concentration (mol mol-1) + pco2in, &! internal co2 concentration at the new iteration (pa) + pco2i, &! internal co2 concentration (pa) + es, &! canopy surface h2o vapor pressure (pa) + + sqrtin, &! intermediate calculation for quadratic + assmt, &! net assimilation with a positive limitation (mol co2 m-2 s-1) + assimn ! net assimilation (mol co2 m-2 s-1) + + integer, parameter :: iterationtotal = 6 ! total iteration number in pco2i calculation + + real(r8) :: & + eyy(iterationtotal), &! differnce of pco2i at two iteration step + pco2y(iterationtotal), &! adjusted to total iteration number + range ! + + integer ic +!----------------------------------------------------------------------- + + CALL calc_photo_params(tlef, po2m, par , psrf, rstfac, rb, effcon, vmax25, c3c4, & + trop, slti, hlti, shti, hhti, trda, trdm, cint, & + vm, epar, respc, omss, gbh2o, gammas, rrkk, c3, c4) + + co2a = pco2a/psrf + + range = pco2m * ( 1. - 1.6/gradm ) - gammas + + DO ic = 1, iterationtotal ! loop for total iteration number + pco2y(ic) = 0. + eyy(ic) = 0. + ENDDO + + ITERATION_LOOP_UPDATE: DO ic = 1, iterationtotal + + CALL sortin(eyy, pco2y, range, gammas, ic, iterationtotal) + pco2i = pco2y(ic) + +!----------------------------------------------------------------------- +! NET ASSIMILATION +! the leaf assimilation (or gross photosynthesis) rate is described +! as the minimum of three limiting rates: +! omc: the efficiency of the photosynthetic enzyme system (Rubisco-limited); +! ome: the amount of PAR captured by leaf chlorophyll; +! oms: the capacity of the leaf to export or utilize the products of photosynthesis. +! to aviod the abrupt transitions, two quadratic equations are used: +! atheta*omp^2 - omp*(omc+ome) + omc*ome = 0 +! btheta*assim^2 - assim*(omp+oms) + omp*oms = 0 +!----------------------------------------------------------------------- + + atheta = 0.877 + btheta = 0.95 + + omc = vm * ( pco2i-gammas ) / ( pco2i + rrkk ) * c3 + vm * c4 + ome = epar * ( pco2i-gammas ) / ( pco2i+2.*gammas ) * c3 + epar * c4 + IF(.not. DEF_USE_WUEST .or. abs(c4 - 1) .lt. 0.001)THEN + oms = omss * c3 + omss*pco2i * c4 + + sqrtin= max( 0., ( (ome+omc)**2 - 4.*atheta*ome*omc ) ) + omp = ( ( ome+omc ) - sqrt( sqrtin ) ) / ( 2.*atheta ) + sqrtin= max( 0., ( (omp+oms)**2 - 4.*btheta*omp*oms ) ) + assim = max( 0., ( ( oms+omp ) - sqrt( sqrtin ) ) / ( 2.*btheta )) + ELSE + assim = max( 0., min(omc, ome)) + ENDIF + + assimn= ( assim - respc) ! mol m-2 s-1 + +!----------------------------------------------------------------------- +! STOMATAL CONDUCTANCE +! +! (1) pathway for co2 flux +! co2m +! o +! | +! | +! < | +! 1.37/gsh2o > | Ac-Rd-Rsoil +! < v +! | +! <--- Ac-Rd | +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! co2i 1.6/gsh2o co2s 1.37/gbh2o co2a +! | ^ +! | | Rsoil +! | | +! +! (2) pathway for water vapor flux +! +! em +! o +! | +! | +! < ^ +! 1/gsh2o > | Ea +! < | +! | +! ---> Ec ! +! o------/\/\/\/\/\------o------/\/\/\/\/\------o +! ei 1/gsh2o es 1/gbh2o ea +! | ^ +! | | Eg +! | | +! +! (3) the relationship between net assimilation and tomatal conductance : +! gsh2o = m * An * [es/ei] / [pco2s/p] + b +! es = [gsh2o *ei + gbh2o * ea] / [gsh2o + gbh2o] +! ===> +! a*gsh2o^2 + b*gsh2o + c = 0 +! +!----------------------------------------------------------------------- + + co2s = co2a - 1.37*assimn/gbh2o ! mol mol-1 + co2st = min( co2s, co2a ) + co2st = max( co2st,1.e-5 ) + + assmt = max( 1.e-12, assimn ) + + + pco2in = ( co2s - 1.6 * assmt / gsh2o )*psrf ! pa + + eyy(ic) = pco2i - pco2in ! pa + +!----------------------------------------------------------------------- + + IF( abs(eyy(ic)) .lt. 0.1 ) EXIT + + ENDDO ITERATION_LOOP_UPDATE + + END SUBROUTINE update_photosyn + + SUBROUTINE WUE_solver(gammas, lambda, co2a, ei, ea, psrf, pco2i_c, pco2i_e) + +!----------------------------------------------------------------------- +! Solve internal co2 concentration for Rubisco limit and RuBP regeneration limit. +! +! When Rubisco is limit (omc < ome), solve following equation (Liang et al., 2023, S18a) +! for pco2i_c: +! {1-(1.6*D)/[lambda*(gammas+rrkk)]} * co2i_c^2 & +! - {2*co2a+[1.6*D*(rrkk-gammas)]/[lambda*(gammas+rrkk)]-(1.6*D)/lambda} * co2i_c & +! + {co2a^2 - (1.6*D*co2a)/lambda + (1.6*D*rrkk*gammas)/[lambda*(gammas+rrkk)]} = 0 +! +! When RuBP is limit (omc>=ome), solve following equation (Liang et al., 2023, S18b) +! for pco2i_e: +! [1-(1.6*D)/(3*lambda*gammas)] * co2i_e^2 & +! - [2*co2a-(3.2*D)/(3*lambda)] * co2i_e & +! + [co2a^2 - (1.6*D*co2a)/lambda + (3.2*D*gammas)/(3*lambda)] = 0 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8),intent(in) :: & + gammas, &! CO2 compensation point (pa) + lambda, &! marginal water use efficiency ((mol h2o) (mol co2)-1) + co2a, &! co2 concentration at cas ((mol co2) (mol air)-1) + ea, &! canopy air space vapor pressure (pa) + ei, &! saturation h2o vapor pressure in leaf stomata (pa) + psrf ! air pressure (pa) + + real(r8),intent(out) :: & + pco2i_c, &! internal co2 concentration when Rubisco is limited (pa) + pco2i_e ! internal co2 concentration when RuBP regeneration is limited (pa) + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + D, &! leaf-to-air-vapour mole fraction difference ((mol h2o) (mol air)-1) + co2i_c, &! internal co2 concentration when Rubisco is limited ((mol co2) (mol air)-1) + co2i_e ! internal co2 concentration when RuBP is limited ((mol co2) (mol air)-1) + +!----------------------------------------------------------------------- + + ! solve co2i_c + D = amax1((ei - ea),50._r8) / psrf + + co2i_c = co2a - sqrt(1.6*D*(amax1(co2a-gammas/psrf,0._r8))/lambda) + co2i_e = co2a - co2a / ( 1 + 1.37 * sqrt(lambda * gammas/psrf / D)) + + pco2i_c = co2i_c * psrf + pco2i_e = co2i_e * psrf + + END SUBROUTINE WUE_solver + +END MODULE MOD_AssimStomataConductance +! -------------- EOP --------------- diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_CanopyLayerProfile.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CanopyLayerProfile.F90 new file mode 100644 index 0000000000..4f9da1a27e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CanopyLayerProfile.F90 @@ -0,0 +1,730 @@ +#include + +MODULE MOD_CanopyLayerProfile + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER SUBROUTINE/FUNCTIONS: + + PUBLIC :: uprofile, kprofile + PUBLIC :: uintegral, uintegralz, kintegral + PUBLIC :: ueffect, ueffectz, fuint, fkint, frd + PUBLIC :: udiff, kdiff, ufindroots, kfindroots + + PUBLIC :: cal_z0_displa + +!----------------------------------------------------------------------- + +CONTAINS + + real(r8) FUNCTION uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: z + + real(r8) :: ulog,uexp + + ! A simple version of wind profile based on Dai et al., 2019. + ! A combination of u of canopy area and bare soil wighted by + ! their fractional cover. + ! + ! - Canopy area wind: min(uexp, ulog) - bare soil: ulog + ! fc: vegetation fractional cover, bee: free parameter = 1. + + ulog = utop*log(z/z0mg)/log(htop/z0mg) + uexp = utop*exp(-alpha*(1-(z-hbot)/(htop-hbot))) + + uprofile = bee*fc*min(uexp,ulog) + (1-bee*fc)*ulog + + RETURN + END FUNCTION uprofile + + + ! Exchange coefficient K profile based on Dai et al., 2019. + real(r8) FUNCTION kprofile(ktop, fc, bee, alpha, & + displah, htop, hbot, obu, ustar, z) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), parameter :: com1 = 0.4 + real(r8), parameter :: com2 = 0.08 + + real(r8), intent(in) :: ktop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: displah + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: obu + real(r8), intent(in) :: ustar + real(r8), intent(in) :: z + + real(r8) :: fac + real(r8) :: kcob, klin, kexp + + klin = ktop*z/htop + + fac = 1. / (1.+exp(-(displah-com1)/com2)) + kcob = 1. / (fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + + kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) + kprofile = 1./( bee*fc/min(kexp,kcob) + (1-bee*fc)/kcob ) + + RETURN + END FUNCTION kprofile + + + ! numerical solution for wind profile integration (not used now) + real(r8) FUNCTION uintegral(utop, fc, bee, alpha, z0mg, htop, hbot) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + + integer :: i, n + real(r8) :: dz, z, u + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 + n = int( (htop-hbot) / dz ) + 1 + + uintegral = 0. + + DO i = 1, n + IF (i < n) THEN + z = htop - (i-0.5)*dz + ELSE + dz = htop - hbot - (n-1)*dz + z = hbot + 0.5*dz + ENDIF + + u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + u = max(0._r8, u) + !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) + ! 03/04/2020, yuan: NOTE: the above is hard to solve + !NOTE: The integral cannot be solved analytically after + !the square root sign of u, and the integral can be approximated + !directly for u, In this way, there is no need to square + uintegral = uintegral + u*dz / (htop-hbot) + ENDDO + + RETURN + END FUNCTION uintegral + + + ! numerical solution for wind profile integration (not used now) + real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, & + htop, hbot, ztop, zbot) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + + integer :: i, n + real(r8) :: dz, z, u + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 + n = int( (ztop-zbot) / dz ) + 1 + + uintegralz = 0. + + DO i = 1, n + IF (i < n) THEN + z = ztop - (i-0.5)*dz + ELSE + dz = ztop - zbot - (n-1)*dz + z = zbot + 0.5*dz + ENDIF + + u = uprofile(utop, fc, bee, alpha, z0mg, htop, hbot, z) + + u = max(0._r8, u) + !uintegral = uintegral + sqrt(u)*dz / (htop-hbot) + ! 03/04/2020, yuan: NOTE: the above is hard to solve + !NOTE: The integral cannot be solved analytically after + !the square root sign of u, and the integral can be approximated + !directly for u, In this way, there is no need to square + uintegralz = uintegralz + u*dz / (ztop-zbot) + ENDDO + + RETURN + END FUNCTION uintegralz + + + real(r8) FUNCTION ueffect(utop, htop, hbot, & + z0mg, alpha, bee, fc) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: alpha + real(r8), intent(in) :: bee + real(r8), intent(in) :: fc + + real(r8) :: roots(2), uint + integer :: rootn + + rootn = 0 + uint = 0. + + ! The dichotomy method to find the root satisfies a certain accuracy, + ! assuming that there are at most 2 roots + CALL ufindroots(htop,hbot,(htop+hbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + uint = uint + fuint(utop, htop, hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + uint = uint + fuint(utop, htop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + uint = uint + fuint(utop, htop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), roots(2), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(2), hbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + ueffect = uint / (htop-hbot) + + RETURN + END FUNCTION ueffect + + + ! Calculate the effective wind speed between ztop and zbot + real(r8) FUNCTION ueffectz(utop, htop, hbot, & + ztop, zbot, z0mg, alpha, bee, fc) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: alpha + real(r8), intent(in) :: bee + real(r8), intent(in) :: fc + + real(r8) :: roots(2), uint + integer :: rootn + + rootn = 0 + uint = 0. + + ! The dichotomy method to find the root satisfies a certain accuracy, + ! assuming that there are at most 2 roots + CALL ufindroots(ztop,zbot,(ztop+zbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + uint = uint + fuint(utop, ztop, zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + uint = uint + fuint(utop, ztop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + uint = uint + fuint(utop, ztop, roots(1), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(1), roots(2), & + htop, hbot, z0mg, alpha, bee, fc) + uint = uint + fuint(utop, roots(2), zbot, & + htop, hbot, z0mg, alpha, bee, fc) + ENDIF + + ueffectz = uint / (ztop-zbot) + + RETURN + END FUNCTION ueffectz + + + real(r8) FUNCTION fuint(utop, ztop, zbot, & + htop, hbot, z0mg, alpha, bee, fc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: utop, ztop, zbot + real(r8), intent(in) :: htop, hbot + real(r8), intent(in) :: z0mg, alpha + real(r8), intent(in) :: bee, fc + + ! local variables + real(r8) :: fuexpint, fulogint + + fulogint = utop/log(htop/z0mg) *& + (ztop*log(ztop/z0mg) - zbot*log(zbot/z0mg) + zbot - ztop) + + IF (udiff((ztop+zbot)/2.,utop,htop,hbot,z0mg,alpha) <= 0) THEN + ! uexp is smaller + fuexpint = utop*(htop-hbot)/alpha*( & + exp(-alpha*(htop-ztop)/(htop-hbot))-& + exp(-alpha*(htop-zbot)/(htop-hbot)) ) + + fuint = bee*fc*fuexpint + (1.-bee*fc)*fulogint + ELSE + ! ulog is smaller + fuint = fulogint + ENDIF + + RETURN + END FUNCTION fuint + + + RECURSIVE SUBROUTINE ufindroots(ztop,zbot,zmid, & + utop, htop, hbot, z0mg, alpha, roots, rootn) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ztop, zbot, zmid + real(r8), intent(in) :: utop, htop, hbot + real(r8), intent(in) :: z0mg, alpha + + real(r8), intent(inout) :: roots(2) + integer, intent(inout) :: rootn + + ! local variables + real(r8) :: udiff_ub, udiff_lb + + udiff_ub = udiff(ztop,utop,htop,hbot,z0mg,alpha) + udiff_lb = udiff(zmid,utop,htop,hbot,z0mg,alpha) + + IF (udiff_ub*udiff_lb == 0) THEN + IF (udiff_lb == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: U root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSEIF (udiff_ub*udiff_lb < 0) THEN + IF (ztop-zmid < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: U root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = (ztop+zmid)/2. + ELSE + CALL ufindroots(ztop,zmid,(ztop+zmid)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + ENDIF + ENDIF + + udiff_ub = udiff(zmid,utop,htop,hbot,z0mg,alpha) + udiff_lb = udiff(zbot,utop,htop,hbot,z0mg,alpha) + + IF (udiff_ub*udiff_lb == 0) THEN + IF (udiff_ub == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: U root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSEIF (udiff_ub*udiff_lb < 0) THEN + IF (zmid-zbot < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: U root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = (zmid+zbot)/2. + ELSE + CALL ufindroots(zmid,zbot,(zmid+zbot)/2., & + utop, htop, hbot, z0mg, alpha, roots, rootn) + ENDIF + ENDIF + END SUBROUTINE ufindroots + + + real(r8) FUNCTION udiff(z, utop, htop, hbot, z0mg, alpha) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: z, utop, htop, hbot + real(r8), intent(in) :: z0mg, alpha + + real(r8) :: uexp, ulog + + uexp = utop*exp(-alpha*(htop-z)/(htop-hbot)) + ulog = utop*log(z/z0mg)/log(htop/z0mg) + + udiff = uexp - ulog + + RETURN + END FUNCTION udiff + + + ! numerical solution for K profile integration (not used now) + real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, & + displah, htop, hbot, obu, ustar, ztop, zbot) + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ktop + real(r8), intent(in) :: fc + real(r8), intent(in) :: bee + real(r8), intent(in) :: alpha + real(r8), intent(in) :: z0mg + real(r8), intent(in) :: displah + real(r8), intent(in) :: htop + real(r8), intent(in) :: hbot + real(r8), intent(in) :: obu + real(r8), intent(in) :: ustar + real(r8), intent(in) :: ztop + real(r8), intent(in) :: zbot + + integer :: i, n + real(r8) :: dz, z, k + + kintegral = 0. + + IF (ztop <= zbot) THEN + RETURN + ENDIF + + ! 09/26/2017: change fixed n -> fixed dz + dz = 0.001 + n = int( (ztop-zbot) / dz ) + 1 + + DO i = 1, n + IF (i < n) THEN + z = ztop - (i-0.5)*dz + ELSE + dz = ztop - zbot - (n-1)*dz + z = zbot + 0.5*dz + ENDIF + + k = kprofile(ktop, fc, bee, alpha, & + displah, htop, hbot, obu, ustar, z) + + kintegral = kintegral + 1./k * dz + + ENDDO + + RETURN + END FUNCTION kintegral + + + real(r8) FUNCTION frd(ktop, htop, hbot, & + ztop, zbot, displah, z0h, obu, ustar, & + z0mg, alpha, bee, fc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ktop, htop, hbot + real(r8), intent(in) :: ztop, zbot + real(r8), intent(in) :: displah, z0h, obu, ustar + real(r8), intent(in) :: z0mg, alpha, bee, fc + + ! local parameters + real(r8), parameter :: com1 = 0.4 + real(r8), parameter :: com2 = 0.08 + + real(r8) :: roots(2), fac, kint + integer :: rootn + + rootn = 0 + kint = 0. + + ! calculate fac + fac = 1. / (1.+exp(-(displah-com1)/com2)) + roots(:) = 0. + + CALL kfindroots(ztop,zbot,(ztop+zbot)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + + IF (rootn == 0) THEN !no root + kint = kint + fkint(ktop, ztop, zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + IF (rootn == 1) THEN + kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(1), zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + IF (rootn == 2) THEN + kint = kint + fkint(ktop, ztop, roots(1), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(1), roots(2), htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + kint = kint + fkint(ktop, roots(2), zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + ENDIF + + frd = kint + + RETURN + END FUNCTION frd + + + real(r8) FUNCTION fkint(ktop, ztop, zbot, htop, hbot, & + z0h, obu, ustar, fac, alpha, bee, fc) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: ktop, ztop, zbot + real(r8), intent(in) :: htop, hbot + real(r8), intent(in) :: z0h, obu, ustar, fac, alpha + real(r8), intent(in) :: bee, fc + + ! local variables + real(r8) :: fkexpint, fkcobint + + !NOTE: + ! klin = ktop*z/htop + ! kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + fkcobint = fac*htop/ktop*(log(ztop)-log(zbot)) +& + (1.-fac)*kintmoninobuk(0.,z0h,obu,ustar,ztop,zbot) + + IF (kdiff((ztop+zbot)/2.,ktop,htop,hbot,obu,ustar,fac,alpha) <= 0) THEN + ! kexp is smaller + IF (alpha > 0) THEN + fkexpint = -(htop-hbot)/alpha/ktop*( & + exp(alpha*(htop-ztop)/(htop-hbot))-& + exp(alpha*(htop-zbot)/(htop-hbot)) ) + ELSE + fkexpint = (ztop-zbot)/ktop + ENDIF + + fkint = bee*fc*fkexpint + (1.-bee*fc)*fkcobint + ELSE + ! kcob is smaller + fkint = fkcobint + ENDIF + + RETURN + END FUNCTION fkint + + + RECURSIVE SUBROUTINE kfindroots(ztop,zbot,zmid, & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: ztop, zbot, zmid + real(r8), intent(in) :: ktop, htop, hbot + real(r8), intent(in) :: obu, ustar, fac, alpha + + real(r8), intent(inout) :: roots(2) + integer, intent(inout) :: rootn + + ! local variables + real(r8) :: kdiff_ub, kdiff_lb + + ! CALL recursive SUBROUTINE kfindroots + kdiff_ub = kdiff(ztop,ktop,htop,hbot,obu,ustar,fac,alpha) + kdiff_lb = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) + + IF (kdiff_ub*kdiff_lb == 0) THEN + IF (kdiff_lb == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: K root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSEIF (kdiff_ub*kdiff_lb < 0) THEN + IF (ztop-zmid < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: K root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = (ztop+zmid)/2. + ELSE + CALL kfindroots(ztop,zmid,(ztop+zmid)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + ENDIF + ENDIF + + kdiff_ub = kdiff(zmid,ktop,htop,hbot,obu,ustar,fac,alpha) + kdiff_lb = kdiff(zbot,ktop,htop,hbot,obu,ustar,fac,alpha) + + IF (kdiff_ub*kdiff_lb == 0) THEN + IF (kdiff_ub == 0) THEN !root found + rootn = rootn + 1 + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: K root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = zmid + ENDIF + ELSEIF (kdiff_ub*kdiff_lb < 0) THEN + IF (zmid-zbot < 0.01) THEN + rootn = rootn + 1 !root found + IF (rootn > 2) THEN + rootn = 2 + print *, "Warning: K root number > 2, only the first 2 are used!" + RETURN !CALL abort + ENDIF + roots(rootn) = (zmid+zbot)/2. + ELSE + CALL kfindroots(zmid,zbot,(zmid+zbot)/2., & + ktop, htop, hbot, obu, ustar, fac, alpha, roots, rootn) + ENDIF + ENDIF + END SUBROUTINE kfindroots + + + real(r8) FUNCTION kdiff(z, ktop, htop, hbot, & + obu, ustar, fac, alpha) + + USE MOD_Precision + USE MOD_FrictionVelocity + IMPLICIT NONE + + real(r8), intent(in) :: z, ktop, htop, hbot + real(r8), intent(in) :: obu, ustar, fac, alpha + + real(r8) :: kexp, klin, kcob + + kexp = ktop*exp(-alpha*(htop-z)/(htop-hbot)) + + klin = ktop*z/htop + kcob = 1./(fac/klin + (1.-fac)/kmoninobuk(0.,obu,ustar,z)) + + kdiff = kexp - kcob + + RETURN + END FUNCTION kdiff + + + SUBROUTINE cal_z0_displa (lai, h, fc, z0, displa) + + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + + real(r8), intent(in) :: lai + real(r8), intent(in) :: h + real(r8), intent(in) :: fc + real(r8), intent(out) :: z0 + real(r8), intent(out) :: displa + + real(r8), parameter :: Cd = 0.2 !leaf drag coefficient + real(r8), parameter :: cd1 = 7.5 !a free parameter for d/h calculation, Raupach 1992, 1994 + real(r8), parameter :: psih = 0.193 !psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 + + ! local variables + real(r8) :: fai, sqrtdragc, temp1, delta , lai0 + + ! when assume z0=0.01, displa=0 + ! to calculate lai0, delta displa + !---------------------------------------------------- + sqrtdragc = -vonkar/(log(0.01/h) - psih) + sqrtdragc = max(sqrtdragc, 0.0031**0.5) + IF (sqrtdragc .le. 0.3) THEN + fai = (sqrtdragc**2-0.003) / 0.3 + fai = min(fai, fc*(1-exp(-20.))) + ELSE + fai = 0.29 + print *, "z0m, displa error!" + ENDIF + + ! calculate delta displa when z0 = 0.01 + lai0 = -log(1.-fai/fc)/0.5 + temp1 = (2.*cd1*fai)**0.5 + delta = -h * ( fc*1.1*log(1. + (Cd*lai0*fc)**0.25) + & + (1.-fc)*(1.-(1.-exp(-temp1))/temp1) ) + + ! calculate z0m, displa + !---------------------------------------------------- + ! NOTE: potential bug below, only apply for spheric + ! crowns. For other cases, fc*(...) ==> a*fc*(...) + fai = fc*(1. - exp(-0.5*lai)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + temp1 = (2.*cd1*fai)**0.5 + + IF (lai > lai0) THEN + displa = delta + h*( & + ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & + (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) + ELSE + displa = h*( & + ( fc)*1.1*log(1. + (Cd*lai*fc)**0.25) + & + (1-fc)*(1.-(1.-exp(-temp1))/temp1) ) + ENDIF + + displa = max(displa, 0.) + z0 = (h-displa) * exp(-vonkar/sqrtdragc + psih) + + IF (z0 < 0.01) THEN + z0 = 0.01 + displa = 0. + ENDIF + + END SUBROUTINE cal_z0_displa + +END MODULE MOD_CanopyLayerProfile diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_LC.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_LC.F90 new file mode 100644 index 0000000000..a265a0bc59 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_LC.F90 @@ -0,0 +1,878 @@ +#include + +MODULE MOD_Const_LC + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Constant values set for land cover types +! +! Created by Hua Yuan, 08/2019 +! +! !REVISIONS: +! 08/2019, Hua Yuan: initial version adapted from IniTimeConst.F90 of CoLM2014 +! 08/2019, Hua Yuan: added constants values for IGBP land cover types +! 05/2023, Xingjie Lu: added Plant Hydraulics Parameters +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS + + IMPLICIT NONE + SAVE + +#ifdef LULC_USGS + +! GLCC USGS Land Use/Land Cover System Legend +!----------------------------------------------------------------------- +! 0 Ocean +! 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 Inland Water +!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 + + character(len=256) :: patchclassname (0:N_land_classification) = & + (/'0 Ocean ', & + '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 Inland Water ', & + '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 '/) + + ! land patch types + ! 0: soil, 1: urban, 2: wetland, 3: ice, 4: lake + integer , parameter, dimension(N_land_classification) :: patchtypes_usgs & + = (/1, 0, 0, 0, 0, 0, 0, 0,& + 0, 0, 0, 0, 0, 0, 0, 4,& + 2, 2, 0, 0, 0, 0, 0, 3/) + + ! Look-up table canopy top height + !NOTE: now read from input NetCDF file + !NOTE: woody wetland 35m? + ! shrub land 0.5m? grass like land 1m? all set to 0.5 + real(r8), parameter, dimension(N_land_classification) :: htop0_usgs & + !=(/ 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.5,& + ! 0.5, 1.0, 20.0, 17.0, 35.0, 17.0, 20.0, 1.0,& + ! 1.0, 35.0, 0.5, 1.0, 1.0, 1.0, 1.0, 1.0/) + =(/ 1.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5,& + 0.5, 0.5, 20.0, 17.0, 35.0, 17.0, 20.0, 0.5,& + 0.5, 17.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5/) + + ! Look-up table canopy bottom height + ! 01/06/2020, yuan: adjust hbot: grass/shrub -> 0, tree->1 + real(r8), parameter, dimension(N_land_classification) :: hbot0_usgs & + !=(/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.1,& + ! 0.1, 0.1, 11.5, 8.5, 1.0, 8.5, 10.0, 0.1,& + ! 0.1, 1.0, 0.1, 0.01, 0.01, 0.01, 0.01, 0.01/) + =(/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,& + 0.0, 0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0,& + 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + + ! defulat vegetation fractional cover + real(r8), parameter, dimension(N_land_classification) :: fveg0_usgs & + = 1.0 !(/.../) + + ! Look-up table stem area index + !NOTE: now read from input NetCDF file + real(r8), parameter, dimension(N_land_classification) :: sai0_usgs & + !=(/0.2, 0.2, 0.3, 0.3, 0.5, 0.5, 1.0, 0.5,& + ! 1.0, 0.5, 2.0, 2.0, 2.0, 2.0, 2.0, 0.0,& + ! 2.0, 2.0, 0.0, 0.1, 0.1, 0.1, 0.0, 0.0/) + =(/0.2, 0.2, 0.3, 0.3, 0.5, 0.5, 1.0, 0.5,& + 1.0, 0.5, 2.0, 2.0, 2.0, 2.0, 2.0, 0.0,& + 0.2, 2.0, 0.2, 0.2, 0.2, 0.2, 0.0, 0.0/) + + ! ratio to calculate roughness length z0m + real(r8), parameter, dimension(N_land_classification) :: z0mr_usgs = 0.1 + + ! ratio to calculate displacement height d + real(r8), parameter, dimension(N_land_classification) :: displar_usgs = 0.667 + + ! inverse sqrt of leaf dimension [m**-0.5, m=4 cm] + real(r8), parameter, dimension(N_land_classification) :: sqrtdi_usgs = 5.0 + + ! leaf angle distribution parameter + real(r8), parameter, dimension(N_land_classification) :: chil_usgs & + = (/-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, 0.010,& + 0.010, -0.300, 0.250, 0.010, 0.100, 0.010, 0.125, -0.300,& + -0.300, 0.100, 0.010, -0.300, -0.300, -0.300, -0.300, -0.300/) + + ! reflectance of green leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: rhol_vis_usgs & + = (/0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.100,& + 0.100, 0.105, 0.100, 0.070, 0.100, 0.070, 0.070, 0.105,& + 0.105, 0.100, 0.100, 0.105, 0.105, 0.105, 0.105, 0.105/) + + ! reflectance of dead leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: rhos_vis_usgs & + = (/0.360, 0.360, 0.360, 0.360, 0.360, 0.360, 0.360, 0.160,& + 0.160, 0.360, 0.160, 0.160, 0.160, 0.160, 0.160, 0.360,& + 0.360, 0.160, 0.160, 0.360, 0.360, 0.360, 0.360, 0.360/) + + ! reflectance of green leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: rhol_nir_usgs & + = (/0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.450,& + 0.450, 0.580, 0.450, 0.350, 0.450, 0.350, 0.400, 0.580,& + 0.580, 0.450, 0.450, 0.580, 0.580, 0.580, 0.580, 0.580/) + + ! reflectance of dead leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: rhos_nir_usgs & + = (/0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.580, 0.390,& + 0.390, 0.580, 0.390, 0.390, 0.390, 0.390, 0.390, 0.580,& + 0.580, 0.390, 0.390, 0.580, 0.580, 0.580, 0.580, 0.580/) + + ! transmittance of green leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: taul_vis_usgs & + = (/0.070, 0.070, 0.070, 0.070, 0.070, 0.070, 0.070, 0.070,& + 0.070, 0.070, 0.050, 0.050, 0.050, 0.050, 0.050, 0.070,& + 0.070, 0.050, 0.070, 0.070, 0.070, 0.070, 0.070, 0.070/) + + ! transmittance of dead leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: taus_vis_usgs & + = (/0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001,& + 0.001, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220,& + 0.220, 0.001, 0.001, 0.220, 0.220, 0.220, 0.220, 0.220/) + + ! transmittance of green leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: taul_nir_usgs & + = (/0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250,& + 0.250, 0.250, 0.250, 0.100, 0.250, 0.100, 0.150, 0.250,& + 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250/) + + ! transmittance of dead leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: taus_nir_usgs & + = (/0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001,& + 0.001, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380,& + 0.380, 0.001, 0.001, 0.380, 0.380, 0.380, 0.380, 0.380/) + + ! maximum carboxylation rate at 25 C at canopy top + ! /06/03/2014/ based on Bonan et al., 2010 (Table 2) + real(r8), parameter, dimension(N_land_classification) :: vmax25_usgs & + = (/100.0, 57.0, 57.0, 57.0, 52.0, 52.0, 52.0, 52.0,& + 52.0, 52.0, 52.0, 57.0, 72.0, 54.0, 52.0, 57.0,& + 52.0, 52.0, 52.0, 52.0, 52.0, 52.0, 52.0, 52.0/) + + ! quantum efficiency + !TODO: no C4, 0.05 may have problem + real(r8), parameter, dimension(N_land_classification) :: effcon_usgs & + = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& + 0.08, 0.08, 0.08, 0.05, 0.05, 0.05, 0.05, 0.05/) + + !c3c4 flag + integer, parameter, dimension(N_land_classification) :: c3c4_usgs & + = (/1, 1, 1, 1, 1, 1, 1, 1,& + 1, 1, 1, 1, 1, 1, 1, 1,& + 1, 1, 1, 0, 0, 0, 0, 0/) + + ! conductance-photosynthesis slope parameter + !TODO: no C4, 4.0 may have problem + real(r8), parameter, dimension(N_land_classification) :: g1_usgs & + = (/4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0,& + 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0,& + 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0/) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: g0_usgs & + = (/100, 100, 100, 100, 100, 100, 100, 100,& + 100, 100, 100, 100, 100, 100, 100, 100,& + 100, 100, 100, 100, 100, 100, 100, 100/) + + ! conductance-photosynthesis slope parameter + !TODO: no C4, 4.0 may have problem + real(r8), parameter, dimension(N_land_classification) :: gradm_usgs & + = (/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, 9.0, 9.0, 4.0, 4.0, 4.0, 4.0, 4.0/) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: binter_usgs & + = (/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& + 0.01, 0.01, 0.01, 0.04, 0.04, 0.04, 0.04, 0.04/) + + ! respiration fraction + real(r8), parameter, dimension(N_land_classification) :: respcp_usgs & + = (/0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& + 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& + 0.015, 0.015, 0.015, 0.025, 0.025, 0.025, 0.025, 0.025/) + + ! slope of high temperature inhibition FUNCTION (s1) + real(r8), parameter, dimension(N_land_classification) :: shti_usgs = 0.3 + + ! slope of low temperature inhibition FUNCTION (s3) + real(r8), parameter, dimension(N_land_classification) :: slti_usgs = 0.2 + + ! temperature coefficient in gs-a model (s5) + real(r8), parameter, dimension(N_land_classification) :: trda_usgs = 1.3 + + ! temperature coefficient in gs-a model (s6) + real(r8), parameter, dimension(N_land_classification) :: trdm_usgs = 328.0 + + ! temperature coefficient in gs-a model (273.16+25) + real(r8), parameter, dimension(N_land_classification) :: trop_usgs = 298.0 + + ! 1/2 point of high temperature inhibition FUNCTION (s2) + real(r8), parameter, dimension(N_land_classification) :: hhti_usgs & + =(/308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 313.0,& + 313.0, 308.0, 311.0, 303.0, 313.0, 303.0, 307.0, 308.0,& + 308.0, 313.0, 313.0, 313.0, 313.0, 313.0, 313.0, 308.0/) + + ! 1/2 point of low temperature inhibition FUNCTION (s4) + real(r8), parameter, dimension(N_land_classification) :: hlti_usgs & + =(/281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 283.0,& + 283.0, 281.0, 283.0, 278.0, 288.0, 278.0, 281.0, 281.0,& + 281.0, 288.0, 283.0, 288.0, 288.0, 288.0, 288.0, 281.0/) + + ! coefficient of leaf nitrogen allocation + real(r8), parameter, dimension(N_land_classification) :: extkn_usgs = 0.5 + + ! depth at 50% roots + real(r8), parameter, dimension(N_land_classification) :: d50_usgs & + =(/23.0, 21.0, 23.0, 22.0, 15.7, 19.0, 9.3, 47.0,& + 28.2, 21.7, 16.0, 16.0, 15.0, 15.0, 15.5, 1.0,& + 9.3, 15.5, 27.0, 9.0, 9.0, 9.0, 9.0, 1.0/) + + ! coefficient of root profile + real(r8), parameter, dimension(N_land_classification) :: beta_usgs & + =(/-1.757, -1.835, -1.757, -1.796, -1.577, -1.738, -1.359, -3.245,& + -2.302, -1.654, -1.681, -1.681, -1.632, -1.632, -1.656, -1.000,& + -1.359, -1.656, -2.051, -2.621, -2.621, -2.621, -2.621, -1.000/) + + ! Table 2. Zeng, 2001 + ! urban ==> cropland + ! water/glacier ==> grass + real(r8), parameter, dimension(N_land_classification) :: roota_usgs & + =(/ 5.558, 5.558, 5.558, 5.558, 8.149, 5.558, 10.740, 7.022,& + 8.881, 7.920, 5.990, 7.066, 7.344, 6.706, 4.453, 10.740,& + 10.740, 4.453, 8.992, 8.992, 8.992, 8.992, 4.372, 10.740/) + + real(r8), parameter, dimension(N_land_classification) :: rootb_usgs & + =(/ 2.614, 2.614, 2.614, 2.614, 2.611, 2.614, 2.608, 1.415,& + 2.012, 1.964, 1.955, 1.953, 1.303, 2.175, 1.631, 2.608,& + 2.608, 1.631, 8.992, 8.992, 8.992, 8.992, 0.978, 2.608/) + + ! Plant Hydraulics Parameters + real(r8), parameter, dimension(N_land_classification) :: kmax_sun0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) + + real(r8), parameter, dimension(N_land_classification) :: kmax_sha0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) + + real(r8), parameter, dimension(N_land_classification) :: kmax_xyl0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) + + real(r8), parameter, dimension(N_land_classification) :: kmax_root0_usgs & + = (/ 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008,& + 2.e-008, 2.e-008, 2.e-008, 0., 2.e-008, 2.e-008,& + 0., 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008/) + + ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_sun0_usgs & + = (/-150000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& + -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& + -260000.0,-465000.0,-330000.0,-150000.0,-340000.0,-347272.7,& + -150000.0,-340000.0,-342500.0,-341250.0,-150000.0,-150000.0/) *1 + + ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_sha0_usgs & + = (/-150000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& + -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& + -260000.0,-465000.0,-330000.0,-150000.0,-340000.0,-347272.7,& + -150000.0,-340000.0,-342500.0,-341250.0,-150000.0,-150000.0/) *1 + + ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_xyl0_usgs & + = (/-200000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& + -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& + -260000.0,-465000.0,-330000.0,-200000.0,-340000.0,-347272.7,& + -200000.0,-340000.0,-342500.0,-341250.0,-200000.0,-200000.0/) *1 + + ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_root0_usgs & + = (/-200000.0,-340000.0,-340000.0,-340000.0,-340000.0,-343636.4,& + -340000.0,-393333.3,-366666.7,-340000.0,-270000.0,-380000.0,& + -260000.0,-465000.0,-330000.0,-200000.0,-340000.0,-347272.7,& + -200000.0,-340000.0,-342500.0,-341250.0,-200000.0,-200000.0/)*1 + + ! shape-fitting parameter for vulnerability curve (-) + real(r8), parameter, dimension(N_land_classification) :: ck0_usgs & + = (/ 0., 3.95, 3.95, 3.95, 3.95, 3.95, & + 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, & + 3.95, 3.95, 3.95, 0., 3.95, 3.95, & + 0., 3.95, 3.95, 3.95, 0., 0./) + + ! lambda for WUE stomata model + real(r8), parameter, dimension(N_land_classification) :: lambda_usgs & + = (/1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000., 1000./) +!end plant hydraulic parameters +#else + +! MODIS IGBP Land Use/Land Cover System Legend +!----------------------------------------------------------------------- +! 0 Ocean +! 1 Evergreen Needleleaf Forests +! 2 Evergreen Broadleaf Forests +! 3 Deciduous Needleleaf Forests +! 4 Deciduous Broadleaf Forests +! 5 Mixed Forests +! 6 Closed Shrublands +! 7 Open Shrublands +! 8 Woody Savannas +! 9 Savannas +!10 Grasslands +!11 Permanent Wetlands +!12 Croplands +!13 Urban and Built-up Lands +!14 Cropland/Natural Vegetation Mosaics +!15 Permanent Snow and Ice +!16 Barren +!17 Water Bodies + + character(len=256) :: patchclassname (0:N_land_classification) = & + (/'0 Ocean ', '1 Evergreen Needleleaf Forests ', & + '2 Evergreen Broadleaf Forests ', '3 Deciduous Needleleaf Forests ', & + '4 Deciduous Broadleaf Forests ', '5 Mixed Forests ', & + '6 Closed Shrublands ', '7 Open Shrublands ', & + '8 Woody Savannas ', '9 Savannas ', & + '10 Grasslands ', '11 Permanent Wetlands ', & + '12 Croplands ', '13 Urban and Built-up Lands ', & + '14 Cropland/Natural Vegetation Mosaics', '15 Permanent Snow and Ice ', & + '16 Barren ', '17 Water Bodies ' /) + + ! land patch types + ! 0: soil, 1: urban, 2: wetland, 3: ice, 4: lake + integer , parameter, dimension(N_land_classification) :: patchtypes_igbp & + = (/0, 0, 0, 0, 0, 0, 0, 0,& + 0, 0, 2, 0, 1, 0, 3, 0,& + 4 /) + + ! Look-up table canopy top height + !NOTE: now read from input NetCDF file + ! shrub land 0.5m? grass like land 1m? all set to 0.5 + real(r8), parameter, dimension(N_land_classification) :: htop0_igbp & + !=(/17.0, 35.0, 17.0, 20.0, 20.0, 0.5, 0.5, 1.0,& + ! 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0,& + ! 1.0 /) + =(/17.0, 35.0, 17.0, 20.0, 20.0, 0.5, 0.5, 1.0,& + 0.5, 0.5, 0.5, 0.5, 1.0, 0.5, 0.5, 0.5,& + 0.5 /) + + ! Look-up table canopy bottom height + ! 01/06/2020, yuan: adjust hbop: grass/shrub -> 0, tree->1 + real(r8), parameter, dimension(N_land_classification) :: hbot0_igbp & + !=(/ 8.5, 1.0, 8.5, 11.5, 10.0, 0.1, 0.1, 0.1,& + ! 0.1, 0.01, 0.01, 0.01, 0.3, 0.01, 0.01, 0.01,& + ! 0.01 /) + =(/ 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0,& + 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,& + 0.0 /) + + ! Look-up table vegetation fractional cover + real(r8), parameter, dimension(N_land_classification) :: fveg0_igbp & + = 1.0 !(/.../) + + ! Look-up table stem area index + !NOTE: now read from input NetCDF file + real(r8), parameter, dimension(N_land_classification) :: sai0_igbp & + =(/2.0, 2.0, 2.0, 2.0, 2.0, 0.5, 0.5, 0.5,& + 0.5, 0.2, 0.2, 0.2, 0.2, 0.2, 0.0, 0.0,& + 0.0 /) + + ! ratio to calculate roughness length z0m + real(r8), parameter, dimension(N_land_classification) :: z0mr_igbp = 0.1 + + ! ratio to calculate displacement height d + real(r8), parameter, dimension(N_land_classification) :: displar_igbp = 0.667 + + ! inverse&sqrt leaf specific dimension size 4 cm + real(r8), parameter, dimension(N_land_classification) :: sqrtdi_igbp = 5.0 + + ! leaf angle distribution parameter + real(r8), parameter, dimension(N_land_classification) :: chil_igbp & + = (/ 0.010, 0.100, 0.010, 0.250, 0.125, 0.010, 0.010, 0.010,& + 0.010, -0.300, 0.100, -0.300, 0.010, -0.300, 0.010, 0.010,& + 0.010 /) + + ! reflectance of green leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: rhol_vis_igbp & + = (/0.070, 0.100, 0.070, 0.100, 0.070, 0.105, 0.105, 0.105,& + 0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.105, 0.105,& + 0.105 /) + + ! reflectance of dead leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: rhos_vis_igbp & + = (/0.160, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160,& + 0.160, 0.360, 0.160, 0.360, 0.160, 0.360, 0.160, 0.160,& + 0.160 /) + + ! reflectance of green leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: rhol_nir_igbp & + = (/0.350, 0.450, 0.350, 0.450, 0.400, 0.450, 0.450, 0.580,& + 0.580, 0.580, 0.450, 0.580, 0.450, 0.580, 0.450, 0.450,& + 0.580 /) + + ! reflectance of dead leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: rhos_nir_igbp & + = (/0.390, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390,& + 0.390, 0.580, 0.390, 0.580, 0.390, 0.580, 0.390, 0.390,& + 0.580 /) + + ! transmittance of green leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: taul_vis_igbp & + = (/0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050,& + 0.050, 0.070, 0.050, 0.070, 0.050, 0.070, 0.050, 0.050,& + 0.050 /) + + ! transmittance of dead leaf in visible band + real(r8), parameter, dimension(N_land_classification) :: taus_vis_igbp & + = (/0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,& + 0.001, 0.220, 0.001, 0.220, 0.001, 0.220, 0.001, 0.001,& + 0.001 /) + + ! transmittance of green leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: taul_nir_igbp & + = (/0.100, 0.250, 0.100, 0.250, 0.150, 0.250, 0.250, 0.250,& + 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250,& + 0.250 /) + + ! transmittance of dead leaf in near infrared band + real(r8), parameter, dimension(N_land_classification) :: taus_nir_igbp & + = (/0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,& + 0.001, 0.380, 0.001, 0.380, 0.001, 0.380, 0.001, 0.001,& + 0.001 /) + + ! maximum carboxylation rate at 25 C at canopy top + ! /06/03/2014/ based on Bonan et al., 2010 (Table 2) + real(r8), parameter, dimension(N_land_classification) :: vmax25_igbp & + = (/ 54.0, 72.0, 57.0, 52.0, 52.0, 52.0, 52.0, 52.0,& + 52.0, 52.0, 52.0, 57.0,100.0, 57.0, 52.0, 52.0,& + 52.0 /) + + ! quantum efficiency + !TODO: no C4 + real(r8), parameter, dimension(N_land_classification) :: effcon_igbp & + = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08,& + 0.08 /) + + !c3c4 flag + integer, parameter, dimension(N_land_classification) :: c3c4_igbp & + = (/1, 1, 1, 1, 1, 1, 1, 1,& + 1, 1, 1, 1, 1, 1, 1, 1,& + 1 /) + + ! conductance-photosynthesis slope parameter + real(r8), parameter, dimension(N_land_classification) :: g1_igbp & + = (/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 /) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: g0_igbp & + = (/100, 100, 100, 100, 100, 100, 100, 100,& + 100, 100, 100, 100, 100, 100, 100, 100,& + 100 /) + + ! conductance-photosynthesis slope parameter + real(r8), parameter, dimension(N_land_classification) :: gradm_igbp & + = (/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 /) + + ! conductance-photosynthesis intercept + real(r8), parameter, dimension(N_land_classification) :: binter_igbp & + = (/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01,& + 0.01 /) + + ! respiration fraction + real(r8), parameter, dimension(N_land_classification) :: respcp_igbp & + = (/0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& + 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015,& + 0.015 /) + + ! slope of high temperature inhibition FUNCTION (s1) + real(r8), parameter, dimension(N_land_classification) :: shti_igbp = 0.3 + + ! slope of low temperature inhibition FUNCTION (s3) + real(r8), parameter, dimension(N_land_classification) :: slti_igbp = 0.2 + + ! temperature coefficient in gs-a model (s5) + real(r8), parameter, dimension(N_land_classification) :: trda_igbp = 1.3 + + ! temperature coefficient in gs-a model (s6) + real(r8), parameter, dimension(N_land_classification) :: trdm_igbp = 328.0 + + ! temperature coefficient in gs-a model (273.16+25) + real(r8), parameter, dimension(N_land_classification) :: trop_igbp = 298.0 + + ! 1/2 point of high temperature inhibition FUNCTION (s2) + real(r8), parameter, dimension(N_land_classification) :: hhti_igbp & + =(/303.0, 313.0, 303.0, 311.0, 307.0, 308.0, 313.0, 313.0,& + 313.0, 308.0, 313.0, 308.0, 308.0, 308.0, 303.0, 313.0,& + 308.0 /) + + ! 1/2 point of low temperature inhibition FUNCTION (s4) + real(r8), parameter, dimension(N_land_classification) :: hlti_igbp & + =(/278.0, 288.0, 278.0, 283.0, 281.0, 281.0, 288.0, 288.0,& + 288.0, 281.0, 283.0, 281.0, 281.0, 281.0, 278.0, 288.0,& + 281.0 /) + + ! coefficient of leaf nitrogen allocation + real(r8), parameter, dimension(N_land_classification) :: extkn_igbp = 0.5 + + ! depth at 50% roots + real(r8), parameter, dimension(N_land_classification) :: d50_igbp & + =(/15.0, 15.0, 16.0, 16.0, 15.5, 19.0, 28.0, 18.5,& + 28.0, 9.0, 9.0, 22.0, 23.0, 22.0, 1.0, 9.0,& + 1.0 /) + ! coefficient of root profile + real(r8), parameter, dimension(N_land_classification) :: beta_igbp & + =(/-1.623, -1.623, -1.681, -1.681, -1.652, -1.336, -1.909, -1.582,& + -1.798, -1.359, -1.359, -1.796, -1.757, -1.796, -1.000, -2.261,& + -1.000 /) + + ! Table 2. Zeng, 2001 + ! water/glacier ==> grass + ! urban ==> cropland + real(r8), parameter, dimension(N_land_classification) :: roota_igbp & + =(/ 6.706, 7.344, 7.066, 5.990, 4.453, 6.326, 7.718, 7.604,& + 8.235, 10.740, 10.740, 5.558, 5.558, 5.558, 10.740, 4.372,& + 10.740 /) + + real(r8), parameter, dimension(N_land_classification) :: rootb_igbp & + =(/ 2.175, 1.303, 1.953, 1.955, 1.631, 1.567, 1.262, 2.300,& + 1.627, 2.608, 2.608, 2.614, 2.614, 2.614, 2.608, 0.978,& + 2.608 /) + + ! Plant Hydraulics Parameters + real(r8), parameter, dimension(N_land_classification) :: kmax_sun0_igbp & + = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) + + real(r8), parameter, dimension(N_land_classification) :: kmax_sha0_igbp & + = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) + + real(r8), parameter, dimension(N_land_classification) :: kmax_xyl0_igbp & + = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) + + real(r8), parameter, dimension(N_land_classification) :: kmax_root0_igbp & + = (/2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008, & + 2.e-008, 2.e-008, 2.e-008, 2.e-008, 2.e-008 /) + + ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_sun0_igbp & + = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & + -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & + -150000.0, -343636.4, -150000.0, -150000.0, -150000.0/) *1 + + ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_sha0_igbp & + = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & + -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & + -150000.0, -343636.4, -150000.0, -150000.0, -150000.0/) *1 + + ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_xyl0_igbp & + = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & + -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & + -200000.0, -343636.4, -200000.0, -200000.0, -200000.0/) *1 + + ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), parameter, dimension(N_land_classification) :: psi50_root0_igbp & + = (/-465000.0, -260000.0, -380000.0, -270000.0, -330000.0, -393333.3, & + -393333.3, -340000.0, -340000.0, -340000.0, -343636.4, -340000.0, & + -200000.0, -343636.4, -200000.0, -200000.0, -200000.0/) *1 + + ! shape-fitting parameter for vulnerability curve (-) + real(r8), parameter, dimension(N_land_classification) :: ck0_igbp & + = (/3.95, 3.95, 3.95, 3.95, 3.95, 3.95, & + 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, & + 3.95, 3.95, 3.95, 3.95, 3.95 /) + !end plant hydraulic parameters + + ! lambda for WUE stomata model + real(r8), parameter, dimension(N_land_classification) :: lambda_igbp & + = (/1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000., 1000., & + 1000., 1000., 1000., 1000., 1000./) +#endif + + real(r8), dimension(N_land_classification) :: & + patchtypes, &! land patch types + htop0, &! canopy top height + hbot0, &! canopy bottom height + fveg0, &! canopy vegetation fractional cover + sai0, &! canopy stem area index + chil, &! leaf angle distribution factor + z0mr, &! ratio to calculate roughness length z0m + displar, &! ratio to calculate displacement height d + sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] + + vmax25, &! maximum carboxylation rate at 25 C at canopy top + effcon, &! quantum efficiency + g1, &! conductance-photosynthesis slope parameter + g0, &! conductance-photosynthesis intercept + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + respcp, &! respiration fraction + shti, &! slope of high temperature inhibition function (s1) + slti, &! slope of low temperature inhibition function (s3) + trda, &! temperature coefficient in gs-a model (s5) + trdm, &! temperature coefficient in gs-a model (s6) + trop, &! temperature coefficient in gs-a model (273.16+25) + hhti, &! 1/2 point of high temperature inhibition function (s2) + hlti, &! 1/2 point of low temperature inhibition function (s4) + extkn, &! coefficient of leaf nitrogen allocation + + lambda, &! marginal water cost of carbon gain (mol mol-1) + + d50, &! depth at 50% roots + beta ! coefficient of root profile + + integer, dimension(N_land_classification) :: c3c4 ! c3c4 flag + +! Plant Hydraulic Parameters + real(r8), dimension(N_land_classification) :: & + kmax_sun, &! Plant Hydraulics Parameters (TODO@Xingjie Lu, please give more details) + kmax_sha, &! Plant Hydraulics Parameters + kmax_xyl, &! Plant Hydraulics Parameters + kmax_root, &! Plant Hydraulics Parameters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck ! shape-fitting parameter for vulnerability curve (-) +! end plant hydraulic parameters + + real(r8), PRIVATE, dimension(N_land_classification) :: & + roota, &! root fraction para + rootb ! root fraction para + + real(r8) :: & + rho(2,2,N_land_classification),&! leaf reflectance + tau(2,2,N_land_classification) ! leaf transmittance + + ! scheme 1: Schenk and Jackson, 2002, 2: Zeng 2001 + integer, PRIVATE :: ROOTFR_SCHEME = 1 + + ! fraction of roots in each soil layer + real(r8), dimension(nl_soil,N_land_classification) :: rootfr + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: Init_LC_Const + +CONTAINS + + SUBROUTINE Init_LC_Const + + USE MOD_Namelist + IMPLICIT NONE + + integer :: i, nsl + +#ifdef LULC_USGS + patchtypes (:) = patchtypes_usgs (:) + htop0 (:) = htop0_usgs (:) + hbot0 (:) = hbot0_usgs (:) + fveg0 (:) = fveg0_usgs (:) + sai0 (:) = sai0_usgs (:) + z0mr (:) = z0mr_usgs (:) + displar (:) = displar_usgs (:) + sqrtdi (:) = sqrtdi_usgs (:) + chil (:) = chil_usgs (:) + vmax25 (:) = vmax25_usgs (:) * 1.e-6 + effcon (:) = effcon_usgs (:) + c3c4 (:) = c3c4_usgs (:) + g1 (:) = g1_usgs (:) + g0 (:) = g0_usgs (:) + gradm (:) = gradm_usgs (:) + binter (:) = binter_usgs (:) + respcp (:) = respcp_usgs (:) + shti (:) = shti_usgs (:) + slti (:) = slti_usgs (:) + trda (:) = trda_usgs (:) + trdm (:) = trdm_usgs (:) + trop (:) = trop_usgs (:) + hhti (:) = hhti_usgs (:) + hlti (:) = hlti_usgs (:) + extkn (:) = extkn_usgs (:) + d50 (:) = d50_usgs (:) + beta (:) = beta_usgs (:) +IF (DEF_USE_PLANTHYDRAULICS) THEN + kmax_sun (:) = kmax_sun0_usgs (:) + kmax_sha (:) = kmax_sha0_usgs (:) + kmax_xyl (:) = kmax_xyl0_usgs (:) + kmax_root (:) = kmax_root0_usgs (:) + psi50_sun (:) = psi50_sun0_usgs (:) + psi50_sha (:) = psi50_sha0_usgs (:) + psi50_xyl (:) = psi50_xyl0_usgs (:) + psi50_root (:) = psi50_root0_usgs(:) + ck (:) = ck0_usgs (:) +ENDIF +IF (DEF_USE_WUEST)THEN + lambda (:) = lambda_usgs (:) +ENDIF + roota (:) = roota_usgs (:) + rootb (:) = rootb_usgs (:) + rho (1,1,:) = rhol_vis_usgs (:) + rho (2,1,:) = rhol_nir_usgs (:) + rho (1,2,:) = rhos_vis_usgs (:) + rho (2,2,:) = rhos_nir_usgs (:) + tau (1,1,:) = taul_vis_usgs (:) + tau (2,1,:) = taul_nir_usgs (:) + tau (1,2,:) = taus_vis_usgs (:) + tau (2,2,:) = taus_nir_usgs (:) +#else + patchtypes (:) = patchtypes_igbp (:) + htop0 (:) = htop0_igbp (:) + hbot0 (:) = hbot0_igbp (:) + fveg0 (:) = fveg0_igbp (:) + sai0 (:) = sai0_igbp (:) + z0mr (:) = z0mr_igbp (:) + displar (:) = displar_igbp (:) + sqrtdi (:) = sqrtdi_igbp (:) + chil (:) = chil_igbp (:) + vmax25 (:) = vmax25_igbp (:) * 1.e-6 + effcon (:) = effcon_igbp (:) + c3c4 (:) = c3c4_igbp (:) + g1 (:) = g1_igbp (:) + g0 (:) = g0_igbp (:) + gradm (:) = gradm_igbp (:) + binter (:) = binter_igbp (:) + respcp (:) = respcp_igbp (:) + shti (:) = shti_igbp (:) + slti (:) = slti_igbp (:) + trda (:) = trda_igbp (:) + trdm (:) = trdm_igbp (:) + trop (:) = trop_igbp (:) + hhti (:) = hhti_igbp (:) + hlti (:) = hlti_igbp (:) + extkn (:) = extkn_igbp (:) + d50 (:) = d50_igbp (:) + beta (:) = beta_igbp (:) +IF(DEF_USE_PLANTHYDRAULICS)THEN + kmax_sun (:) = kmax_sun0_igbp (:) + kmax_sha (:) = kmax_sha0_igbp (:) + kmax_xyl (:) = kmax_xyl0_igbp (:) + kmax_root (:) = kmax_root0_igbp (:) + psi50_sun (:) = psi50_sun0_igbp (:) + psi50_sha (:) = psi50_sha0_igbp (:) + psi50_xyl (:) = psi50_xyl0_igbp (:) + psi50_root (:) = psi50_root0_igbp(:) + ck (:) = ck0_igbp (:) +ENDIF +IF (DEF_USE_WUEST)THEN + lambda (:) = lambda_igbp (:) +ENDIF + roota (:) = roota_igbp (:) + rootb (:) = rootb_igbp (:) + rho (1,1,:) = rhol_vis_igbp (:) + rho (2,1,:) = rhol_nir_igbp (:) + rho (1,2,:) = rhos_vis_igbp (:) + rho (2,2,:) = rhos_nir_igbp (:) + tau (1,1,:) = taul_vis_igbp (:) + tau (2,1,:) = taul_nir_igbp (:) + tau (1,2,:) = taus_vis_igbp (:) + tau (2,2,:) = taus_nir_igbp (:) +#endif + + ! ---------------------------------------------------------- + ! The definition of global root distribution is based on + ! Schenk and Jackson, 2002: The Global Biogeography of Roots. + ! Ecological Monagraph 72(3): 311-328. + ! ---------------------------------------------------------- + IF (ROOTFR_SCHEME == 1) THEN + DO i = 1, N_land_classification + rootfr(1,i)=1./(1.+(zi_soi(1)*100./d50(i))**beta(i)) + rootfr(nl_soil,i)=1.-1./(1.+(zi_soi(nl_soil-1)*100./d50(i))**beta(i)) + + DO nsl=2,nl_soil-1 + rootfr(nsl,i)=1./(1.+(zi_soi(nsl)*100./d50(i))**beta(i)) & + -1./(1.+(zi_soi(nsl-1)*100./d50(i))**beta(i)) + ENDDO + ENDDO + ELSE + DO i = 1, N_land_classification + rootfr(1,i) = 1. - 0.5*( & + exp(-roota(i) * zi_soi(1)) & + + exp(-rootb(i) * zi_soi(1)) ) + + rootfr(nl_soil,i) = 0.5*( & + exp(-roota(i) * zi_soi(nl_soil)) & + + exp(-rootb(i) * zi_soi(nl_soil)) ) + + DO nsl = 2, nl_soil-1 + rootfr(nsl,i) = 0.5*( & + exp(-roota(i) * zi_soi(nsl-1)) & + + exp(-rootb(i) * zi_soi(nsl-1)) & + - exp(-roota(i) * zi_soi(nsl)) & + - exp(-rootb(i) * zi_soi(nsl)) ) + ENDDO + ENDDO + ENDIF + + END SUBROUTINE Init_LC_Const + +END MODULE MOD_Const_LC +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_PFT.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_PFT.F90 new file mode 100644 index 0000000000..0ae52b2ce0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_PFT.F90 @@ -0,0 +1,1817 @@ +#include + +MODULE MOD_Const_PFT + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Set constants for plant functional types (PFTs) +! +! Created by Hua Yuan, 08/2019 +! +! !REVISIONS: +! 10/2021, Xingjie Lu: added for crop PFTs +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_TimeManager, only: get_calday + + IMPLICIT NONE + SAVE + +! Plant Functional Type classification +!----------------------------------------------------------------------- +! 0 not vegetated +! 1 needleleaf evergreen temperate tree +! 2 needleleaf evergreen boreal tree +! 3 needleleaf deciduous boreal tree +! 4 broadleaf evergreen tropical tree +! 5 broadleaf evergreen temperate tree +! 6 broadleaf deciduous tropical tree +! 7 broadleaf deciduous temperate tree +! 8 broadleaf deciduous boreal tree +! 9 broadleaf evergreen shrub +!10 broadleaf deciduous temperate shrub +!11 broadleaf deciduous boreal shrub +!12 c3 arctic grass +!13 c3 non-arctic grass +!14 c4 grass +!15 c3 crop +!16 c3_irrigated +!17 temperate_corn +!18 irrigated_temperate_corn +!19 spring_wheat +!20 irrigated_spring_wheat +!21 winter_wheat +!22 irrigated_winter_wheat +!23 temperate_soybean +!24 irrigated_temperate_soybean +!25 barley +!26 irrigated_barley +!27 winter_barley +!28 irrigated_winter_barley +!29 rye +!30 irrigated_rye +!31 winter_rye +!32 irrigated_winter_rye +!33 cassava +!34 irrigated_cassava +!35 citrus +!36 irrigated_citrus +!37 cocoa +!38 irrigated_cocoa +!39 coffee +!40 irrigated_coffee +!41 cotton +!42 irrigated_cotton +!43 datepalm +!44 irrigated_datepalm +!45 foddergrass +!46 irrigated_foddergrass +!47 grapes +!48 irrigated_grapes +!49 groundnuts +!50 irrigated_groundnuts +!51 millet +!52 irrigated_millet +!53 oilpalm +!54 irrigated_oilpalm +!55 potatoes +!56 irrigated_potatoes +!57 pulses +!58 irrigated_pulses +!59 rapeseed +!60 irrigated_rapeseed +!61 rice +!62 irrigated_rice +!63 sorghum +!64 irrigated_sorghum +!65 sugarbeet +!66 irrigated_sugarbeet +!67 sugarcane +!68 irrigated_sugarcane +!69 sunflower +!70 irrigated_sunflower +!71 miscanthus +!72 irrigated_miscanthus +!73 switchgrass +!74 irrigated_switchgrass +!75 tropical_corn +!76 irrigated_tropical_corn +!77 tropical_soybean +!78 irrigated_tropical_soybean + + character(len=256) :: pftclassname (0:N_PFT+N_CFT-1) = & + (/'0 not vegetated ', '1 needleleaf evergreen temperate tree ', & + '2 needleleaf evergreen boreal tree ', '3 needleleaf deciduous boreal tree ', & + '4 broadleaf evergreen tropical tree ', '5 broadleaf evergreen temperate tree ', & + '6 broadleaf deciduous tropical tree ', '7 broadleaf deciduous temperate tree ', & + '8 broadleaf deciduous boreal tree ', '9 broadleaf evergreen shrub ', & + '10 broadleaf deciduous temperate shrub', '11 broadleaf deciduous boreal shrub ', & + '12 c3 arctic grass ', '13 c3 non-arctic grass ', & + '14 c4 grass ', '15 c3 crop ' & +#ifdef CROP + ,'16 c3_irrigated ', '17 temperate_corn ', & + '18 irrigated_temperate_corn ', '19 spring_wheat ', & + '20 irrigated_spring_wheat ', '21 winter_wheat ', & + '22 irrigated_winter_wheat ', '23 temperate_soybean ', & + '24 irrigated_temperate_soybean ', '25 barley ', & + '26 irrigated_barley ', '27 winter_barley ', & + '28 irrigated_winter_barley ', '29 rye ', & + '30 irrigated_rye ', '31 winter_rye ', & + '32 irrigated_winter_rye ', '33 cassava ', & + '34 irrigated_cassava ', '35 citrus ', & + '36 irrigated_citrus ', '37 cocoa ', & + '38 irrigated_cocoa ', '39 coffee ', & + '40 irrigated_coffee ', '41 cotton ', & + '42 irrigated_cotton ', '43 datepalm ', & + '44 irrigated_datepalm ', '45 foddergrass ', & + '46 irrigated_foddergrass ', '47 grapes ', & + '48 irrigated_grapes ', '49 groundnuts ', & + '50 irrigated_groundnuts ', '51 millet ', & + '52 irrigated_millet ', '53 oilpalm ', & + '54 irrigated_oilpalm ', '55 potatoes ', & + '56 irrigated_potatoes ', '57 pulses ', & + '58 irrigated_pulses ', '59 rapeseed ', & + '60 irrigated_rapeseed ', '61 rice ', & + '62 irrigated_rice ', '63 sorghum ', & + '64 irrigated_sorghum ', '65 sugarbeet ', & + '66 irrigated_sugarbeet ', '67 sugarcane ', & + '68 irrigated_sugarcane ', '69 sunflower ', & + '70 irrigated_sunflower ', '71 miscanthus ', & + '72 irrigated_miscanthus ', '73 switchgrass ', & + '74 irrigated_switchgrass ', '75 tropical_corn ', & + '76 irrigated_tropical_corn ', '77 tropical_soybean ', & + '78 irrigated_tropical_soybean ' & +#endif + /) + + ! canopy layer number + integer , parameter :: canlay_p(0:N_PFT+N_CFT-1) & + = (/0, 2, 2, 2, 2, 2, 2, 2 & + , 2, 1, 1, 1, 1, 1, 1, 1 & +#ifdef CROP + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1, 1 & + , 1, 1, 1, 1, 1, 1, 1 & +#endif + /) + + ! canopy top height + real(r8), parameter :: htop0_p(0:N_PFT+N_CFT-1) & + =(/ 0.5, 17.0, 17.0, 14.0, 35.0, 35.0, 18.0, 20.0& + ,20.0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& +#ifdef CROP + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5& + , 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 & +#endif + /) + + ! canopy bottom height + ! 01/06/2020, yuan: adjust htop: grass/shrub -> 0, tree->1 + real(r8), parameter :: hbot0_p(0:N_PFT+N_CFT-1) & + !TODO: check the setting values + !=(/0.01, 8.5, 8.5, 7.0, 1.0, 1.0, 10.0, 11.5& + ! 11.5, 0.1, 0.1, 0.1, 0.01, 0.01, 0.01, 0.01/) + =(/0.00, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0& + , 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& +#ifdef CROP + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0& + , 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 & +#endif + /) + + ! default vegetation fractional cover + real(r8), parameter :: fveg0_p(0:N_PFT+N_CFT-1) & + = 1.0 !(/.../) + + ! default stem area index + real(r8), parameter :: sai0_p(0:N_PFT+N_CFT-1) & + =(/0.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0& + , 2.0, 0.5, 0.5, 0.5, 0.2, 0.2, 0.2, 0.2& +#ifdef CROP + , 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.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.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 & +#endif + /) + + ! ratio to calculate roughness length z0m + real(r8), parameter :: z0mr_p(0:N_PFT+N_CFT-1) = 0.1 + + ! ratio to calculate displacement height d + real(r8), parameter :: displar_p(0:N_PFT+N_CFT-1) = 0.667 + + ! inverse&sqrt leaf specific dimension size 4 cm + real(r8), parameter :: sqrtdi_p(0:N_PFT+N_CFT-1) = 5.0 + + ! leaf angle distribution parameter + real(r8), parameter :: chil_p(0:N_PFT+N_CFT-1) & + = (/-0.300, 0.010, 0.010, 0.010, 0.100, 0.100, 0.010, 0.250& + , 0.250, 0.010, 0.250, 0.250, -0.300, -0.300, -0.300, -0.300& +#ifdef CROP + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300& + ,-0.300, -0.300, -0.300, -0.300, -0.300, -0.300, -0.300 & +#endif + /) + + ! reflectance of green leaf in visible band +#if (defined LULC_IGBP_PC) + ! Leaf optical properties adapted from measured data (Dong et al., 2021) + real(r8), parameter :: rhol_vis_p(0:N_PFT+N_CFT-1) & + = (/0.110, 0.070, 0.070, 0.070, 0.100, 0.110, 0.100, 0.100& + , 0.100, 0.070, 0.100, 0.100, 0.110, 0.110, 0.110, 0.110& +#else + real(r8), parameter :: rhol_vis_p(0:N_PFT+N_CFT-1) & + = (/0.110, 0.070, 0.070, 0.070, 0.100, 0.100, 0.100, 0.100& + , 0.100, 0.070, 0.100, 0.100, 0.110, 0.110, 0.110, 0.110& +#endif +#ifdef CROP + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110& + , 0.110, 0.110, 0.110, 0.110, 0.110, 0.110, 0.110 & +#endif + /) + + ! reflectance of dead leaf in visible band + real(r8), parameter :: rhos_vis_p(0:N_PFT+N_CFT-1) & + = (/0.310, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160, 0.160& + , 0.160, 0.160, 0.160, 0.160, 0.310, 0.310, 0.310, 0.310& +#ifdef CROP + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310& + , 0.310, 0.310, 0.310, 0.310, 0.310, 0.310, 0.310 & +#endif + /) + + ! reflectance of green leaf in near infrared band +#if (defined LULC_IGBP_PC) + ! Leaf optical properties adapted from measured data (Dong et al., 2021) + real(r8), parameter :: rhol_nir_p(0:N_PFT+N_CFT-1) & + = (/0.350, 0.360, 0.370, 0.360, 0.450, 0.460, 0.450, 0.420& + , 0.450, 0.350, 0.450, 0.450, 0.350, 0.350, 0.350, 0.350& +#else + real(r8), parameter :: rhol_nir_p(0:N_PFT+N_CFT-1) & + = (/0.350, 0.350, 0.350, 0.350, 0.450, 0.450, 0.450, 0.450& + , 0.450, 0.350, 0.450, 0.450, 0.350, 0.350, 0.350, 0.350& +#endif +#ifdef CROP + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350& + , 0.350, 0.350, 0.350, 0.350, 0.350, 0.350, 0.350 & +#endif + /) + + ! reflectance of dead leaf in near infrared band + real(r8), parameter :: rhos_nir_p(0:N_PFT+N_CFT-1) & + = (/0.530, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390, 0.390& + , 0.390, 0.390, 0.390, 0.390, 0.530, 0.530, 0.530, 0.530& +#ifdef CROP + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530& + , 0.530, 0.530, 0.530, 0.530, 0.530, 0.530, 0.530 & +#endif + /) + + ! transmittance of green leaf in visible band +#if (defined LULC_IGBP_PC) + ! Leaf optical properties adapted from measured data (Dong et al., 2021) + real(r8), parameter :: taul_vis_p(0:N_PFT+N_CFT-1) & + = (/0.050, 0.050, 0.050, 0.050, 0.050, 0.060, 0.050, 0.060& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& +#else + real(r8), parameter :: taul_vis_p(0:N_PFT+N_CFT-1) & + = (/0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& +#endif +#ifdef CROP + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050& + , 0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050 & +#endif + /) + + ! transmittance of dead leaf in visible band + real(r8), parameter :: taus_vis_p(0:N_PFT+N_CFT-1) & + = (/0.120, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001& + , 0.001, 0.001, 0.001, 0.001, 0.120, 0.120, 0.120, 0.120& +#ifdef CROP + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120& + , 0.120, 0.120, 0.120, 0.120, 0.120, 0.120, 0.120 & +#endif + /) + + ! transmittance of green leaf in near infrared band +#if (defined LULC_IGBP_PC) + ! Leaf optical properties adapted from measured data (Dong et al., 2021) + real(r8), parameter :: taul_nir_p(0:N_PFT+N_CFT-1) & + = (/0.340, 0.280, 0.290, 0.380, 0.250, 0.330, 0.250, 0.430& + , 0.400, 0.100, 0.250, 0.250, 0.340, 0.340, 0.340, 0.340& +#else + real(r8), parameter :: taul_nir_p(0:N_PFT+N_CFT-1) & + = (/0.340, 0.100, 0.100, 0.100, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.100, 0.250, 0.250, 0.340, 0.340, 0.340, 0.340& +#endif +#ifdef CROP + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340& + , 0.340, 0.340, 0.340, 0.340, 0.340, 0.340, 0.340 & +#endif + /) + + ! transmittance of dead leaf in near infrared band + real(r8), parameter :: taus_nir_p(0:N_PFT+N_CFT-1) & + = (/0.250, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001& + , 0.001, 0.001, 0.001, 0.001, 0.250, 0.250, 0.250, 0.250& +#ifdef CROP + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250& + , 0.250, 0.250, 0.250, 0.250, 0.250, 0.250, 0.250 & +#endif + /) + + ! maximum carboxylation rate at 25 C at canopy top + ! /06/03/2014/ based on Bonan et al., 2011 (Table 2) + !real(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & + ! = (/ 52.0, 61.0, 54.0, 57.0, 72.0, 72.0, 52.0, 52.0& + ! , 52.0, 72.0, 52.0, 52.0, 52.0, 52.0, 52.0, 57.0& + ! /07/27/2022/ based on Bonan et al., 2011 (Table 2, VmaxF(N)) + ! Temporarilly tune Vegetation parameter to match VGM model (soil too wet) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & +! = (/ 52.0, 16.1, 16.5, 22.5, 12.3, 10.7, 16.2, 15.1& +! , 15.3, 21.4, 22.0, 26.6, 34.2, 20.6, 10.0, 57.0& +! = (/ 52.0, 56.0, 54.0, 57.0, 18.0, 23.0, 31.3, 36.1& +! , 52.0, 40.0, 37.5, 52.0, 52.0, 52.0, 13.4, 57.0& + = (/ 52.0, 25.2, 26.5, 34.1, 13.2, 15.7, 20.3, 24.2& + , 28.0, 33.1, 33.4, 48.5, 55.7, 41.5, 10.0, 57.0& +#ifdef CROP + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0 & +#endif + /) * 1.e-6 +#else + real(r8), parameter :: vmax25_p(0:N_PFT+N_CFT-1) & +! = (/ 52.0, 55.0, 42.0, 29.0, 41.0, 51.0, 36.0, 30.0& +! , 40.0, 36.0, 30.0, 19.0, 21.0, 26.0, 25.0, 57.0& + = (/ 52.0, 56.0, 54.0, 57.0, 18.0, 23.0, 31.3, 36.1& + , 52.0, 40.0, 37.5, 52.0, 52.0, 52.0, 13.4, 57.0& +#ifdef CROP + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0& + , 57.0, 57.0, 57.0, 57.0, 57.0, 57.0, 57.0 & +#endif + /) * 1.e-6 +#endif + + ! quantum efficiency + real(r8), parameter :: effcon_p(0:N_PFT+N_CFT-1) & + = (/0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.05, 0.08& +#ifdef CROP + , 0.08, 0.05, 0.05, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08& + , 0.08, 0.08, 0.08, 0.05, 0.05, 0.08, 0.08 & +#endif + /) + + !C3C4 switch 1: C3, 0: C4 + integer, parameter :: c3c4_p(0:N_PFT+N_CFT-1) & + = (/1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 0, 1& +#ifdef CROP + , 1, 0, 0, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 1, 1, 1, 1, 1& + , 1, 1, 1, 0, 0, 1, 1 & +#endif + /) + + ! conductance-photosynthesis slope parameter + real(r8), parameter :: g1_p(0:N_PFT+N_CFT-1) & + = (/4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& +#ifdef CROP + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0& + , 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0 & +#endif + /) + + ! conductance-photosynthesis intercept + real(r8), parameter :: g0_p(0:N_PFT+N_CFT-1) & + = (/100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& +#ifdef CROP + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100, 100& + , 100, 100, 100, 100, 100, 100, 100 & +#endif + /) + + ! conductance-photosynthesis slope parameter + real(r8), parameter :: gradm_p(0:N_PFT+N_CFT-1) & + = (/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, 4.0, 9.0& +#ifdef CROP + , 9.0, 4.0, 4.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, 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, 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, 9.0, 9.0& + , 9.0, 9.0, 9.0, 4.0, 4.0, 9.0, 9.0 & +#endif + /) + + ! conductance-photosynthesis intercept + real(r8), parameter :: binter_p(0:N_PFT+N_CFT-1) & + = (/0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.04, 0.01& +#ifdef CROP + , 0.01, 0.04, 0.04, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01& + , 0.01, 0.01, 0.01, 0.04, 0.04, 0.01, 0.01 & +#endif + /) + + ! respiration fraction + real(r8), parameter :: respcp_p(0:N_PFT+N_CFT-1) & + = (/0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.025, 0.015& +#ifdef CROP + , 0.015, 0.025, 0.025, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015, 0.015& + , 0.015, 0.015, 0.015, 0.025, 0.025, 0.015, 0.015 & +#endif + /) + + ! slope of high temperature inhibition FUNCTION (s1) + real(r8), parameter :: shti_p(0:N_PFT+N_CFT-1) = 0.3 + + ! slope of low temperature inhibition FUNCTION (s3) + real(r8), parameter :: slti_p(0:N_PFT+N_CFT-1) = 0.2 + + ! temperature coefficient in gs-a model (s5) + real(r8), parameter :: trda_p(0:N_PFT+N_CFT-1) = 1.3 + + ! temperature coefficient in gs-a model (s6) + real(r8), parameter :: trdm_p(0:N_PFT+N_CFT-1) = 328.0 + + ! temperature coefficient in gs-a model (273.16+25) + real(r8), parameter :: trop_p(0:N_PFT+N_CFT-1) = 298.0 + + ! 1/2 point of high temperature inhibition FUNCTION (s2) + real(r8), parameter :: hhti_p(0:N_PFT+N_CFT-1) & + =(/308.0, 303.0, 303.0, 303.0, 313.0, 313.0, 311.0, 311.0& + ,311.0, 313.0, 313.0, 303.0, 303.0, 308.0, 313.0, 308.0& +#ifdef CROP + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0& + ,308.0, 308.0, 308.0, 308.0, 308.0, 308.0, 308.0 & +#endif + /) + + ! 1/2 point of low temperature inhibition FUNCTION (s4) + real(r8), parameter :: hlti_p(0:N_PFT+N_CFT-1) & + =(/281.0, 278.0, 278.0, 278.0, 288.0, 288.0, 283.0, 283.0& + ,283.0, 283.0, 283.0, 278.0, 278.0, 281.0, 288.0, 281.0& +#ifdef CROP + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0& + ,281.0, 281.0, 281.0, 281.0, 281.0, 281.0, 281.0 & +#endif + /) + + ! coefficient of leaf nitrogen allocation + real(r8), parameter :: extkn_p(0:N_PFT+N_CFT-1) = 0.5 + + real(r8) :: & +#ifndef CROP + rho_p(2,2,0:N_PFT-1), &!leaf reflectance + tau_p(2,2,0:N_PFT-1) !leaf transmittance +#else + rho_p(2,2,0:N_PFT+N_CFT-1), &!leaf reflectance + tau_p(2,2,0:N_PFT+N_CFT-1) !leaf transmittance +#endif + + ! depth at 50% roots + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: d50_p & + =(/27.0, 21.0, 12.0, 12.0, 15.0, 23.0, 16.0, 23.0& + ,12.0, 23.5, 23.5, 23.5, 9.0, 7.0, 16.0, 22.0& +#ifdef CROP + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0& + ,22.0, 22.0, 22.0, 22.0, 22.0, 22.0, 22.0 & +#endif + /) + + ! coefficient of root profile + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: beta_p & + =(/-2.051, -1.835, -1.880, -1.880, -1.632, -1.757, -1.681, -1.757& + , -1.880, -1.623, -1.623, -1.623, -2.621, -1.176, -1.452, -1.796& +#ifdef CROP + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796& + , -1.796, -1.796, -1.796, -1.796, -1.796, -1.796, -1.796 & +#endif + /) + + ! woody (1) or grass (0) + integer , parameter, dimension(0:N_PFT+N_CFT-1) :: woody & + =(/0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0 & +#ifdef CROP + , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & + , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & + , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & + , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & +#endif + /) + + ! Set the root distribution parameters of PFT + real(r8), PRIVATE, parameter :: roota(0:N_PFT+N_CFT-1) & + =(/ 0.0, 7.0, 7.0, 7.0, 7.0, 7.0, 6.0, 6.0& + , 6.0, 7.0, 7.0, 7.0, 11.0, 11.0, 11.0, 6.0& +#ifdef CROP + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0& + , 6.0, 6.0, 6.0, 6.0, 6.0, 6.0, 6.0 & +#endif + /) + + real(r8), PRIVATE, parameter :: rootb(0:N_PFT+N_CFT-1) & + =(/ 0.0, 2.0, 2.0, 2.0, 1.0, 1.0, 2.0, 2.0& + , 2.0, 1.5, 1.5, 1.5, 2.0, 2.0, 2.0, 3.0& +#ifdef CROP + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0& + , 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0 & +#endif + /) + + +! bgc PFT constants + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: grperc = 0.11_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: grpnow = 1._r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_flab = 0.25_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_fcel = 0.5_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lf_flig = 0.25_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_flab = 0.25_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_fcel = 0.5_r8 + + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fr_flig = 0.25_r8 + + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isshrub & ! True => is a shrub + =(/.False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .True., .True., .True., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isgrass & ! True => is a grass + =(/.False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .True., .True., .True., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + ! True => is tropical broadleaf evergreen tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isbetr & + =(/.False., .False., .False., .False., .True., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + ! True => is a broadleaf deciduous tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isbdtr & + =(/.False., .False., .False., .False., .False., .False., .True., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isevg & ! True => is a evergreen tree + =(/.False., .True., .True., .False., .True., .True., .False., .False. & + , .False., .True., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + ! True => is a seasonal deciduous tree + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: issed & + =(/.False., .False., .False., .True., .False., .False., .False., .True. & + , .True., .False., .False., .True., .True., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isstd & ! True => is a stress deciduous tree + =(/.False., .False., .False., .False., .False., .False., .True., .False. & + , .False., .False., .True., .False., .False., .True., .True., .True. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isbare & ! True => is a bare land + =(/.True., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: iscrop & ! True => is a crop land + =(/.False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .True. & +#ifdef CROP + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True. & +#endif + /) + + logical , parameter, dimension(0:N_PFT+N_CFT-1) :: isnatveg &! True => is a natural vegetation + =(/.False., .True., .True., .True., .True., .True., .True., .True. & + , .True., .True., .True., .True., .True., .True., .True., .False. & +#ifdef CROP + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fsr_pft & + =(/ 0., 0.26, 0.26, 0.26, 0.25, 0.25, 0.25, 0.25 & + , 0.25, 0.28, 0.28, 0.28, 0.33, 0.33, 0.33, 0.33 & +#ifdef CROP + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & + , 0.33, 0.33, 0.33, 0.33, 0.33, 0.33, 0.33 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fd_pft & + =(/ 0., 24., 24., 24., 24., 24., 24., 24. & + , 24., 24., 24., 24., 24., 24., 24., 24. & +#ifdef CROP + , 24., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: leafcn & + =(/ 1., 58., 58., 25.8131130614352 & + , 29.603315571344, 29.603315571344, 23.4521575984991, 23.4521575984991 & + , 23.4521575984991, 36.4166059723234, 23.2558139534884, 23.2558139534884 & + , 28.0269058295964, 28.0269058295964, 35.3606789250354, 28.0269058295964 & +#ifdef CROP + , 25., 25., 25., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 20. & + , 20., 20., 20., 25. & + , 25., 20., 20., 20. & + , 20., 20., 20., 25. & + , 25., 20., 20. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: frootcn & + =(/ 1., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& +#ifdef CROP + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42., 42.& + , 42., 42., 42., 42., 42., 42., 42. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: livewdcn & + =(/ 1., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 0., 0., 0., 0.& +#ifdef CROP + , 0., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: deadwdcn & + =(/ 1., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 0., 0., 0., 0.& +#ifdef CROP + , 0., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500., 500.& + , 500., 500., 500., 500., 500., 500., 500. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: graincn & + =(/-999., -999., -999., -999., -999., -999., -999., -999.& + , -999., -999., -999., -999., -999., -999., -999., -999.& +#ifdef CROP + , -999., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50., 50.& + , 50., 50., 50., 50., 50., 50., 50. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: lflitcn & + =(/ 1., 70., 80., 50., 60., 60., 50., 50.& + , 50., 60., 50., 50., 50., 50., 50., 50.& +#ifdef CROP + , 50., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25., 25.& + , 25., 25., 25., 25., 25., 25., 25. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: leaf_long & + =(/ 0., 3.30916666666667, 3.30916666666667, 0.506666666666667& + , 1.4025, 1.4025, 0.48333333333333, 0.483333333333333& + , 0.483333333333333, 1.32333333333333, 0.39, 0.39& + , 0.320833333333333, 0.32083333333333, 0.14, 0.320833333333333& +#ifdef CROP + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1., 1.& + , 1., 1., 1. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_leaf & + =(/ 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_lstem & + =(/ 0., 0.3, 0.3, 0.3, 0.27, 0.27, 0.27, 0.27& + , 0.27, 0.35, 0.35, 0.35, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_dstem & + =(/ 0., 0.3, 0.3, 0.3, 0.27, 0.27, 0.27, 0.27& + , 0.27, 0.35, 0.35, 0.35, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: cc_other & + =(/ 0., 0.5, 0.5, 0.5, 0.45, 0.45, 0.45, 0.45& + , 0.45, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_leaf & + =(/ 0., 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_lstem & + =(/ 0., 0.5, 0.5, 0.5, 0.45, 0.45, 0.35, 0.35& + , 0.45, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_lroot & + =(/ 0., 0.15, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1& + , 0.13, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2& +#ifdef CROP + , 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.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.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_root & + =(/ 0., 0.15, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1& + , 0.13, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2& +#ifdef CROP + , 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.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.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_droot & + =(/ 0., 0.15, 0.15, 0.15, 0.13, 0.13, 0.1, 0.1& + , 0.13, 0.17, 0.17, 0.17, 0.2, 0.2, 0.2, 0.2& +#ifdef CROP + , 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.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.2, 0.2, 0.2& + , 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fm_other & + =(/ 0., 0.5, 0.5, 0.5, 0.45, 0.45, 0.35, 0.35& + , 0.45, 0.55, 0.55, 0.55, 0.8, 0.8, 0.8, 0.8& +#ifdef CROP + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8& + , 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: froot_leaf & + =(/ 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, 1.5& +#ifdef CROP + , 1., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2., 2.& + , 2., 2., 2., 2., 2., 2., 2. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: croot_stem & + =(/ 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3& + , 0.3, 0.3, 0.3, 0.3, 0., 0., 0., 0.& +#ifdef CROP + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: stem_leaf & + =(/ 0., 2.3, 2.3, 1., 2.3, 1.5, 1., 2.3& + , 2.3, 1.4, 0.24, 0.24, 0., 0., 0., 0.& +#ifdef CROP + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: flivewd & + =(/ 0., 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1& + , 0.1, 0.5, 0.5, 0.1, 0., 0., 0., 0.& +#ifdef CROP + , 0., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: fcur2 & + =(/ 0., 1., 1., 0., 1., 1., 0., 0.& + , 0., 1., 0., 0., 0., 0., 0., 0.& +#ifdef CROP + , 0., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1., 1.& + , 1., 1., 1., 1., 1., 1., 1. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: dsladlai & + =(/ 0., 0.00125, 0.001, 0.003, 0.00122, 0.0015, 0.0027, 0.0027& + , 0.0027, 0., 0., 0., 0., 0., 0., 0.& +#ifdef CROP + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0., 0.& + , 0., 0., 0., 0., 0., 0., 0. & +#endif + /) + + real(r8), parameter, dimension(0:N_PFT+N_CFT-1) :: slatop & + =(/ 0., 0.01222, 0.01122, 0.02432, 0.03143, 0.02728, 0.03385, 0.03541& + , 0.0447, 0.01332, 0.02255, 0.01564, 0.01077, 0.02663, 0.01983, 0.04024& +#ifdef CROP + , 0.035, 0.05, 0.05, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.05, 0.05, 0.035, 0.035, 0.035& + , 0.035, 0.035, 0.035, 0.05, 0.05, 0.035, 0.035 & +#endif + /) +!--- crop variables --- + ! Max fertilizer to be applied in total (kg N/m2) + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: manure & + = (/ 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & +#ifdef CROP + , 0., 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020 & + , 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020, 0.0020 & + , 0.0020, 0., 0., 0., 0., 0., 0., 0. & + , 0., 0.0020, 0.0020, 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0.0020, 0.0020, 0. & + , 0., 0., 0., 0.0020, 0.0020, 0., 0., 0. & + , 0., 0., 0., 0.0020, 0.0020, 0.0020, 0.0020 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: lfemerg & ! parameter used in CNPhenology + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.11, 0.11, 0.07, 0.07, 0.03, 0.03, 0.15 & + , 0.15, 0.07, 0.07, 0.03, 0.03, 0.07, 0.07, 0.03 & + , 0.03, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.07, 0.07, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.12, 0.12, -999.9 & + , -999.9, -999.9, -999.9, 0.11, 0.11, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.11, 0.11, 0.15, 0.15 & +#endif + /) + + integer, parameter, dimension(0:N_PFT+N_CFT-1) :: mxmat & ! parameter used in CNPhenology + = (/-999, -999, -999, -999, -999, -99 , -999, -999 & + , -999, -999, -999, -999, -999, -999, -999, -999 & +#ifdef CROP + , -999, 150, 150, 150, 150, 270, 270, 150 & + , 150, 150, 150, 270, 270, 150, 150, 270 & + , 270, -999, -999, -999, -999, -999, -999, -999 & + , -999, 150, 150, -999, -999, -999, -999, -999 & + , -999, -999, -999, -999, -999, -999, -999, -999 & + , -999, -999, -999, -999, -999, 150, 150, -999 & + , -999, -999, -999, 300, 300, -999, -999, -999 & + , -999, -999, -999, 150, 150, 150, 150 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: grnfill & ! parameter used in CNPhenology + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.64, 0.64, 0.6, 0.6, 0.67, 0.67, 0.69 & + , 0.69, 0.6, 0.6, 0.67, 0.67, 0.6, 0.6, 0.67 & + , 0.67, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.6, 0.6, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.68, 0.68, -999.9 & + , -999.9, -999.9, -999.9, 0.64, 0.64, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.64, 0.64, 0.69, 0.69 & +#endif + /) + + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: baset & ! parameter used in accFlds + = (/0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & +#ifdef CROP + , 0., 8., 8., 0., 0., 0., 0., 10. & + , 10., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 10., 10., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 0., 0., 0. & + , 0., 0., 0., 0., 0., 10., 10., 0. & + , 0., 0., 0., 10., 10., 0., 0., 0. & + , 0., 0., 0., 8., 8., 10., 10. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: astemf & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.0, 0.0, 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, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.3, 0.3, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.05, 0.05, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.0, 0.0, 0.05, 0.05 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: arooti & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.4, 0.4, 0.1, 0.1, 0.1, 0.1, 0.2 & + , 0.2, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & + , 0.1, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.1, 0.1, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.1, 0.1, -999.9 & + , -999.9, -999.9, -999.9, 0.4, 0.4, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.4, 0.4, 0.2, 0.2 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: arootf & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.05, 0.05, 0.0, 0.0, 0.0, 0.0, 0.1 & + , 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 & + , 0.0, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.2, 0.2, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.0, 0.0, -999.9 & + , -999.9, -999.9, -999.9, 0.05, 0.05, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.05, 0.05, 0.1, 0.1 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) ::fleafi & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 0.8, 0.8, 0.9, 0.9, 0.9, 0.9, 0.9 & + , 0.9, 0.85, 0.85, 0.9, 0.9, 0.9, 0.9, 0.9 & + , 0.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 0.85, 0.85, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 0.75, 0.75, -999.9 & + , -999.9, -999.9, -999.9, 0.8, 0.8, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 0.8, 0.8, 0.85, 0.85 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: bfact & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 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, 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, 0.1 & + , 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: declfact & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & + , 1.05, 1.05, 1.05, 1.05, 1.05, 1.05, 1.05 & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: allconss & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 2., 2., 1., 1., 1., 1., 5. & + , 5., 1., 1., 1., 1., 1., 1., 1. & + , 1., -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 5., 5., -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 1., 1., -999.9 & + , -999.9, -999.9, -999.9, 2., 2., -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 2., 2., 5., 5. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: allconsl & ! parameter used in CNAllocation + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 5., 5., 3., 3., 3., 3., 2. & + , 2., 3., 3., 3., 3., 3., 3., 3. & + , 3., -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 2., 2., -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 3., 3., -999.9 & + , -999.9, -999.9, -999.9, 5., 5., -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 5., 5., 2., 2. & +#endif + /) + + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: fleafcn & ! C:N during grain fill; leaf + = (/999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & +#ifdef CROP + , 999., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65., 65. & + , 65., 65., 65., 65., 65., 65., 65. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: fstemcn & ! C:N during grain fill; stem + = (/999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & +#ifdef CROP + , 999., 120., 120., 100., 100., 100., 100., 130. & + , 130., 100., 100., 100., 100., 100., 100., 100. & + , 100., 999., 999., 999., 999., 999., 999., 999. & + , 999., 130., 130., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 100., 100., 999. & + , 999., 999., 999., 120., 120., 999., 999., 999. & + , 999., 999., 999., 120., 120., 130., 130. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: ffrootcn & ! C:N during grain fill; fine root + = (/999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & +#ifdef CROP + , 999., 0., 0., 40., 40., 40., 40., 0. & + , 0., 40., 40., 40., 40., 40., 40., 40. & + , 40., 999., 999., 999., 999., 999., 999., 999. & + , 999., 0., 0., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 999., 999., 999. & + , 999., 999., 999., 999., 999., 40., 40., 999. & + , 999., 999., 999., 0., 0., 999., 999., 999. & + , 999., 999., 999., 0., 0., 0., 0. & +#endif + /) + + real(r8),parameter, dimension(0:N_PFT+N_CFT-1) :: laimx & ! maximum leaf area index + = (/-999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & +#ifdef CROP + , -999.9, 5., 5., 7., 7., 7., 7., 6. & + , 6., 7., 7., 7., 7., 7., 7., 7. & + , 7., -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, 6., 6., -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, -999.9, -999.9, 7., 7., -999.9 & + , -999.9, -999.9, -999.9, 5., 5., -999.9, -999.9, -999.9 & + , -999.9, -999.9, -999.9, 5., 5., 6., 6. & +#endif + /) +#ifdef CROP + integer, parameter, dimension(0:N_PFT+N_CFT-1) :: mergetoclmpft & ! merge crop functional types + = (/0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18 & + , 19, 20, 21, 22, 23, 24, 19, 20, 21, 22, 19, 20, 21, 22, 61, 62, 19, 20, 61 & + , 62, 61, 62, 41, 42, 41, 42, 19, 20, 19, 20, 61, 62, 75, 76, 61, 62, 19, 20 & + , 19, 20, 19, 20, 61, 62, 75, 76, 19, 20, 67, 68, 19, 20, 75, 76, 75, 76, 75 & + , 76, 77, 78/) +#endif +! end bgc variables + +! Plant Hydraulics Parameters + real(r8), parameter :: kmax_sun_p(0:N_PFT+N_CFT-1) & + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#ifdef CROP + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#endif + /) + + real(r8), parameter :: kmax_sha_p(0:N_PFT+N_CFT-1) & + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#ifdef CROP + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#endif + /) + real(r8), parameter :: kmax_xyl_p(0:N_PFT+N_CFT-1) & + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#ifdef CROP + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#endif + /) + + real(r8), parameter :: kmax_root_p(0:N_PFT+N_CFT-1) & + = (/ 0.,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#ifdef CROP + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& + ,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007,1.e-007& +#endif + /) + + ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), parameter :: psi50_sun_p(0:N_PFT+N_CFT-1) & + = (/-150000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& + ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& +#ifdef CROP + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000& +#endif + /) + + ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), parameter :: psi50_sha_p(0:N_PFT+N_CFT-1) & + = (/-150000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& + ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& +#ifdef CROP + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000& +#endif + /) + + ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), parameter :: psi50_xyl_p(0:N_PFT+N_CFT-1) & + = (/-200000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& + ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& +#ifdef CROP + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000& +#endif + /) + + ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), parameter :: psi50_root_p(0:N_PFT+N_CFT-1) & + = (/-200000, -530000, -400000, -380000, -250000, -270000, -340000, -270000& + ,-200000, -400000, -390000, -390000, -340000, -340000, -340000, -340000& +#ifdef CROP + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000, -340000& + ,-340000, -340000, -340000, -340000, -340000, -340000, -340000& +#endif + /) + + ! shape-fitting parameter for vulnerability curve (-) + real(r8), parameter :: ck_p(0:N_PFT+N_CFT-1) & + = (/3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& +#ifdef CROP + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& + ,3.95, 3.95, 3.95, 3.95, 3.95, 3.95, 3.95& +#endif + /) +!end plant hydraulic parameters + + ! Temporally tune Vegetation parameter to match VGM model (soil too wet) +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), parameter :: lambda_p(0:N_PFT+N_CFT-1) & + = (/1000., 222., 383., 467., 2500., 500., 737., 428.& + , 199., 749., 751., 200., 150., 480., 800., 1000.& +#ifdef CROP + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000.& +#endif + /) +#else + real(r8), parameter :: lambda_p(0:N_PFT+N_CFT-1) & + = (/1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& +#ifdef CROP + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000., 1000.& + ,1000., 1000., 1000., 1000., 1000., 1000., 1000.& +#endif + /) +#endif + ! irrigation parameter for irrigated crop + logical , parameter :: irrig_crop(0:N_PFT+N_CFT-1) & + =(/.False., .False., .False., .False., .False., .False., .False., .False. & + , .False., .False., .False., .False., .False., .False., .False., .False. & +#ifdef CROP + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True., .False. & + , .True., .False., .True., .False., .True., .False., .True. & +#endif + /) + + + ! scheme 1: Schenk and Jackson, 2002, 2: Zeng 2001 + integer, PRIVATE :: ROOTFR_SCHEME = 1 + + !fraction of roots in each soil layer +#ifdef CROP + real(r8), dimension(nl_soil,N_PFT+N_CFT) :: & + rootfr_p(1:nl_soil, 0:N_PFT+N_CFT-1) +#else + real(r8), dimension(nl_soil,N_PFT) :: & + rootfr_p(1:nl_soil, 0:N_PFT-1) +#endif + + integer, PRIVATE :: i, nsl + + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: Init_PFT_Const + +CONTAINS + + SUBROUTINE Init_PFT_Const + + IMPLICIT NONE + + rho_p(1,1,:) = rhol_vis_p(:) + rho_p(2,1,:) = rhol_nir_p(:) + rho_p(1,2,:) = rhos_vis_p(:) + rho_p(2,2,:) = rhos_nir_p(:) + tau_p(1,1,:) = taul_vis_p(:) + tau_p(2,1,:) = taul_nir_p(:) + tau_p(1,2,:) = taus_vis_p(:) + tau_p(2,2,:) = taus_nir_p(:) + +IF (ROOTFR_SCHEME == 1) THEN +#ifdef CROP + DO i = 0, N_PFT+N_CFT-1 +#else + DO i = 0, N_PFT-1 +#endif + rootfr_p(1,i)=1./(1.+(zi_soi(1)*100./d50_p(i))**beta_p(i)) + rootfr_p(nl_soil,i)=1.-1./(1.+(zi_soi(nl_soil-1)*100./d50_p(i))**beta_p(i)) + + DO nsl=2,nl_soil-1 + rootfr_p(nsl,i)=1./(1.+(zi_soi(nsl)*100./d50_p(i))**beta_p(i)) & + -1./(1.+(zi_soi(nsl-1)*100./d50_p(i))**beta_p(i)) + ENDDO + ENDDO +ELSE + ! PFT rootfr_p (Zeng, 2001) +#ifdef CROP + DO i = 0, N_PFT+N_CFT-1 +#else + DO i = 0, N_PFT-1 +#endif + rootfr_p(1,i) = 1. - 0.5*( & + exp(-roota(i) * zi_soi(1)) & + + exp(-rootb(i) * zi_soi(1)) ) + + rootfr_p(nl_soil,i) = 0.5*( & + exp(-roota(i) * zi_soi(nl_soil)) & + + exp(-rootb(i) * zi_soi(nl_soil)) ) + + DO nsl = 2, nl_soil-1 + rootfr_p(nsl,i) = 0.5*( & + exp(-roota(i) * zi_soi(nsl-1)) & + + exp(-rootb(i) * zi_soi(nsl-1)) & + - exp(-roota(i) * zi_soi(nsl)) & + - exp(-rootb(i) * zi_soi(nsl)) ) + ENDDO + ENDDO +ENDIF + + + END SUBROUTINE Init_PFT_Const + +END MODULE MOD_Const_PFT +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_Physical.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_Physical.F90 new file mode 100644 index 0000000000..2a9e8e5b6e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Const_Physical.F90 @@ -0,0 +1,30 @@ +MODULE MOD_Const_Physical + +!======================================================================= +! physical constants +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + + PUBLIC + real(r8), parameter :: denice = 917. ! density of ice [kg/m3] + real(r8), parameter :: denh2o = 1000. ! density of liquid water [kg/m3] + real(r8), parameter :: cpliq = 4188. ! Specific heat of water [J/kg/K] + real(r8), parameter :: cpice = 2117.27 ! Specific heat of ice [J/kg/K] + real(r8), parameter :: cpair = 1004.64 ! specific heat of dry air [J/kg/K] + real(r8), parameter :: hfus = 0.3336e6 ! latent heat of fusion for ice [J/kg] + real(r8), parameter :: hvap = 2.5104e6 ! latent heat of evap for water [J/kg] + real(r8), parameter :: hsub = 2.8440e6 ! latent heat of sublimation [J/kg] + real(r8), parameter :: tkair = 0.023 ! thermal conductivity of air [W/m/k] + real(r8), parameter :: tkice = 2.290 ! thermal conductivity of ice [W/m/k] + real(r8), parameter :: tkwat = 0.6 ! thermal conductivity of water [W/m/k] + real(r8), parameter :: tfrz = 273.16 ! freezing temperature [K] + real(r8), parameter :: rgas = 287.04 ! gas constant for dry air [J/kg/K] + real(r8), parameter :: roverg = 4.71047e4 ! rw/g = (8.3144/0.018)/(9.80616)*1000. mm/K + real(r8), parameter :: rwat = 461.296 ! gas constant for water vapor [J/(kg K)] + real(r8), parameter :: grav = 9.80616 ! gravity constant [m/s2] + real(r8), parameter :: vonkar = 0.4 ! von Karman constant [-] + real(r8), parameter :: stefnc = 5.67e-8 ! Stefan-Boltzmann constant [W/m2/K4] + +END MODULE MOD_Const_Physical diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Eroot.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Eroot.F90 new file mode 100644 index 0000000000..333547bc1f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Eroot.F90 @@ -0,0 +1,156 @@ +#include + +MODULE MOD_Eroot + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: eroot + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE eroot (nl_soil,trsmx0,porsl, & +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + psi0,rootfr, dz_soisno,t_soisno,wliq_soisno,rootr,etrc,rstfac) + +!======================================================================= +! !DESCRIPTION: +! effective root fraction and maximum possible transpiration rate +! +! Original author: Yongjiu Dai, 08/30/2002 +! +! !REVISIONS: +! 09/2021, Shupeng Zhang and Xingjie Lu: add vanGenuchten scheme to +! calculate soil water potential. +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: denh2o + USE MOD_Namelist, only: DEF_RSTFAC + USE MOD_Const_Physical, only: tfrz +#ifdef vanGenuchten_Mualem_SOIL_MODEL + USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq, soil_vliq_from_psi +#endif + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: nl_soil ! upper bound of array + + real(r8), intent(in) :: trsmx0 ! max transpiration for moist soil+100% veg.[mm/s] + real(r8), intent(in) :: porsl(1:nl_soil) ! soil porosity [-] +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw(1:nl_soil) ! Clapp-Hornberger "B" +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil) + real(r8), intent(in) :: alpha_vgm(1:nl_soil) + real(r8), intent(in) :: n_vgm (1:nl_soil) + real(r8), intent(in) :: L_vgm (1:nl_soil) + real(r8), intent(in) :: sc_vgm (1:nl_soil) + real(r8), intent(in) :: fc_vgm (1:nl_soil) +#endif + real(r8), intent(in) :: psi0(1:nl_soil) ! saturated soil suction (mm) (NEGATIVE) + real(r8), intent(in) :: rootfr(1:nl_soil) ! fraction of roots in a layer, + real(r8), intent(in) :: dz_soisno(1:nl_soil) ! layer thickness (m) + real(r8), intent(in) :: t_soisno(1:nl_soil) ! soil/snow skin temperature (K) + real(r8), intent(in) :: wliq_soisno(1:nl_soil) ! liquid water (kg/m2) + + real(r8), intent(out) :: rootr(1:nl_soil) ! root resistance of a layer, all layers add to 1 + real(r8), intent(out) :: etrc ! maximum possible transpiration rate (mm h2o/s) + real(r8), intent(out) :: rstfac ! factor of soil water stress for photosynthesis + +!-------------------------- Local Variables ---------------------------- + + real(r8) roota ! accumulates root resistance factors + real(r8) rresis(1:nl_soil) ! soil water contribution to root resistance + real(r8) s_node ! vol_liq/porosity + real(r8) smpmax ! wilting point potential in mm + real(r8) smp_node ! matrix potential + + !new method to calculate root resistance + real(r8) :: smpswc = -1.5e5 ! soil water potential at wilting point (mm) + real(r8) :: smpsfc = -3.3e3 ! soil water potential at field capacity (mm) + real(r8) :: liqswc, liqsfc, liqsat ! liquid water content at wilting point, field capacity, and saturation (kg/m2) + + integer i ! loop counter + +!----------------------------------------------------------------------- + IF (DEF_RSTFAC == 1) THEN + ! transpiration potential(etrc) and root resistance factors (rstfac) + + roota = 1.e-10 ! must be non-zero to begin + DO i = 1, nl_soil + + IF(t_soisno(i)>tfrz .and. porsl(i)>=1.e-6)THEN + smpmax = -1.5e5 + s_node = max(wliq_soisno(i)/(1000.*dz_soisno(i)*porsl(i)),0.001) + s_node = min(1., s_node) +#ifdef Campbell_SOIL_MODEL + smp_node = max(smpmax, psi0(i)*s_node**(-bsw(i))) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + smp_node = soil_psi_from_vliq ( s_node*(porsl(i)-theta_r(i)) + theta_r(i), & + porsl(i), theta_r(i), psi0(i), & + 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) + smp_node = max(smpmax, smp_node) +#endif + rresis(i) =(1.-smp_node/smpmax)/(1.-psi0(i)/smpmax) + rootr(i) = rootfr(i)*rresis(i) + roota = roota + rootr(i) + ELSE + rootr(i) = 0. + ENDIF + ENDDO + ELSEIF (DEF_RSTFAC == 2) THEN + !new method to calculate root resistance + roota = 1.e-10 + DO i = 1, nl_soil + IF(t_soisno(i)>tfrz .and. porsl(i)>=1.e-6)THEN +#ifdef Campbell_SOIL_MODEL + liqswc = denh2o*dz_soisno(i)*porsl(i)*((smpswc/psi0(i))**(-1/bsw(i))) + liqsfc = denh2o*dz_soisno(i)*porsl(i)*((smpsfc/psi0(i))**(-1/bsw(i))) + liqsat = denh2o*dz_soisno(i)*porsl(i) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + liqswc = soil_vliq_from_psi(smpswc, porsl(i), theta_r(i), psi0(i), 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) + liqswc = denh2o*dz_soisno(i)*liqswc + liqsfc = soil_vliq_from_psi(smpsfc, porsl(i), theta_r(i), psi0(i), 5, (/alpha_vgm(i), n_vgm(i), L_vgm(i), sc_vgm(i), fc_vgm(i)/)) + liqsfc = denh2o*dz_soisno(i)*liqsfc + liqsat = denh2o*dz_soisno(i)*porsl(i) +#endif + rresis(i) = (wliq_soisno(i)-liqswc)/(liqsfc-liqswc) + rresis(i) = min(1.0, rresis(i)) + rresis(i) = max(0.0, rresis(i)) + rootr(i) = rootfr(i)*rresis(i) + roota = roota + rootr(i) + ELSE + rootr(i) = 0. + ENDIF + ENDDO + ENDIF + + ! normalize root resistances to get layer contribution to ET + rootr(:) = rootr(:)/roota + + ! determine maximum possible transpiration rate + etrc = trsmx0*roota + rstfac = roota + + END SUBROUTINE eroot + +END MODULE MOD_Eroot diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 new file mode 100644 index 0000000000..92f68e3262 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FireData.F90 @@ -0,0 +1,139 @@ +#include + +#ifdef BGC +MODULE MOD_FireData +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module read in fire data. +! +! Original: +! 2023, Lu Xingjie and Zhang Shupeng: prepare the original version of +! the fire data module. +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_SpatialMapping + USE MOD_Vars_TimeInvariants, only: abm_lf, gdp_lf, peatf_lf + USE MOD_Vars_TimeVariables, only: hdm_lf + IMPLICIT NONE + + character(len=256) :: file_fire + + type(grid_type) :: grid_fire + type(spatial_mapping_type) :: mg2p_fire + +CONTAINS + + SUBROUTINE init_fire_data (YY) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open fire netcdf file from DEF_dir_runtime, read latitude and +! longitude info. Initialize fire data read in. +!----------------------------------------------------------------------- + + USE MOD_MPAS_MPI + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: YY + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + type(block_data_real8_2d) :: f_xy_fire + + file_fire = trim(DEF_dir_runtime) // '/fire/abm_colm_double_fillcoast.nc' + + CALL ncio_read_bcast_serial (file_fire, 'lat', lat) + CALL ncio_read_bcast_serial (file_fire, 'lon', lon) + + CALL grid_fire%define_by_center (lat, lon) + + CALL mg2p_fire%build_arealweighted (grid_fire, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + IF (.true.) THEN + CALL allocate_block_data (grid_fire, f_xy_fire) + ENDIF + + file_fire = trim(DEF_dir_runtime) // '/fire/abm_colm_double_fillcoast.nc' + IF (.true.) THEN + CALL ncio_read_block (file_fire, 'abm', grid_fire, f_xy_fire) + ENDIF + CALL mg2p_fire%grid2pset (f_xy_fire, abm_lf) +#ifdef RangeCheck + CALL check_vector_data ('abm', abm_lf) +#endif + + file_fire = trim(DEF_dir_runtime) // '/fire/peatf_colm_360x720_c100428.nc' + IF (.true.) THEN + CALL ncio_read_block (file_fire, 'peatf', grid_fire, f_xy_fire) + ENDIF + CALL mg2p_fire%grid2pset (f_xy_fire, peatf_lf) +#ifdef RangeCheck + CALL check_vector_data ('peatf', peatf_lf) +#endif + + file_fire = trim(DEF_dir_runtime) // '/fire/gdp_colm_360x720_c100428.nc' + IF (.true.) THEN + CALL ncio_read_block (file_fire, 'gdp', grid_fire, f_xy_fire) + ENDIF + CALL mg2p_fire%grid2pset (f_xy_fire, gdp_lf) +#ifdef RangeCheck + CALL check_vector_data ('gdp', gdp_lf) +#endif + + CALL update_hdm_data (YY) + + END SUBROUTINE init_fire_data + + SUBROUTINE update_hdm_data (YY) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Read in the Fire data from CLM5 dataset (month when crop fire peak +! (abm), GDP, peatland fraction (peatf), and population density +! +! Original: Xingjie Lu and Shupeng Zhang, 2022 +!----------------------------------------------------------------------- + + USE MOD_MPAS_MPI + USE MOD_DataType + USE MOD_Namelist + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: YY + + ! Local Variables + type(block_data_real8_2d) :: f_xy_fire + integer :: itime + + itime = max(1850,min(YY,2016)) - 1849 + + file_fire = trim(DEF_dir_runtime) & + // '/fire/colmforc.Li_2017_HYDEv3.2_CMIP6_hdm_0.5x0.5_AVHRR_simyr1850-2016_c180202.nc' + + IF (.true.) THEN + CALL allocate_block_data (grid_fire, f_xy_fire) + CALL ncio_read_block_time (file_fire, 'hdm', grid_fire, itime, f_xy_fire) + ENDIF + + CALL mg2p_fire%grid2pset (f_xy_fire, hdm_lf) + +#ifdef RangeCheck + CALL check_vector_data ('hdm', hdm_lf) +#endif + + END SUBROUTINE update_hdm_data + +END MODULE MOD_FireData +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_FrictionVelocity.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FrictionVelocity.F90 new file mode 100644 index 0000000000..2a93a983f3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_FrictionVelocity.F90 @@ -0,0 +1,572 @@ +MODULE MOD_FrictionVelocity + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: moninobuk + PUBLIC :: moninobukm + PUBLIC :: moninobukini + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: psi + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE moninobuk(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of friction velocity, relation for potential temperature +! and humidity profiles of surface boundary layer. +! the scheme is based on the work of Zeng et al. (1998): +! Intercomparison of bulk aerodynamic algorithms for the computation of +! sea surface fluxes using TOGA CORE and TAO data. J. Climate, Vol. +! 11: 2628-2644 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stability effect [m/s] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fm10m ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + +! real(r8), external :: psi ! stability FUNCTION for unstable case +!----------------------------------------------------------------------- +! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + +! wind profile + zldis=hu-displa + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fm = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ustar = vonkar*um / fm + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + + ! for 10 meter wind-velocity + zldis=10.+z0m + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fm10m = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fm10m = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm10m = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fm10m = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! temperature profile + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! humidity profile + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen humidity + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobuk + + + SUBROUTINE moninobukm(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt,& + ustar,fh2m,fq2m,htop,fmtop,fm,fh,fq,fht,fqt,phih) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of friction velocity, relation for potential temperature +! and humidity profiles of surface boundary layer. the scheme is based +! on the work of Zeng et al. (1998): Intercomparison of bulk aerodynamic +! algorithms for the computation of sea surface fluxes using TOGA CORE +! and TAO data. J. Climate, Vol. 11: 2628-2644 +! +! !REVISIONS: +! 09/2017, Hua Yuan: adapted from moninobuk FUNCTION to calculate canopy +! top fm, fq and phih for roughness sublayer u/k profile +! calculation. +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: displat ! displacement height of the top layer [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: z0mt ! roughness length of the top layer, latent heat [m] + real(r8), intent(in) :: htop ! canopy top height of the top layer [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stability effect [m/s] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fmtop ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + real(r8), intent(out) :: fht ! integral of profile FUNCTION for heat at the top layer + real(r8), intent(out) :: fqt ! integral of profile FUNCTION for moisture at the top layer + real(r8), intent(out) :: phih ! phi(h), similarity FUNCTION for sensible heat + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + +! real(r8), external :: psi ! stability FUNCTION for unstable case +!----------------------------------------------------------------------- +! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + +! wind profile + zldis=hu-displa + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fm = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ustar = vonkar*um / fm + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + + ! for canopy top wind-velocity + !NOTE: changed for canopy top wind-velocity (no wake assumed) + zldis=htop-displa + zeta=zldis/obu + zetam=1.574 + IF(zeta < -zetam)THEN ! zeta < -1 + fmtop = log(-zetam*obu/z0m) - psi(1,-zetam) & + + psi(1,z0m/obu) + 1.14*((-zeta)**0.333-(zetam)**0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fmtop = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fmtop = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fmtop = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! temperature profile + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for top layer temperature + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fht = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fht = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fht = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fht = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for canopy top phi(h) + ! CESM TECH NOTE EQ. (5.31) + zldis=htop-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + phih = (1. - 16.*zeta)**(-0.5) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + phih = 1. + 5.*zeta + ELSE ! 1 < zeta, phi=5+zeta + phih = 5. + zeta + ENDIF + +! humidity profile + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + ! for 2 meter screen humidity + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + ! for top layer humidity + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fqt = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fqt = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fqt = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fqt = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobukm + + real(r8) FUNCTION kmoninobuk(displa,obu,ustar,z) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! k profile calculation for bare ground case +! +! Created by Hua Yuan, 09/2017 +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: ustar ! friction velocity [m/s] + real(r8), intent(in) :: z ! height of windspeed [m] + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) phih ! phi(h), similarity FUNCTION for sensible heat + +!----------------------------------------------------------------------- + + IF ( z .le. displa ) THEN + kmoninobuk = 0. + RETURN + ENDIF + + ! for canopy top phi(h) + zldis=z-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + phih = (1. - 16.*zeta)**(-0.5) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + phih = 1. + 5.*zeta + ELSE ! 1 < zeta, phi=5+zeta + phih = 5. + zeta + ENDIF + + kmoninobuk = vonkar*(z-displa)*ustar/phih + + END FUNCTION kmoninobuk + + real(r8) FUNCTION kintmoninobuk(displa,z0h,obu,ustar,ztop,zbot) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! k profile integration for bare ground case +! +! Created by Hua Yuan, 09/2017 +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: ustar ! friction velocity [m/s] + real(r8), intent(in) :: ztop ! height top + real(r8), intent(in) :: zbot ! height bottom + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + + real(r8) :: fh_top, fh_bot ! integral of profile FUNCTION for heat + +!----------------------------------------------------------------------- + + zldis=ztop-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh_top = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh_top = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh_top = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh_top = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + zldis=zbot-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh_bot = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh_bot = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh_bot = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh_bot = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + + kintmoninobuk = (fh_top-fh_bot)/(vonkar*ustar) + + END FUNCTION kintmoninobuk + + + SUBROUTINE moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) + +! ====================================================================== +! Original author: Yongjiu Dai, September 15, 1999 +! +! initialization of Monin-Obukhov length, +! the scheme is based on the work of Zeng et al. (1998): +! Intercomparison of bulk aerodynamic algorithms for the computation +! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, Vol. +! 11: 2628-2644 +! ====================================================================== + + USE MOD_Precision + USE MOD_Const_Physical, only: grav, vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: ur ! wind speed at reference height [m/s] + real(r8), intent(in) :: thm ! intermediate variable (tm+0.0098*ht) + real(r8), intent(in) :: th ! potential temperature [kelvin] + real(r8), intent(in) :: thv ! virtual potential temperature (kelvin) + real(r8), intent(in) :: dth ! diff of virtual temp. between ref. height and surface + real(r8), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8), intent(in) :: dqh ! diff of humidity between ref. height and surface + real(r8), intent(in) :: zldis ! reference height "minus" zero displacement height [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + + real(r8), intent(out) :: um ! wind speed including the stability effect [m/s] + real(r8), intent(out) :: obu ! monin-obukhov length (m) + +!-------------------------- Local Variables ---------------------------- + real(r8) wc ! convective velocity [m/s] + real(r8) rib ! bulk Richardson number + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + +!----------------------------------------------------------------------- +! Initial values of u* and convective velocity + + wc=0.5 + IF(dthv >= 0.)THEN + um=max(ur,0.1) + ELSE + um=sqrt(ur*ur+wc*wc) + ENDIF + + rib=grav*zldis*dthv/(thv*um*um) + + IF(rib >= 0.)THEN ! neutral or stable + zeta = rib*log(zldis/z0m)/(1.-5.*min(rib,0.19)) + zeta = min(2.,max(zeta,1.e-6)) + ELSE ! unstable + zeta = rib*log(zldis/z0m) + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu=zldis/zeta + + END SUBROUTINE moninobukini + + + real(r8) FUNCTION psi(k,zeta) + +!======================================================================= +! stability FUNCTION for unstable case (rib < 0) + + USE MOD_Precision + IMPLICIT NONE + + integer k + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) chik ! + + chik = (1.-16.*zeta)**0.25 + IF(k == 1)THEN + psi = 2.*log((1.+chik)*0.5)+log((1.+chik*chik)*0.5)-2.*atan(chik)+2.*atan(1.) + ELSE + psi = 2.*log((1.+chik*chik)*0.5) + ENDIF + + END FUNCTION psi + +END MODULE MOD_FrictionVelocity +! --------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 new file mode 100644 index 0000000000..34e84dd24d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90 @@ -0,0 +1,1143 @@ +#include + +MODULE MOD_Glacier + +!----------------------------------------------------------------------- +! Energy and Mass Balance Model of LAND ICE (GLACIER / ICE SHEET) +! +! Original author: Yongjiu Dai, /05/2014/ +! +! !REVISIONS: +! 01/2023, Hua Yuan: added GLACIER_WATER_snicar() to account for SNICAR +! model effects on snow water [see snowwater_snicar()], snow +! layers combine [see snowlayerscombine_snicar()], snow layers +! divide [see snowlayersdivide_snicar()] +! +! 01/2023, Hua Yuan: added snow layer absorption in GLACIER_TEMP() +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: GLACIER_TEMP + PUBLIC :: GLACIER_WATER + PUBLIC :: GLACIER_WATER_snicar + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: groundfluxes_glacier + PRIVATE :: groundtem_glacier + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE GLACIER_TEMP (patchtype,lb ,nl_ice ,deltim ,& + zlnd ,zsno ,capr ,cnfac ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_hpbl ,& + forc_rhoair ,forc_psrf ,coszen ,sabg ,& + forc_frl ,fsno ,dz_icesno ,z_icesno ,& + zi_icesno ,t_icesno ,wice_icesno ,wliq_icesno ,& + scv ,snowdp ,imelt ,taux ,& + tauy ,fsena ,fevpa ,lfevpa ,& + fseng ,fevpg ,olrg ,fgrnd ,& + qseva ,qsdew ,qsubl ,qfros ,& + sm ,tref ,qref ,trad ,& + errore ,emis ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,pg_rain ,& + pg_snow ,t_precip ,snofrz ,sabg_snow_lyr) + +!----------------------------------------------------------------------- +! this is the main SUBROUTINE to execute the calculation of thermal processes +! and surface fluxes of the land ice (glacier and ice sheet) +! +! Original author: Yongjiu Dai and Nan Wei, /05/2014/ +! Modified by Nan Wei, 07/2017/ interaction btw prec and land ice +! FLOW DIAGRAM FOR GLACIER_TEMP.F90 +! +! GLACIER_TEMP ===> qsadv +! groundfluxes | ---------> |moninobukini +! | |moninobuk +! +! groundTem | ---------> |meltf +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: hvap,hsub,rgas,cpair,stefnc,tfrz,cpliq,cpice + USE MOD_FrictionVelocity + USE MOD_Qsadv + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: & + patchtype,& ! land patch type (0=soil, 1=urban and built-up, + ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + lb, &! lower bound of array + nl_ice ! upper bound of array + + real(r8), intent(in) :: & + deltim, &! model time step [second] + zlnd, &! roughness length for ice surface [m] + zsno, &! roughness length for snow [m] + capr, &! tuning factor to turn first layer T into surface T + cnfac, &! Crank Nicholson factor between 0 and 1 + + ! Atmospherical variables and observational height + forc_hgt_u, &! observational height of wind [m] + forc_hgt_t, &! observational height of temperature [m] + forc_hgt_q, &! observational height of humidity [m] + forc_us, &! wind component in eastward direction [m/s] + forc_vs, &! wind component in northward direction [m/s] + forc_t, &! temperature at agcm reference height [kelvin] + forc_q, &! specific humidity at agcm reference height [kg/kg] + forc_rhoair, &! density air [kg/m3] + forc_psrf, &! atmosphere pressure at the surface [pa] + t_precip, &! snowfall/rainfall temperature [kelvin] + pg_rain, &! rainfall [kg/(m2 s)] + pg_snow, &! snowfall [kg/(m2 s)] + forc_hpbl, &! atmospheric boundary layer height [m] + + ! Radiative fluxes + coszen, &! cosine of the solar zenith angle + sabg, &! solar radiation absorbed by ground [W/m2] + forc_frl, &! atmospheric infrared (longwave) radiation [W/m2] + + ! State variable (1) + fsno, &! fraction of ground covered by snow + dz_icesno(lb:nl_ice), &! layer thickness [m] + z_icesno (lb:nl_ice), &! node depth [m] + zi_icesno(lb-1:nl_ice) ! interface depth [m] + + real(r8), intent(in) :: & + sabg_snow_lyr (lb:1) ! snow layer absorption [W/m-2] + + ! State variables (2) + real(r8), intent(inout) :: & + t_icesno(lb:nl_ice), &! snow/ice temperature [K] + wice_icesno(lb:nl_ice),&! ice lens [kg/m2] + wliq_icesno(lb:nl_ice),&! liquid water [kg/m2] + scv, &! snow cover, water equivalent [mm, kg/m2] + snowdp ! snow depth [m] + + real(r8), intent(inout) :: & + snofrz (lb:0) ! snow freezing rate (lyr) [kg m-2 s-1] + + integer, intent(out) :: & + imelt(lb:nl_ice) ! flag for melting or freezing [-] + + ! Output fluxes + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsena, &! sensible heat to atmosphere [W/m2] + lfevpa, &! latent heat flux to atmosphere [W/m2] + fseng, &! sensible heat flux from ground [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + olrg, &! outgoing long-wave radiation to atmosphere + fgrnd, &! ground heat flux [W/m2] + + fevpa, &! evapotranspiration to atmosphere (mm h2o/s) + qseva, &! ground surface evaporation rate (mm h2o/s) + qsdew, &! ground surface dew formation (mm h2o /s) [+] + qsubl, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros, &! surface dew added to snow pack (mm h2o /s) [+] + + sm, &! rate of snowmelt [kg/(m2 s)] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air specific humidity + trad, &! radiative temperature [K] + + emis, &! averaged bulk surface emissivity + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! u* in similarity theory [m/s] + qstar, &! q* in similarity theory [kg/kg] + tstar, &! t* in similarity theory [K] + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + integer i,j + + real(r8) :: & + cgrnd, &! deriv. of ice energy flux wrt to ice temp [w/m2/k] + cgrndl, &! deriv, of ice sensible heat flux wrt ice temp [w/m2/k] + cgrnds, &! deriv of ice latent heat flux wrt ice temp [w/m**2/k] + degdT, &! d(eg)/dT + dqgdT, &! d(qg)/dT + eg, &! water vapor pressure at temperature T [pa] + egsmax, &! max. evaporation which ice can provide at one time step + egidif, &! the excess of evaporation over "egsmax" + emg, &! ground emissivity (0.96) + errore, &! energy balance error [w/m2] + fact(lb:nl_ice), &! used in computing tridiagonal matrix + htvp, &! latent heat of vapor of water (or sublimation) [j/kg] + qg, &! ground specific humidity [kg/kg] + qsatg, &! saturated humidity [kg/kg] + qsatgdT, &! d(qsatg)/dT + qred, &! ice surface relative humidity + thm, &! intermediate variable (forc_t+0.0098*forc_hgt_t) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + t_grnd, &! ground surface temperature [K] + t_icesno_bef(lb:nl_ice), &! ice/snow temperature before update + tinc, &! temperature difference of two time step + ur, &! wind speed at reference height [m/s] + xmf ! total latent heat of phase change of ground water + +!======================================================================= +! [1] Initial set and propositional variables +!======================================================================= + + ! temperature and water mass from previous time step + t_grnd = t_icesno(lb) + t_icesno_bef(lb:) = t_icesno(lb:) + + ! emissivity + emg = 0.97 + + ! latent heat, assumed that the sublimation occurs only as wliq_icesno=0 + htvp = hvap + IF(wliq_icesno(lb)<=0. .and. wice_icesno(lb)>0.) htvp = hsub + + ! potential temperature at the reference height + thm = forc_t + 0.0098*forc_hgt_t ! intermediate variable equivalent to + ! forc_t*(pgcm/forc_psrf)**(rgas/cpair) + th = forc_t*(100000./forc_psrf)**(rgas/cpair) ! potential T + thv = th*(1.+0.61*forc_q) ! virtual potential T + ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) ! limit set to 0.1 + +!======================================================================= +! [2] specific humidity and its derivative at ground surface +!======================================================================= + + qred = 1. + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) + + qg = qred*qsatg + dqgdT = qred*qsatgdT + +!======================================================================= +! [3] Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!======================================================================= + + CALL groundfluxes_glacier (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,& + forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & + ur,thm,th,thv,t_grnd,qg,dqgdT,htvp,& + forc_hpbl,& + fsno,cgrnd,cgrndl,cgrnds,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq) + +!======================================================================= +! [4] Ground temperature +!======================================================================= + + CALL groundtem_glacier (patchtype,lb,nl_ice,deltim,& + capr,cnfac,dz_icesno,z_icesno,zi_icesno,& + t_icesno,wice_icesno,wliq_icesno,scv,snowdp,& + forc_frl,sabg,sabg_snow_lyr,fseng,fevpg,cgrnd,htvp,emg,& + imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) + +!======================================================================= +! [5] Correct fluxes to present ice temperature +!======================================================================= + + t_grnd = t_icesno(lb) + tinc = t_icesno(lb) - t_icesno_bef(lb) + fseng = fseng + tinc*cgrnds + fevpg = fevpg + tinc*cgrndl + +! calculation of evaporative potential; flux in kg m-2 s-1. +! egidif holds the excess energy IF all water is evaporated +! during the timestep. this energy is later added to the sensible heat flux. + + egsmax = (wice_icesno(lb)+wliq_icesno(lb)) / deltim + + egidif = max( 0., fevpg - egsmax ) + fevpg = min ( fevpg, egsmax ) + fseng = fseng + htvp*egidif + +! total fluxes to atmosphere + fsena = fseng + fevpa = fevpg + lfevpa= htvp*fevpg ! W/m^2 (accounting for sublimation) + + qseva = 0. + qsubl = 0. + qfros = 0. + qsdew = 0. + + IF(fevpg >= 0)THEN + qseva = min(wliq_icesno(lb)/deltim, fevpg) + qsubl = fevpg - qseva + ELSE + IF(t_grnd < tfrz)THEN + qfros = abs(fevpg) + ELSE + qsdew = abs(fevpg) + ENDIF + ENDIF + +! ground heat flux + fgrnd = sabg + emg*forc_frl & + - emg*stefnc*t_icesno_bef(lb)**3*(t_icesno_bef(lb) + 4.*tinc) & + - (fseng+fevpg*htvp) & + + cpliq * pg_rain * (t_precip - t_icesno(lb)) & + + cpice * pg_snow * (t_precip - t_icesno(lb)) + +! outgoing long-wave radiation from ground + olrg = (1.-emg)*forc_frl + emg*stefnc * t_icesno_bef(lb)**4 & +! for conservation we put the increase of ground longwave to outgoing + + 4.*emg*stefnc*t_icesno_bef(lb)**3*tinc + +! averaged bulk surface emissivity + emis = emg + +! radiative temperature + trad = (olrg/stefnc)**0.25 + +!======================================================================= +! [6] energy balance error +!======================================================================= + + errore = sabg + forc_frl - olrg - fsena - lfevpa - xmf & + + cpliq * pg_rain * (t_precip-t_icesno(lb)) & + + cpice * pg_snow * (t_precip-t_icesno(lb)) + DO j = lb, nl_ice + errore = errore - (t_icesno(j)-t_icesno_bef(j))/fact(j) + ENDDO + +#if (defined CoLMDEBUG) + IF(abs(errore)>.2)THEN + write(6,*) 'GLACIER_TEMP.F90 : energy balance violation' + write(6,100) errore,sabg,forc_frl,olrg,fsena,lfevpa,xmf,t_precip,t_icesno(lb) + CALL CoLM_stop('GLACIER_TEMP energy balance violation.') + ENDIF +100 format(10(f7.3)) +#endif + + END SUBROUTINE GLACIER_TEMP + + + + SUBROUTINE groundfluxes_glacier (zlnd,zsno,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,& + ur,thm,th,thv,t_grnd,qg,dqgdT,htvp,& + hpbl,& + fsno,cgrnd,cgrndl,cgrnds,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq) + +!======================================================================= +! this is the main SUBROUTINE to execute the calculation of thermal processes +! and surface fluxes of land ice (glacier and ice sheet) +! +! Original author: Yongjiu Dai and Nan Wei, /05/2014/ +! +! !REVISIONS: +! 05/2023, Shaofeng Liu: add option to CALL moninobuk_leddy, the LargeEddy +! surface turbulence scheme (LZD2022); make a proper update of um. +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT + USE MOD_TurbulenceLEddy + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + zlnd, &! roughness length for ice [m] + zsno, &! roughness length for snow [m] + + ! atmospherical variables and observational height + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] [not used] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + fsno, &! fraction of ground covered by snow + + ur, &! wind speed at reference height [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + + t_grnd, &! ground surface temperature [K] + qg, &! ground specific humidity [kg/kg] + dqgdT, &! d(qg)/dT + htvp ! latent heat of vapor of water (or sublimation) [j/kg] + real(r8), intent(in) :: & + hpbl ! atmospheric boundary layer height [m] + + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsena, &! sensible heat to atmosphere [W/m2] + fevpa, &! evapotranspiration to atmosphere [mm/s] + fseng, &! sensible heat flux from ground [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + cgrnd, &! deriv. of ice energy flux wrt to ice temp [w/m2/k] + cgrndl, &! deriv, of ice sensible heat flux wrt ice temp [w/m2/k] + cgrnds, &! deriv of ice latent heat flux wrt ice temp [w/m**2/k] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air humidity + + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + integer niters, &! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + raih, &! temporary variable [kg/m2/s] + raiw, &! temporary variable [kg/m2/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile FUNCTION for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0hg, &! roughness length over ground, sensible heat [m] + z0qg ! roughness length over ground, latent heat [m] + +!----------------------------------------------------------------------- +! initial roughness length + IF(fsno > 0.)THEN + ! z0mg = zsno + z0mg = 0.002 ! Table 1 of Brock et al., (2006) + z0hg = z0mg + z0qg = z0mg + ELSE + ! z0mg = zlnd + z0mg = 0.001 ! Table 1 of Brock et al., (2006) + z0hg = z0mg + z0qg = z0mg + ENDIF + +! potential temperature at the reference height + beta = 1. ! - (in computing W_*) + zii = 1000. ! m (pbl height) + z0m = z0mg + +!----------------------------------------------------------------------- +! Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!----------------------------------------------------------------------- +! Initialization variables + nmozsgn = 0 + obuold = 0. + + dth = thm-t_grnd + dqh = qm-qg + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-0. + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + +! Evaluated stability-dependent variables using moz from prior iteration + niters=6 + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters ! begin stability iteration + !---------------------------------------------------------------- + displax = 0. + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um, hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF(zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF(zeta >= 0.)THEN + um = max(ur,0.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION ! END stability iteration + !---------------------------------------------------------------- + +! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + + raih = rhoair*cpair/rah + raiw = rhoair/raw + cgrnds = raih + cgrndl = raiw*dqgdT + cgrnd = cgrnds + htvp*cgrndl + + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! surface fluxes of momentum, sensible and latent +! using ground temperatures from previous time step + taux = -rhoair*us/ram + tauy = -rhoair*vs/ram + fseng = -raih*dth + fevpg = -raiw*dqh + + fsena = fseng + fevpa = fevpg + +! 2 m height air temperature + tref = (thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar)) + qref = ( qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar)) + + END SUBROUTINE groundfluxes_glacier + + + + SUBROUTINE groundtem_glacier (patchtype,lb,nl_ice,deltim,& + capr,cnfac,dz_icesno,z_icesno,zi_icesno,& + t_icesno,wice_icesno,wliq_icesno,scv,snowdp,& + forc_frl,sabg,sabg_snow_lyr,fseng,fevpg,cgrnd,htvp,emg,& + imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) + +!======================================================================= +! SNOW and LAND ICE temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of snow/ice is computed from the +! formulation used in SNTHERM (Jordan 1991) and Yen (1981), +! respectively. +! o Boundary conditions: +! F = Rnet - Hg - LEg (top) + HPR, F= 0 (base of the land ice column). +! o Ice/snow temperature is predicted from heat conduction in 10 ice +! layers and up to 5 snow layers. The thermal conductivities at the +! interfaces between two neighbor layers (j, j+1) are derived from an +! assumption that the flux across the interface is equal to that from +! the node j to the interface and the flux from the interface to the +! node j+1. The equation is solved using the Crank-Nicholson method +! and resulted in a tridiagonal system equation. +! +! Phase change (see meltf.F90) +! +! Original author: Yongjiu Dai, /05/2014/ +! +! !REVISIONS: +! 01/2023, Hua Yuan: account for snow layer absorption (SNICAR) in +! ground heat flux, temperature and melt calculation. +!======================================================================= + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_Const_Physical, only: stefnc,cpice,cpliq,denh2o,denice,tfrz,tkwat,tkice,tkair + USE MOD_PhaseChange + USE MOD_Utils + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: patchtype !land patch type (0=soil, 1=urban and built-up, + !2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: nl_ice !upper bound of array + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: dz_icesno(lb:nl_ice) !layer thickness [m] + real(r8), intent(in) :: z_icesno (lb:nl_ice) !node depth [m] + real(r8), intent(in) :: zi_icesno(lb-1:nl_ice) !interface depth [m] + + real(r8), intent(in) :: sabg !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: forc_frl !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: fseng !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fevpg !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: cgrnd !deriv. of ice energy flux wrt to ice temp [W/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [J/kg] + real(r8), intent(in) :: emg !ground emissivity (0.97 for snow, + real(r8), intent(in) :: t_precip !snowfall/rainfall temperature [kelvin] + real(r8), intent(in) :: pg_rain !rainfall [kg/(m2 s)] + real(r8), intent(in) :: pg_snow !snowfall [kg/(m2 s)] + + real(r8), intent(in) :: sabg_snow_lyr (lb:1) !snow layer absorption [W/m-2] + + real(r8), intent(inout) :: t_icesno (lb:nl_ice) !snow and ice temperature [K] + real(r8), intent(inout) :: wice_icesno(lb:nl_ice) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_icesno(lb:nl_ice) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change of ground water + real(r8), intent(out) :: fact(lb:nl_ice) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_ice) !flag for melting or freezing [-] + + real(r8), intent(out) :: snofrz(lb:0) !snow freezing rate (lyr) [kg m-2 s-1] + +!-------------------------- Local Variables ---------------------------- + real(r8) rhosnow ! partial density of water (ice + liquid) + real(r8) cv(lb:nl_ice) ! heat capacity [J/(m2 K)] + real(r8) thk(lb:nl_ice) ! thermal conductivity of layer + real(r8) tk(lb:nl_ice) ! thermal conductivity [W/(m K)] + + real(r8) at(lb:nl_ice) !"a" vector for tridiagonal matrix + real(r8) bt(lb:nl_ice) !"b" vector for tridiagonal matrix + real(r8) ct(lb:nl_ice) !"c" vector for tridiagonal matrix + real(r8) rt(lb:nl_ice) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_ice) ! heat diffusion through the layer interface [W/m2] + real(r8) fn1 (lb:nl_ice) ! heat diffusion through the layer interface [W/m2] + real(r8) dzm ! used in computing tridiagonal matrix + real(r8) dzp ! used in computing tridiagonal matrix + + real(r8) t_icesno_bef(lb:nl_ice) ! snow/ice temperature before update + real(r8) wice_icesno_bef(lb:0) ! ice lens [kg/m2] + real(r8) hs ! net energy flux into the surface (w/m2) + real(r8) dhsdt ! d(hs)/dT + real(r8) brr(lb:nl_ice) ! temporary set + + integer i,j + + real(r8) :: porsl(1:nl_ice) ! not used + real(r8) :: psi0 (1:nl_ice) ! not used +#ifdef Campbell_SOIL_MODEL + real(r8) :: bsw(1:nl_ice) ! not used +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8) :: theta_r (1:nl_ice), & + alpha_vgm(1:nl_ice), & + n_vgm (1:nl_ice), & + L_vgm (1:nl_ice), & + sc_vgm (1:nl_ice), & + fc_vgm (1:nl_ice) +#endif + +!----------------------------------------------------------------------- +! SNOW and LAND ICE heat capacity + cv(1:) = wice_icesno(1:)*cpice + wliq_icesno(1:)*cpliq + IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv + + IF(lb<=0)THEN + cv(:0) = cpliq*wliq_icesno(:0) + cpice*wice_icesno(:0) + ENDIF + +! SNOW and LAND ICE thermal conductivity [W/(m K)] + DO j = lb, nl_ice + thk(j) = tkwat + IF(t_icesno(j)<=tfrz) thk(j) = 9.828*exp(-0.0057*t_icesno(j)) + ENDDO + + IF(lb < 1)THEN + DO j = lb, 0 + rhosnow = (wice_icesno(j)+wliq_icesno(j))/dz_icesno(j) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(j) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(j) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(j) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(j) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(j) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(j) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO j = lb, nl_ice-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top ice node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and ice + IF((j==0) .and. (z_icesno(j+1)-zi_icesno(j)=1)THEN + gwat = pg_rain + sm - qseva + ELSE + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_icesno(lb:0),wice_icesno(lb:0),wliq_icesno(lb:0),gwat) + ENDIF + +!======================================================================= +! [2] surface runoff and infiltration +!======================================================================= + + IF(snl<0)THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lb = snl + 1 ! lower bound of array + CALL snowcompaction (lb,deltim,& + imelt(lb:0),fiold(lb:0),t_icesno(lb:0),& + wliq_icesno(lb:0),wice_icesno(lb:0),forc_us,forc_vs,dz_icesno(lb:0)) + + ! Combine thin snow elements + lb = maxsnl + 1 + CALL snowlayerscombine (lb,snl,& + z_icesno(lb:1),dz_icesno(lb:1),zi_icesno(lb-1:1),& + wliq_icesno(lb:1),wice_icesno(lb:1),t_icesno(lb:1),scv,snowdp) + + ! Divide thick snow elements + IF(snl<0) & + CALL snowlayersdivide (lb,snl,& + z_icesno(lb:0),dz_icesno(lb:0),zi_icesno(lb-1:0),& + wliq_icesno(lb:0),wice_icesno(lb:0),t_icesno(lb:0)) + ENDIF + + IF (snl > maxsnl) THEN + wice_icesno(maxsnl+1:snl) = 0. + wliq_icesno(maxsnl+1:snl) = 0. + t_icesno (maxsnl+1:snl) = 0. + z_icesno (maxsnl+1:snl) = 0. + dz_icesno (maxsnl+1:snl) = 0. + ENDIF + + IF(lb >= 1)THEN + wliq_icesno(1) = max(1.e-8, wliq_icesno(1) + qsdew * deltim) + wice_icesno(1) = max(1.e-8, wice_icesno(1) + (qfros-qsubl) * deltim) + ENDIF + + END SUBROUTINE GLACIER_WATER + + + SUBROUTINE GLACIER_WATER_snicar ( nl_ice ,maxsnl ,deltim ,& + z_icesno ,dz_icesno ,zi_icesno ,t_icesno ,& + wliq_icesno ,wice_icesno ,pg_rain ,pg_snow ,& + sm ,scv ,snowdp ,imelt ,& + fiold ,snl ,qseva ,qsdew ,& + qsubl ,qfros ,gwat ,ssi ,& + wimp ,forc_us ,forc_vs ,& + ! SNICAR + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ) + +!======================================================================= + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_SnowLayersCombineDivide + USE MOD_SoilSnowHydrology + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: nl_ice ! upper bound of array + integer, intent(in) :: maxsnl ! maximum number of snow layers + + real(r8), intent(in) :: & + deltim , &! time step (s) + ssi , &! irreducible water saturation of snow + wimp , &! water impermeable IF porosity less than wimp + pg_rain , &! rainfall (mm h2o/s) + pg_snow , &! snowfall (mm h2o/s) + sm , &! snow melt (mm h2o/s) + qseva , &! ground surface evaporation rate (mm h2o/s) + qsdew , &! ground surface dew formation (mm h2o /s) [+] + qsubl , &! sublimation rate from snow pack (mm h2o /s) [+] + qfros , &! surface dew added to snow pack (mm h2o /s) [+] + fiold(maxsnl+1:nl_ice) ! fraction of ice relative to the total water + + ! flag for: melting=1, freezing=2, nothing happened=0 + integer, intent(in) :: imelt(maxsnl+1:nl_ice) + integer, intent(inout) :: snl ! lower bound of array + + real(r8), intent(inout) :: & + z_icesno (maxsnl+1:nl_ice) , &! layer depth (m) + dz_icesno (maxsnl+1:nl_ice) , &! layer thickness (m) + zi_icesno (maxsnl :nl_ice) , &! interface level below a "z" level (m) + t_icesno (maxsnl+1:nl_ice) , &! snow/ice skin temperature (K) + wice_icesno(maxsnl+1:nl_ice) , &! ice lens (kg/m2) + wliq_icesno(maxsnl+1:nl_ice) , &! liquid water (kg/m2) + scv , &! snow mass (kg/m2) + snowdp ! snow depth (m) + + real(r8), intent(out) :: & + gwat ! net water input from top (mm/s) + + real(r8), intent(in) :: forc_us + real(r8), intent(in) :: forc_vs + +! Aerosol Fluxes (Jan. 07, 2023) + ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + real(r8), intent(in) :: forc_aer ( 14 ) + + real(r8), intent(inout) :: & + mss_bcpho (maxsnl+1:0), &! mass of hydrophobic BC in snow (lyr) [kg] + mss_bcphi (maxsnl+1:0), &! mass of hydrophillic BC in snow (lyr) [kg] + mss_ocpho (maxsnl+1:0), &! mass of hydrophobic OC in snow (lyr) [kg] + mss_ocphi (maxsnl+1:0), &! mass of hydrophillic OC in snow (lyr) [kg] + mss_dst1 (maxsnl+1:0), &! mass of dust species 1 in snow (lyr) [kg] + mss_dst2 (maxsnl+1:0), &! mass of dust species 2 in snow (lyr) [kg] + mss_dst3 (maxsnl+1:0), &! mass of dust species 3 in snow (lyr) [kg] + mss_dst4 (maxsnl+1:0) ! mass of dust species 4 in snow (lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) + +!-------------------------- Local Variables ---------------------------- + + integer lb, j + +!======================================================================= +! [1] update the liquid water within snow layer and the water onto the +! ice surface +! +! Snow melting is treated in a realistic fashion, with meltwater +! percolating downward through snow layers as long as the snow is +! unsaturated. Once the underlying snow is saturated, any additional +! meltwater runs off. When glacier ice melts, however, the meltwater is +! assumed to remain in place until it refreezes. In warm parts of the +! ice sheet, the meltwater does not refreeze, but stays in place +! indefinitely. +!======================================================================= + + lb = snl + 1 + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_icesno(lb:0),wice_icesno(lb:0),wliq_icesno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + +!======================================================================= +! [2] surface runoff and infiltration +!======================================================================= + + IF(snl<0)THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lb = snl + 1 ! lower bound of array + CALL snowcompaction (lb,deltim,& + imelt(lb:0),fiold(lb:0),t_icesno(lb:0),& + wliq_icesno(lb:0),wice_icesno(lb:0),forc_us,forc_vs,dz_icesno(lb:0)) + + ! Combine thin snow elements + lb = maxsnl + 1 + CALL snowlayerscombine_snicar (lb,snl,& + z_icesno(lb:1),dz_icesno(lb:1),zi_icesno(lb-1:1),& + wliq_icesno(lb:1),wice_icesno(lb:1),t_icesno(lb:1),scv,snowdp,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + + ! Divide thick snow elements + IF(snl<0) & + CALL snowlayersdivide_snicar (lb,snl,& + z_icesno(lb:0),dz_icesno(lb:0),zi_icesno(lb-1:0),& + wliq_icesno(lb:0),wice_icesno(lb:0),t_icesno(lb:0),& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + + IF (snl > maxsnl) THEN + wice_icesno(maxsnl+1:snl) = 0. + wliq_icesno(maxsnl+1:snl) = 0. + t_icesno (maxsnl+1:snl) = 0. + z_icesno (maxsnl+1:snl) = 0. + dz_icesno (maxsnl+1:snl) = 0. + ENDIF + + IF(lb >= 1)THEN + wliq_icesno(1) = max(1.e-8, wliq_icesno(1) + qsdew * deltim) + wice_icesno(1) = max(1.e-8, wice_icesno(1) + (qfros-qsubl) * deltim) + ENDIF + + END SUBROUTINE GLACIER_WATER_snicar + +END MODULE MOD_Glacier diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundFluxes.F90 new file mode 100644 index 0000000000..0aad77fe8e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundFluxes.F90 @@ -0,0 +1,264 @@ +MODULE MOD_GroundFluxes + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: GroundFluxes + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE GroundFluxes (zlnd, zsno, hu, ht, hq, hpbl, & + us, vs, tm, qm, rhoair, psrf, & + ur, thm, th, thv, t_grnd, qg, rss, dqgdT, htvp, & + fsno, cgrnd, cgrndl, cgrnds, & + t_soil, t_snow, q_soil, q_snow, & + taux, tauy, fseng, fseng_soil, fseng_snow, & + fevpg, fevpg_soil, fevpg_snow, tref, qref, & + z0m, z0hg, zol, rib, ustar, qstar, tstar, fm, fh, fq) + +!----------------------------------------------------------------------- +! This is the main SUBROUTINE to execute the calculation of thermal +! processes and surface fluxes +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002 +! +! !REVISIONS: +! 09/2019, Hua Yuan: removed sigf to be consistent with PFT runs, removed +! fsena, fevpa, renamed z0ma to z0m. +! +! 05/2023, Shaofeng Liu: add option to call moninobuk_leddy, the LargeEddy +! surface turbulence scheme (LZD2022); make a proper update of um. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + USE mod_namelist, only: DEF_USE_CBL_HEIGHT,DEF_RSS_SCHEME + USE MOD_TurbulenceLEddy + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + + ! atmospherical variables and observational height + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + hpbl, &! atmospheric boundary layer height [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] [not used] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + fsno, &! fraction of ground covered by snow + + ur, &! wind speed at reference height [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + + t_grnd, &! ground surface temperature [K] + t_soil, &! ground soil temperature [K] + t_snow, &! ground snow temperature [K] + qg, &! ground specific humidity [kg/kg] + q_soil, &! ground soil specific humidity [kg/kg] + q_snow, &! ground snow specific humidity [kg/kg] + dqgdT, &! d(qg)/dT + rss, &! soil surface resistance for evaporation [s/m] + htvp ! latent heat of vapor of water (or sublimation) [j/kg] + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fseng, &! sensible heat flux from ground [W/m2] + fseng_soil,&! sensible heat flux from ground soil [W/m2] + fseng_snow,&! sensible heat flux from ground snow [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + fevpg_soil,&! evaporation heat flux from ground soil [mm/s] + fevpg_snow,&! evaporation heat flux from ground snow [mm/s] + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air humidity + + z0m, &! effective roughness [m] + z0hg, &! roughness length over ground, sensible heat [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + integer niters, &! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + raih, &! temporary variable [kg/m2/s] + raiw, &! temporary variable [kg/m2/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile FUNCTION for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0qg ! roughness length over ground, latent heat [m] + +!----------------------------------------------------------------------- + ! initial roughness length + ! 09/2019, yuan: change to a combination of zlnd and zsno + z0mg = (1.-fsno)*zlnd + fsno*zsno + z0hg = z0mg + z0qg = z0mg + + ! potential temperature at the reference height + beta = 1. ! - (in computing W_*) + zii = 1000. ! m (pbl height) + z0m = z0mg + + !----------------------------------------------------------------------- + ! Compute sensible and latent fluxes and their derivatives with respect + ! to ground temperature using ground temperatures from previous time step. + !----------------------------------------------------------------------- + ! Initialization variables + nmozsgn = 0 + obuold = 0. + + dth = thm-t_grnd + dqh = qm-qg + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-0. + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + + ! Evaluated stability-dependent variables using moz from prior iteration + niters=6 + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters ! begin stability iteration + !---------------------------------------------------------------- + displax = 0. + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + ! 2023.04.06, weinan + !thvstar=tstar+0.61*th*qstar + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF(zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF(zeta >= 0.)THEN + um = max(ur,0.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION ! END stability iteration + !---------------------------------------------------------------- + + ! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + + raih = rhoair*cpair/rah + + ! 08/23/2019, yuan: add soil surface resistance (rss) + IF (dqh > 0.) THEN + raiw = rhoair/raw !dew case. assume no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + raiw = rss*rhoair/raw + ELSE + raiw = rhoair/(raw+rss) + ENDIF + ENDIF + + cgrnds = raih + cgrndl = raiw*dqgdT + cgrnd = cgrnds + htvp*cgrndl + + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + + ! surface fluxes of momentum, sensible and latent + ! using ground temperatures from previous time step + taux = -rhoair*us/ram + tauy = -rhoair*vs/ram + fseng = -raih*dth + fevpg = -raiw*dqh + + fseng_soil = -raih * (thm - t_soil) + fseng_snow = -raih * (thm - t_snow) + fevpg_soil = -raiw * ( qm - q_soil) + fevpg_snow = -raiw * ( qm - q_snow) + + ! 2 m height air temperature + tref = thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) + + END SUBROUTINE GroundFluxes + +END MODULE MOD_GroundFluxes diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 new file mode 100644 index 0000000000..a2706532ec --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_GroundTemperature.F90 @@ -0,0 +1,447 @@ +#include + +MODULE MOD_GroundTemperature + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: GroundTemperature + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE GroundTemperature (patchtype,is_dry_lake,lb,nl_soil,deltim,& + capr,cnfac,vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm,& + sc_vgm , fc_vgm,& +#endif + csol,k_solids,dksatu,dksatf,dkdry,& + BA_alpha,BA_beta,& + sigf,dz_soisno,z_soisno,zi_soisno,& + t_soisno,t_grnd,t_soil,t_snow,wice_soisno,wliq_soisno,scv,snowdp,fsno,& + frl,dlrad,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + fseng,fseng_soil,fseng_snow,fevpg,fevpg_soil,fevpg_snow,cgrnd,htvp,emg,& + imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) + +!======================================================================= +! Snow and soil temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of soil is computed from +! the algorithm of Johansen (as reported by Farouki 1981), and of snow +! is from the formulation used in SNTHERM (Jordan 1991). +! o Boundary conditions: +! F = Rnet - Hg - LEg + Hpr(top), F= 0 (base of the soil column). +! o Soil / snow temperature is predicted from heat conduction +! in 10 soil layers and up to 5 snow layers. The thermal +! conductivities at the interfaces between two neighbor layers (j, +! j+1) are derived from an assumption that the flux across the +! interface is equal to that from the node j to the interface and the +! flux from the interface to the node j+1. The equation is solved +! using the Crank-Nicholson method and resulted in a tridiagonal +! system equation. +! +! Phase change (see meltf.F90) +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2018 +! +! !REVISIONS: +! 07/2017, Nan Wei: interaction btw prec and land surface +! 01/2019, Nan Wei: USE the new version of soil thermal parameters to +! calculate soil temperature +! 01/2023, Hua Yuan: modified ground heat flux, temperature and meltf +! calculation for SNICAR model +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: stefnc,denh2o,denice,tfrz,cpice,cpliq,tkwat,tkice,tkair + USE MOD_Namelist, only: DEF_USE_SNICAR, DEF_SPLIT_SOILSNOW + USE MOD_PhaseChange + USE MOD_SoilThermalParameters + USE MOD_MPAS_MPI + USE MOD_Utils + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: nl_soil !upper bound of array + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + logical, intent(in) :: is_dry_lake + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor + !to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric fraction of quartz in mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric fraction of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric fraction of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric fraction of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric fraction of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric fraction of sand + + real(r8), intent(in) :: porsl(1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw(1:nl_soil) !clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil), & ! + alpha_vgm(1:nl_soil), & ! + n_vgm (1:nl_soil), & ! + L_vgm (1:nl_soil), & ! + sc_vgm (1:nl_soil), & ! + fc_vgm (1:nl_soil) +#endif + real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids (1:nl_soil) !thermal cond. of minerals soil [W/m-K] + real(r8), intent(in) :: dksatu (1:nl_soil) !thermal cond. of sat. unfrozen soil [W/m-K] + real(r8), intent(in) :: dksatf (1:nl_soil) !thermal cond. of sat. frozen soil [W/m-K] + real(r8), intent(in) :: dkdry (1:nl_soil) !thermal cond. of dry soil [W/m-K] + real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal cond. + real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal cond. + + real(r8), intent(in) :: sigf !frac. of veg, excluding snow-covered veg [-] + real(r8), intent(in) :: dz_soisno(lb:nl_soil) !layer thickness [m] + real(r8), intent(in) :: z_soisno (lb:nl_soil) !node depth [m] + real(r8), intent(in) :: zi_soisno(lb-1:nl_soil) !interface depth [m] + + real(r8), intent(in) :: sabg_snow_lyr(lb:1) !snow layer absorption [W/m-2] + + real(r8), intent(in) :: t_grnd !ground surface temperature [K] + real(r8), intent(in) :: t_soil !ground soil temperature [K] + real(r8), intent(in) :: t_snow !ground snow temperature [K] + real(r8), intent(in) :: sabg !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: sabg_soil !solar radiation absorbed by soil [W/m2] + real(r8), intent(in) :: sabg_snow !solar radiation absorbed by snow [W/m2] + real(r8), intent(in) :: frl !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: dlrad !downward longwave radiation blow the canopy [W/m2] + real(r8), intent(in) :: fseng !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fseng_soil !sensible heat flux from ground soil [W/m2] + real(r8), intent(in) :: fseng_snow !sensible heat flux from ground snow [W/m2] + real(r8), intent(in) :: fevpg !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: fevpg_soil !evaporation heat flux from ground soil [mm/s] + real(r8), intent(in) :: fevpg_snow !evaporation heat flux from ground snow [mm/s] + real(r8), intent(in) :: cgrnd !deriv. of soil energy flux wrt to soil temp [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor of water (or sublimation) [j/kg] + real(r8), intent(in) :: emg !ground emissivity (0.97 for snow, 0.96 for soil) + real(r8), intent(in) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: t_precip !snowfall/rainfall temperature [kelvin] + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) !soil temperature [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + real(r8), intent(in) :: fsno !snow fractional cover [-] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change of ground water + real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + + real(r8), intent(out) :: snofrz(lb:0) !snow freezing rate (lyr) [kg m-2 s-1] + +!-------------------------- Local Variables ---------------------------- + real(r8) cv (lb:nl_soil) !heat capacity [J/(m2 K)] + real(r8) tk (lb:nl_soil) !thermal conductivity [W/(m K)] + real(r8) hcap(1:nl_soil) !J/(m3 K) + real(r8) thk(lb:nl_soil) !W/(m K) + + real(r8) at (lb:nl_soil) !"a" vector for tridiagonal matrix + real(r8) bt (lb:nl_soil) !"b" vector for tridiagonal matrix + real(r8) ct (lb:nl_soil) !"c" vector for tridiagonal matrix + real(r8) rt (lb:nl_soil) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_soisno_bef(lb:nl_soil) !soil/snow temperature before update + real(r8) wice_soisno_bef(lb:0) !ice lens [kg/m2] + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) hs_soil !net energy flux into the surface soil (w/m2) + real(r8) hs_snow !net energy flux into the surface snow (w/m2) + real(r8) dhsdT !d(hs)/dT + real(r8) brr (lb:nl_soil) !temporary set + real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil + real(r8) vf_ice (1:nl_soil) !volumetric fraction ice lens within soil + real(r8) rhosnow !partial density of water (ice + liquid) + integer i,j + +!----------------------------------------------------------------------- +! soil ground and wetland heat capacity + DO i = 1, nl_soil + vf_water(i) = wliq_soisno(i)/(dz_soisno(i)*denh2o) + vf_ice(i) = wice_soisno(i)/(dz_soisno(i)*denice) + CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& + wf_gravels(i),wf_sand(i),k_solids(i),& + csol(i),dkdry(i),dksatu(i),dksatf(i),& + BA_alpha(i),BA_beta(i),& + t_soisno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) + cv(i) = hcap(i)*dz_soisno(i) + ENDDO + IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv + +! Snow heat capacity + IF(lb <= 0)THEN + cv(:0) = cpliq*wliq_soisno(:0) + cpice*wice_soisno(:0) + ENDIF + +! Snow thermal conductivity + IF(lb <= 0)THEN + DO i = lb, 0 + rhosnow = (wice_soisno(i)+wliq_soisno(i))/dz_soisno(i) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(i) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(i) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(i) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(i) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(i) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(i) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO i = lb, nl_soil-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top soil node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and soil + IF((i==0) .and. (z_soisno(i+1)-zi_soisno(i)100% cover + IF (DEF_USE_SNICAR .and. lb < 1) THEN + hs = sabg_snow_lyr(lb) + sabg_soil + dlrad*emg & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) + ELSE + hs = sabg + dlrad*emg & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) + ENDIF + + IF (.not.DEF_SPLIT_SOILSNOW) THEN + hs = hs - emg*stefnc*t_grnd**4 + ELSE + ! 03/08/2020, yuan: separate soil and snow + hs = hs - fsno*emg*stefnc*t_snow**4 & + - (1.-fsno)*emg*stefnc*t_soil**4 + + ! 03/08/2020, yuan: calculate hs_soil, hs_snow for + ! soil/snow fractional cover separately. + hs_soil = dlrad*emg & + - emg*stefnc*t_soil**4 & + - (fseng_soil+fevpg_soil*htvp) & + + cpliq*pg_rain*(t_precip-t_soil) & + + cpice*pg_snow*(t_precip-t_soil) + + hs_soil = hs_soil*(1.-fsno) + sabg_soil + + hs_snow = dlrad*emg & + - emg*stefnc*t_snow**4 & + - (fseng_snow+fevpg_snow*htvp) & + + cpliq*pg_rain*(t_precip-t_snow) & + + cpice*pg_snow*(t_precip-t_snow) + + IF (DEF_USE_SNICAR .and. lb < 1) THEN + hs_snow = hs_snow*fsno + sabg_snow_lyr(lb) + ELSE + hs_snow = hs_snow*fsno + sabg_snow + ENDIF + + dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow + + IF (abs(sabg_soil+sabg_snow-sabg)>1.e-6 .or. abs(hs_soil+hs_snow-hs)>1.e-6) THEN + print *, "MOD_GroundTemperature.F90: Error in spliting soil and snow surface!" + print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow + print *, "hs", hs, "hs_soil", hs_soil, "hs_snow:", hs_snow, "fsno:", fsno + print *, "hs_soil+hs_snow", hs_soil+hs_snow, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow + print *, "lb:", lb, "sabg_snow_lyr:", sabg_snow_lyr + CALL CoLM_stop() + ENDIF + ENDIF + + dhsdT = -cgrnd - 4.*emg*stefnc*t_grnd**3 - cpliq*pg_rain - cpice*pg_snow + t_soisno_bef(lb:) = t_soisno(lb:) + + j = lb + fact(j) = deltim / cv(j) * dz_soisno(j) & + / (0.5*(z_soisno(j)-zi_soisno(j-1)+capr*(z_soisno(j+1)-zi_soisno(j-1)))) + + DO j = lb + 1, nl_soil + fact(j) = deltim/cv(j) + ENDDO + + DO j = lb, nl_soil - 1 + fn(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) + ENDDO + fn(nl_soil) = 0. + +! set up vector r and vectors a, b, c that define tridiagonal matrix + j = lb + dzp = z_soisno(j+1)-z_soisno(j) + at(j) = 0. + ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp + + ! the first layer + IF (j<1 .and. DEF_SPLIT_SOILSNOW) THEN ! snow covered and split soil and snow + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*fsno*dhsdT + rt(j) = t_soisno(j) +fact(j)*( hs_snow - fsno*dhsdT*t_soisno(j) + cnfac*fn(j) ) + ELSE ! not a snow layer or don't split soil and snow + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + rt(j) = t_soisno(j) +fact(j)*( hs - dhsdT*t_soisno(j) + cnfac*fn(j) ) + ENDIF + + DO j = lb + 1, nl_soil - 1 + + dzm = (z_soisno(j)-z_soisno(j-1)) + dzp = (z_soisno(j+1)-z_soisno(j)) + + IF (j < 1) THEN ! snow layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + IF (DEF_USE_SNICAR) THEN + rt(j) = t_soisno(j) + fact(j)*sabg_snow_lyr(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ELSE + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDIF + ENDIF + + IF (j == 1) THEN ! the first soil layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + IF (.not.DEF_SPLIT_SOILSNOW) THEN + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ELSE + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) & + - (1.-fsno)*dhsdT*fact(j) + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) & + + fact(j)*( hs_soil - (1.-fsno)*dhsdT*t_soisno(j) ) + ENDIF + ENDIF + + IF (j > 1) THEN ! inner soil layer + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_soisno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDIF + + ENDDO + + j = nl_soil + dzm = (z_soisno(j)-z_soisno(j-1)) + at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*tk(j-1)/dzm + ct(j) = 0. + rt(j) = t_soisno(j) - cnfac*fact(j)*fn(j-1) + +! solve for t_soisno + i = size(at) + CALL tridia (i ,at ,bt ,ct ,rt ,t_soisno) +!======================================================================= +! melting or freezing +!======================================================================= + + DO j = lb, nl_soil - 1 + fn1(j) = tk(j)*(t_soisno(j+1)-t_soisno(j))/(z_soisno(j+1)-z_soisno(j)) + ENDDO + fn1(nl_soil) = 0. + + j = lb + brr(j) = cnfac*fn(j) + (1.-cnfac)*fn1(j) + + DO j = lb + 1, nl_soil + brr(j) = cnfac*(fn(j)-fn(j-1)) + (1.-cnfac)*(fn1(j)-fn1(j-1)) + ENDDO + + + IF (DEF_USE_SNICAR) THEN + + wice_soisno_bef(lb:0) = wice_soisno(lb:0) + + CALL meltf_snicar (patchtype,is_dry_lake,lb,nl_soil,deltim, & + fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,sabg_snow_lyr(lb:),dhsdT, & + t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & + scv,snowdp,sm,xmf,porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz_soisno(1:nl_soil)) + + ! layer freezing mass flux (positive): + DO j = lb, 0 + IF (imelt(j)==2 .and. j<1) THEN + snofrz(j) = max(0._r8,(wice_soisno(j)-wice_soisno_bef(j)))/deltim + ENDIF + ENDDO + + ELSE + CALL meltf (patchtype,is_dry_lake,lb,nl_soil,deltim, & + fact(lb:),brr(lb:),hs,hs_soil,hs_snow,fsno,dhsdT, & + t_soisno_bef(lb:),t_soisno(lb:),wliq_soisno(lb:),wice_soisno(lb:),imelt(lb:), & + scv,snowdp,sm,xmf,porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz_soisno(1:nl_soil)) + ENDIF + +!----------------------------------------------------------------------- + + END SUBROUTINE GroundTemperature + +END MODULE MOD_GroundTemperature diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HighRes_Parameters.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HighRes_Parameters.F90 new file mode 100644 index 0000000000..bb64bd23c7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HighRes_Parameters.F90 @@ -0,0 +1,550 @@ +#include + +MODULE MOD_HighRes_Parameters + +!----------------------------------------------------------------------- +! USES: +USE MOD_Precision +USE MOD_NetCDFSerial +USE MOD_Namelist, only : DEF_USE_SNICAR, DEF_HighResSoil, DEF_HighResVeg, DEF_PROSPECT !, DEF_Satellite_Params +USE MOD_Namelist, only : DEF_HighResUrban_albedo +! USE MOD_Namelist, only : DEF_file_soiloptics, DEF_file_satellite_params, DEF_sla_varname +IMPLICIT NONE +SAVE + +REAL(r8) :: reflectance ( 0:15, 211, 2 ) ! (species, leaf/stem, wavelength) +REAL(r8) :: transmittance ( 0:15, 211, 2 ) ! (species, leaf/stem, wavelength) +! REAL(r8) :: soil_alb ( 211 ) ! (wavelength) +REAL(r8) :: kw ( 211 ) ! (wavelength) +REAL(r8) :: nw ( 211 ) ! (wavelength) +REAL(r8) :: clr_frac ( 211, 89, 5 ) ! (wvl_ctr, SZA, loc ) +REAL(r8) :: cld_frac ( 211, 5 ) ! (wvl_ctr, loc, ) +! Urban hyperspectral albedo +REAL(r8), ALLOCATABLE :: urban_albedo( :, :, : ) ! (cluster_id, season wavelength) +REAL(r8), ALLOCATABLE :: mean_albedo ( :, : ) ! (season, wavelength) +REAL(r8), ALLOCATABLE :: lat_north ( : ) ! (cluster_id) +REAL(r8), ALLOCATABLE :: lat_south ( : ) ! (cluster_id) +REAL(r8), ALLOCATABLE :: lon_east ( : ) ! (cluster_id) +REAL(r8), ALLOCATABLE :: lon_west ( : ) ! (cluster_id) + +! ! ONLY VALID when DEF_Satellite_Params is TRUE +! REAL(r8) :: chl_satellite(366) +! REAL(r8) :: sla_satellite + +PUBLIC :: flux_frac_init +PUBLIC :: leaf_property_init +! PUBLIC :: surface_albedo_single_init +PUBLIC :: get_water_optical_properties +PUBLIC :: get_loc_params +! PUBLIC :: satellite_PROSPECT_init + +CONTAINS +!----------------------------------------------------------------------- + +subroutine flux_frac_init( ) + + USE NETCDF + IMPLICIT NONE + !------------------------------------------------------------------- + INTEGER :: i, ncid, varid + CHARACTER(len=256) :: file_path + !------------------------------------------------------------------- + + ! open the file base on the SZA and latitude + file_path = "/ddn_lustre/weiliren/data/CoLM_hires_params/fsds/swnb_480bnd_fsds.nc" + + ! open the file + CALL nccheck( nf90_open(trim(file_path), NF90_NOWRITE, ncid) , trace=trim(file_path)//' cannot open' ) + + ! get the variable id + + CALL nccheck( nf90_open(trim(file_path), NF90_NOWRITE, ncid) , trace=trim(file_path)//' cannot open' ) + + ! get the variable id + CALL nccheck( nf90_inq_varid(ncid, 'flx_frc_cld', varid) , trace=trim(file_path)//' cannot get varid' ) + CALL nccheck( nf90_get_var(ncid, varid, cld_frac) , trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_inq_varid(ncid, 'flx_frc_clr', varid) , trace=trim(file_path)//' cannot get varid' ) + CALL nccheck( nf90_get_var(ncid, varid, clr_frac) , trace=trim(file_path)//' cannot get data' ) + + ! close the file + CALL nccheck( nf90_close(ncid) , trace=trim(file_path)//' cannot close' ) +end subroutine flux_frac_init + + +subroutine leaf_property_init( rho_p, tau_p ) + ! Plant Functional Type classification + !--------------------------- + ! 0 not vegetated + ! 1 needleleaf evergreen temperate tree + ! 2 needleleaf evergreen boreal tree + ! 3 needleleaf deciduous boreal tree + ! 4 broadleaf evergreen tropical tree + ! 5 broadleaf evergreen temperate tree + ! 6 broadleaf deciduous tropical tree + ! 7 broadleaf deciduous temperate tree + ! 8 broadleaf deciduous boreal tree + ! 9 broadleaf evergreen shrub + !10 broadleaf deciduous temperate shrub + !11 broadleaf deciduous boreal shrub + !12 c3 arctic grass + !13 c3 non-arctic grass + !14 c4 grass + !15 c3 crop + !16 c3_irrigated + + USE NETCDF + IMPLICIT NONE + !------------------------------------------------------------------- + REAL(r8), INTENT(IN) :: rho_p(2, 2, 0:15), tau_p(2, 2, 0:15) ! (leaf/stem, vis/nir, species) + INTEGER :: i, j, ncid, varid, ndims, dimids(3), dimlen(3) + CHARACTER(len=256) :: file_path + REAL(r8), allocatable :: reflectance_temp(:,:,:), transmittance_temp(:,:,:) + !------------------------------------------------------------------- + ! open the file base on the SZA and latitude + + ! Parameters for hyperspectral leaf properties + IF ( DEF_HighResVeg .OR. DEF_PROSPECT ) THEN + + file_path = "/ddn_lustre/weiliren/data/CoLM_hires_params/leaf_optical_properties/colm_PFT_params.nc" + + ! open the file + CALL nccheck( nf90_open(trim(file_path), NF90_NOWRITE, ncid) , trace=trim(file_path)//' cannot open' ) + + ! get the variable id + CALL nccheck( nf90_inq_varid(ncid, 'reflectance', varid) , trace=trim(file_path)//' cannot get varid' ) + CALL nccheck( nf90_inquire_variable(ncid, varid, dimids=dimids) , trace=trim(file_path)//' cannot get var dims' ) + + do i = 1, size(dimlen) + CALL nccheck( nf90_inquire_dimension(ncid, dimids(i), len=dimlen(i)) ) + end do + + ! allocate the memory, and get the reflectance data + allocate( reflectance_temp( dimlen(1), dimlen(2), dimlen(3) ) ) + CALL nccheck( nf90_get_var(ncid, varid, reflectance_temp) ) + + CALL nccheck( nf90_inq_varid(ncid, 'transmittance', varid) , trace=trim(file_path)//' cannot get varid' ) + CALL nccheck( nf90_inquire_variable(ncid, varid, dimids=dimids) , trace=trim(file_path)//' cannot get var dims' ) + + ! allocate the memory, and get the transmittance data + allocate( transmittance_temp( dimlen(1), dimlen(2), dimlen(3) ) ) + CALL nccheck( nf90_get_var(ncid, varid, transmittance_temp) ) + + ! close the file + CALL nccheck( nf90_close(ncid) , trace=trim(file_path)//' cannot close' ) + + do i = 0, 15 + do j = 1, 2 + reflectance (i, :, j) = reflectance_temp (:, j, i+1) + transmittance(i, :, j) = transmittance_temp(:, j, i+1) + end do + end do + + DEALLOCATE( reflectance_temp ) + DEALLOCATE( transmittance_temp ) + + ELSE + + do i = 0, 15 + reflectance(i, 1 :29 , 1) = rho_p(1, 1, i) + reflectance(i, 1 :29 , 2) = rho_p(1, 2, i) + reflectance(i, 30:211, 1) = rho_p(2, 1, i) + reflectance(i, 30:211, 2) = rho_p(2, 2, i) + + transmittance(i, 1 :29 , 1) = tau_p(1, 1, i) + transmittance(i, 1 :29 , 2) = tau_p(1, 2, i) + transmittance(i, 30:211, 1) = tau_p(2, 1, i) + transmittance(i, 30:211, 2) = tau_p(2, 2, i) + end do + + END IF + + ! 3. Close file + +end subroutine leaf_property_init + + +! No longer used +! subroutine surface_albedo_single_init( ) +! IMPLICIT NONE +! INTEGER :: i, unit +! !------------------------------------------------------------------- + +! unit = 10 + +! if (DEF_file_soiloptics == 'Null') then +! write(*,*) "Error: soiloptics file is not defined" +! stop +! end if +! open(unit=unit, file=DEF_file_soiloptics, status='old', action='read') + +! do i = 1, 211 +! read(unit,*) soil_alb(i) +! end do +! close(unit) +! end subroutine surface_albedo_single_init + + +SUBROUTINE get_water_optical_properties( ) + IMPLICIT NONE + INTEGER :: i, unit + + unit = 10 + open(unit=unit, file='/ddn_lustre/weiliren/data/CoLM_hires_params/water_params.txt', status='old') + + do i = 1, 211 + read(unit,*) kw(i), nw(i) + end do + close(unit) +END SUBROUTINE get_water_optical_properties + + +real function rad2deg(angle_in_rad) + real, intent(in) :: angle_in_rad + rad2deg = angle_in_rad * (180.0 / 3.14159265358979323846) +end function rad2deg + + +SUBROUTINE get_loc_params( fsds, idate, coszen, lat, lon, clr_frac_all, cld_frac_all, dir_frac, dif_frac ) + USE MOD_OrbCoszen + USE MOD_TimeManager + + implicit none + real(r8), intent(in) :: fsds + integer, INTENT(in) :: idate(3) + real(r8), intent(in) :: coszen + real(r8), intent(in) :: lat, lon + real(r8), intent(in) :: clr_frac_all( 211, 89, 5 ) + real(r8), intent(in) :: cld_frac_all( 211, 5 ) + + real, intent(out) :: dir_frac(211) + real, intent(out) :: dif_frac(211) + + INTEGER :: loc_index, sza + real(r8) :: lat_deg, sunang, cloud, difrat, vnrat, calday, a + + ! index = 1 - 90 + sza = int(rad2deg(acos(min(1._r8,max(-1._r8,coszen))))) + 1 + sza = max(1, min(ubound(clr_frac_all,2), sza)) ! 自动适配 + + ! combine cloud and clear sky fraction + a = max(0., fsds) + calday = calendarday(idate) + sunang = orb_coszen(calday, lon, lat) + + ! turn lat from radians to degrees + lat_deg = abs(rad2deg(lat)) + + ! check if the lat in tropical/temperate/polar + IF (lat_deg >= 0.0 .AND. lat_deg < 23.5) THEN + loc_index = 5 + + ELSE IF (lat_deg >= 23.5 .AND. lat_deg < 66.5) THEN + ! temperate summer + IF (calday > 91 .AND. calday < 274) THEN + loc_index = 4 + ELSE + loc_index = 3 + END IF + + ELSE IF (lat_deg >= 66.5 .AND. lat_deg <= 90.0) THEN + IF (calday > 91 .AND. calday < 274) THEN + loc_index = 2 + ELSE + loc_index = 1 + END IF + + ENDIF + + dir_frac = clr_frac_all(:, sza, loc_index) + dif_frac = cld_frac_all(:, loc_index) + +END SUBROUTINE get_loc_params + +! SUBROUTINE satellite_PROSPECT_init() +! USE NETCDF +! IMPLICIT NONE +! !------------------------------------------------------------------- +! INTEGER :: i, j, ncid, varid +! INTEGER, ALLOCATABLE :: dimids(:) +! !------------------------------------------------------------------- +! if (DEF_file_satellite_params == 'null') then +! write(*,*) "ERROR: DEF_file_satellite_params is not set" +! stop +! end if + +! ! 1. Open file +! CALL nccheck( nf90_open(trim(DEF_file_satellite_params), NF90_NOWRITE, ncid), trace=trim(DEF_file_satellite_params)//' cannot open' ) + +! ! 2. Read data: chl +! CALL nccheck( nf90_inq_varid(ncid, 'chl', varid), trace=trim(DEF_file_satellite_params)//' cannot find variable' ) +! CALL nccheck( nf90_inquire_variable(ncid, varid, dimids=dimids), trace=trim(DEF_file_satellite_params)//' cannot inquire variable' ) +! CALL nccheck( nf90_get_var(ncid, varid, chl_satellite), trace='chl cannot get variable' ) + +! ! 2. Read data: sla +! CALL nccheck( nf90_inq_varid(ncid, DEF_sla_varname, varid), trace=trim(DEF_file_satellite_params)//' cannot find variable' ) +! CALL nccheck( nf90_inquire_variable(ncid, varid, dimids=dimids), trace=trim(DEF_file_satellite_params)//' cannot inquire variable' ) +! CALL nccheck( nf90_get_var(ncid, varid, sla_satellite), trace=trim(DEF_sla_varname)//' cannot get variable' ) + +! ! 3. Close file +! call nccheck( nf90_close(ncid) ) +! END SUBROUTINE satellite_PROSPECT_init + + +! ======== Calculate Reflectance & Transmittance using PROSPECT ======== +SUBROUTINE update_params_PROSPECT(ipft, reflectance_in, transmittance_in,& + reflectance_p, transmittance_p ,& + soilmoisture ) + USE MOD_prospect_DB + USE MOD_dataSpec_PDB, only : nw + IMPLICIT NONE + !------------------------------------------------------------------- + REAL(r8), PARAMETER :: SLA(0: 15) & ! unit g/m^2 + = (/ 0.0 , 0.0100, 0.0100, 0.0202, 0.0190, 0.0190, 0.0308, 0.0308 & + , 0.0308, 0.0180, 0.0307, 0.0307, 0.0402, 0.0402, 0.0385, 0.0402 /) + + REAL(r8), PARAMETER :: vmax25_p(0: 15) & ! + = (/ 52.0, 55.0, 42.0, 29.0, 41.0, 51.0, 36.0, 30.0 & + , 40.0, 36.0, 30.0, 19.0, 21.0, 26.0, 25.0, 57.0 /) * 1.e-6 + + INTEGER , INTENT(IN) :: ipft + REAL(r8), INTENT(IN) :: reflectance_in(16, 211, 2), transmittance_in(16, 211, 2) + REAL(r8), INTENT(IN) :: soilmoisture + + REAL(r8), INTENT(OUT) :: reflectance_p(211, 2), transmittance_p(211, 2) + + ! Params for PROSPECT + REAL(r8) :: N ! leaf structure coefficient (n_layer) + REAL(r8) :: Cab ! Chlorophyll Content + REAL(r8) :: Car ! Carotenoid, unit [μg cm^−2] + REAL(r8) :: Anth ! Anthocyanin + REAL(r8) :: Cbrown ! Brown Pigment + REAL(r8) :: Cw ! Equivalent Water Thickness + REAL(r8) :: Cm ! Dry Matter Content (g cm^-2) + REAL(r8) :: RT(nw, 2) ! nw = 2101, defined in dataSpec_PDB + + ! temporary variables + REAL(r8) :: vmax25 ! maximum carboxylation rate at 25 C at canopy top, unit [mol m-2 s-1] + + INTEGER :: i, j + !------------------------------------------------------------------- + ! 1. Set Car, Cbrown, Anth + Car = 8.0 + Cbrown = 0.01 + Anth = 0.0 + + ! 2. Calculate N & Cm + ! SLA: Specific Leaf Area, unit [m^2 g-1] -> [cm^2 mg-1] + N = (0.9 * (SLA(ipft) * 10.) + 0.025) / ((SLA(ipft) * 10.) - 0.01) + ! Cm: Dry Matter Content, unit [g cm^-2] <- SLA [m^2 g-1] + Cm = 1.0 / (SLA(ipft) * 1.e4) + + ! 3. Calculate Cab + vmax25 = vmax25_p(ipft) + Cab = ((vmax25 * 1.e6) - 3.72) / 1.3 + + ! 4. Calculate Cw + Cw = 0.01 - (( 0.01 - 0. ) * exp( -5.5 * soilmoisture )) + + ! 5. Calculate reflectance & transmittance + CALL prospect_DB(N,Cab,Car,Anth,Cbrown,Cw,Cm,RT) + + j = 1 + do i = 1, nw, 10 + reflectance_p(j, 1) = RT(i, 1) + transmittance_p(j, 1) = RT(i, 2) + j = j + 1 + end do + + reflectance_p(:,2) = reflectance_in(ipft, :, 2) + transmittance_p(:,2) = transmittance_in(ipft, :, 2) +END SUBROUTINE update_params_PROSPECT +! ====================================================================== + +! SUBROUTINE satellite_PROSPECT(ipft, reflectance_in, transmittance_in,& +! reflectance_p, transmittance_p ,& +! soilmoisture, doy ) +! USE MOD_prospect_DB +! USE MOD_dataSpec_PDB, only : nw +! IMPLICIT NONE +! !------------------------------------------------------------------- + +! INTEGER , INTENT(IN) :: ipft +! REAL(r8), INTENT(IN) :: reflectance_in(16, 211, 2), transmittance_in(16, 211, 2) +! REAL(r8), INTENT(IN) :: soilmoisture +! INTEGER, INTENT(IN) :: doy + +! REAL(r8), INTENT(OUT) :: reflectance_p(211, 2), transmittance_p(211, 2) + +! ! Params for PROSPECT +! REAL(r8) :: N ! leaf structure coefficient (n_layer) +! REAL(r8) :: Cab ! Chlorophyll Content +! REAL(r8) :: Car ! Carotenoid, unit [μg cm^−2] +! REAL(r8) :: Anth ! Anthocyanin +! REAL(r8) :: Cbrown ! Brown Pigment +! REAL(r8) :: Cw ! Equivalent Water Thickness +! REAL(r8) :: Cm ! Dry Matter Content (g cm^-2) +! REAL(r8) :: RT(nw, 2) ! nw = 2101, defined in dataSpec_PDB +! INTEGER :: i, j + +! !NOTE: All from Wang 2025 NC +! ! 1. Set Car, Cbrown, Anth +! Cbrown = 0.0 +! Anth = 0.0 + +! ! 2. Calculate N & Cm +! ! SLA: Specific Leaf Area, unit [cm^2 mg-1] +! N = 1.4 +! ! N = (0.9 * sla_satellite + 0.025) / (sla_satellite - 0.01) +! ! Cm: Dry Matter Content, unit [g cm^-2] <- SLA [cm^2 mg-1] +! Cm = 1.0 / (sla_satellite * 1.e3) + +! ! 3. Calculate Cab +! Cab = chl_satellite(doy) +! Car = Cab / 7. + +! ! 4. Calculate Cw +! Cw = 0.009 ! cm +! ! Cw = 0.01 - (( 0.01 - 0. ) * exp( -5.5 * soilmoisture )) + +! ! 5. Calculate reflectance & transmittance +! CALL prospect_DB(N,Cab,Car,Anth,Cbrown,Cw,Cm,RT) + +! j = 1 +! do i = 1, nw, 10 +! reflectance_p(j, 1) = RT(i, 1) +! transmittance_p(j, 1) = RT(i, 2) +! j = j + 1 +! end do + +! reflectance_p(:,2) = reflectance_in(ipft, :, 2) +! transmittance_p(:,2) = transmittance_in(ipft, :, 2) + +! END SUBROUTINE satellite_PROSPECT + +SUBROUTINE readin_urban_albedo() + + USE NETCDF + IMPLICIT NONE + INTEGER :: ncid, ndims, dimids(3), dimlen(3) + INTEGER :: albedo_varid, mean_albedo_varid, & + lat_north_varid, lat_south_varid, & + lon_east_varid , lon_west_varid + CHARACTER(len=256) :: file_path + INTEGER :: i + + ! 设置文件路径 + file_path = DEF_HighResUrban_albedo + + ! 打开 NetCDF 文件 + CALL nccheck( nf90_open(trim(file_path), NF90_NOWRITE, ncid) , & + trace=trim(file_path)//' cannot open' ) + + ! 获取变量 ID + CALL nccheck( nf90_inq_varid(ncid, 'urban_albedo', albedo_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'mean_albedo', mean_albedo_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'lat_north', lat_north_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'lat_south', lat_south_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'lon_east', lon_east_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + CALL nccheck( nf90_inq_varid(ncid, 'lon_west', lon_west_varid) , & + trace=trim(file_path)//' cannot get varid' ) + + ! 获取变量维度信息 + CALL nccheck( nf90_inquire_variable(ncid, albedo_varid, ndims=ndims, dimids=dimids) , & + trace=trim(file_path)//' cannot get var dims' ) + + ! 获取各维度长度 + do i = 1, ndims + CALL nccheck( nf90_inquire_dimension(ncid, dimids(i), len=dimlen(i)) ) + end do + + ! 分配内存 + if (.not. allocated(urban_albedo)) then + allocate( urban_albedo(dimlen(1), dimlen(2), dimlen(3)) ) ! (cluster_id, season, wavelength) + end if + + if (.not. allocated(mean_albedo)) then + allocate( mean_albedo(dimlen(2), dimlen(3)) ) ! (season, wavelength) + end if + + if (.not. allocated(lat_north)) then + allocate( lat_north(dimlen(1)) ) ! (cluster_id) + end if + + if (.not. allocated(lat_south)) then + allocate( lat_south(dimlen(1)) ) ! (cluster_id) + end if + + if (.not. allocated(lon_east)) then + allocate( lon_east(dimlen(1)) ) ! (cluster_id) + end if + + if (.not. allocated(lon_west)) then + allocate( lon_west(dimlen(1)) ) ! (cluster_id) + end if + + ! 读取数据 + CALL nccheck( nf90_get_var(ncid, albedo_varid, urban_albedo) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, mean_albedo_varid, mean_albedo) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, lat_north_varid, lat_north) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, lat_south_varid, lat_south) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, lon_east_varid, lon_east) , & + trace=trim(file_path)//' cannot get data' ) + + CALL nccheck( nf90_get_var(ncid, lon_west_varid, lon_west) , & + trace=trim(file_path)//' cannot get data' ) + + ! 关闭文件 + CALL nccheck( nf90_close(ncid) , & + trace=trim(file_path)//' cannot close' ) + +END SUBROUTINE readin_urban_albedo + +SUBROUTINE deallocate_urban_albedo() + IMPLICIT NONE + + IF (ALLOCATED(urban_albedo)) THEN + DEALLOCATE(urban_albedo) + END IF + + IF (ALLOCATED(mean_albedo)) THEN + DEALLOCATE(mean_albedo) + END IF + + IF (ALLOCATED(lat_north)) THEN + DEALLOCATE(lat_north) + END IF + + IF (ALLOCATED(lat_south)) THEN + DEALLOCATE(lat_south) + END IF + + IF (ALLOCATED(lon_east)) THEN + DEALLOCATE(lon_east) + END IF + + IF (ALLOCATED(lon_west)) THEN + DEALLOCATE(lon_west) + END IF + +END SUBROUTINE deallocate_urban_albedo + +END MODULE MOD_HighRes_Parameters diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 new file mode 100644 index 0000000000..fcc804e623 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Irrigation.F90 @@ -0,0 +1,538 @@ +#include +#ifdef CROP +MODULE MOD_Irrigation + +! DESCRIPTION: +! This MODULE has all irrigation related subroutines for irrigated crop at either IGBP/USGS or PFT Land type classification and even in the C and N cycle. + USE MOD_Precision + USE MOD_TimeManager + USE MOD_Namelist, only: DEF_simulation_time, DEF_IRRIGATION_ALLOCATION, DEF_USE_VariablySaturatedFlow + USE MOD_Const_Physical, only: tfrz, denice, denh2o + USE MOD_Const_PFT, only: irrig_crop + USE MOD_LandPFT, only : patch_pft_s, patch_pft_e + USE MOD_Vars_Global, only: irrig_start_time, irrig_max_depth, irrig_threshold_fraction, irrig_supply_fraction, irrig_min_cphase, irrig_max_cphase, irrig_time_per_day, & + irrig_method_drip, irrig_method_sprinkler, irrig_method_flood, irrig_method_paddy + USE MOD_Qsadv, only: qsadv + USE MOD_Vars_TimeInvariants, only: pondmx, & +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, fc_vgm, sc_vgm,& +#endif + porsl, psi0, bsw + USE MOD_Vars_TimeVariables, only: tref, t_soisno, wliq_soisno, wice_soisno, zwt, wa, & + irrig_rate, sum_irrig, sum_deficit_irrig, sum_irrig_count, n_irrig_steps_left, & + tairday, usday, vsday, pairday, rnetday, fgrndday, potential_evapotranspiration,& + groundwater_demand, groundwater_supply, reservoirriver_demand, reservoirriver_supply, & + reservoir_supply, river_supply, runoff_supply, & + waterstorage, deficit_irrig, actual_irrig, irrig_gw_alloc, irrig_sw_alloc, zwt_stand + USE MOD_Vars_PFTimeInvariants, only: pftclass + USE MOD_Vars_PFTimeVariables, only: irrig_method_p + USE MOD_BGC_Vars_PFTimeVariables, only: cphase_p + USE MOD_Vars_1DForcing, only: forc_t, forc_frl, forc_psrf, forc_us, forc_vs + USE MOD_Vars_1DFluxes, only: sabg, sabvsun, sabvsha, olrg, fgrnd + USE MOD_Hydro_SoilFunction, only: soil_vliq_from_psi + USE MOD_MPAS_MPI + IMPLICIT NONE + + PUBLIC :: CalIrrigationNeeded + PUBLIC :: CalIrrigationApplicationFluxes + +CONTAINS + + SUBROUTINE CalIrrigationNeeded(i,idate,nl_soil,nbedrock,z_soi,zi_soi,dz_soi,deltim,dlon,npcropmin) + + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate how much irrigation needed in each irrigated crop patch + integer , intent(in) :: i + integer , intent(in) :: idate(3) + integer , intent(in) :: nl_soil + integer , intent(in) :: nbedrock + real(r8), intent(in) :: z_soi(1:nl_soil) + real(r8), intent(in) :: zi_soi(1:nl_soil) + real(r8), intent(in) :: dz_soi(1:nl_soil) + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dlon + integer , intent(in) :: npcropmin + + ! local + integer :: ps, pe, m + integer :: irrig_nsteps_per_day + logical :: check_for_irrig + ps = patch_pft_s(i) + pe = patch_pft_e(i) + + ! initialize irrigation + deficit_irrig(i) = 0._r8 + actual_irrig(i) = 0._r8 + groundwater_demand(i) = 0._r8 + groundwater_supply(i) = 0._r8 + reservoirriver_demand(i) = 0._r8 + reservoirriver_supply(i) = 0._r8 + reservoir_supply(i) = 0._r8 + river_supply(i) = 0._r8 + runoff_supply(i) = 0._r8 + + ! zero irrigation at the begin of the new year + if (idate(2) == 1 .and. idate(3) == deltim)then + sum_irrig(i) = 0._r8 + sum_deficit_irrig(i) = 0._r8 + sum_irrig_count(i) = 0._r8 + zwt_stand(i) = zwt(i) + 1._r8 + zwt_stand(i) = max(0., zwt_stand(i)) + zwt_stand(i) = min(80., zwt_stand(i)) + end if + + ! ! calculate last day potential evapotranspiration + ! CALL CalPotentialEvapotranspiration(i,idate,dlon,deltim) + + ! calculate whether irrigation needed + CALL PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) + + ! calculate irrigation needed + IF (check_for_irrig) THEN + CALL CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) + call CalIrrigationLimitedSupply(i,nl_soil,deltim,dz_soi,zi_soi) + ENDIF + + ! calculate irrigation rate kg/m2->mm/s + IF ((check_for_irrig) .and. (deficit_irrig(i) > 0)) THEN + sum_deficit_irrig(i) = sum_deficit_irrig(i) + deficit_irrig(i) + ENDIF + IF ((check_for_irrig) .and. (actual_irrig(i) > 0)) THEN + irrig_nsteps_per_day = nint(irrig_time_per_day/deltim) + irrig_rate(i) = actual_irrig(i)/deltim/irrig_nsteps_per_day + n_irrig_steps_left(i) = irrig_nsteps_per_day + sum_irrig(i) = sum_irrig(i) + actual_irrig(i) + sum_irrig_count(i) = sum_irrig_count(i) + 1._r8 + ENDIF + END SUBROUTINE CalIrrigationNeeded + + SUBROUTINE CalIrrigationPotentialNeeded(i,ps,pe,nl_soil,nbedrock,z_soi,dz_soi) + + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate how much irrigation needed in each irrigated crop patch without water supply restriction + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: nbedrock + integer , intent(in) :: nl_soil + real(r8), intent(in) :: z_soi(1:nl_soil) + real(r8), intent(in) :: dz_soi(1:nl_soil) + + ! local variables + integer :: j + integer :: m + logical :: reached_max_depth + real(r8) :: h2osoi_liq_tot + real(r8) :: h2osoi_liq_target_tot + real(r8) :: h2osoi_liq_wilting_point_tot + real(r8) :: h2osoi_liq_field_capacity_tot + real(r8) :: h2osoi_liq_saturation_capacity_tot + real(r8) :: h2osoi_liq_wilting_point(1:nl_soil) + real(r8) :: h2osoi_liq_field_capacity(1:nl_soil) + real(r8) :: h2osoi_liq_saturation_capacity(1:nl_soil) + real(r8) :: h2osoi_liq_at_threshold + + real(r8) :: smpswc = -1.5e5 + real(r8) :: smpsfc = -3.3e3 + + ! initialize local variables + reached_max_depth = .false. + h2osoi_liq_tot = 0._r8 + h2osoi_liq_target_tot = 0._r8 + h2osoi_liq_wilting_point_tot = 0._r8 + h2osoi_liq_field_capacity_tot = 0._r8 + h2osoi_liq_saturation_capacity_tot = 0._r8 + + ! calculate wilting point and field capacity + DO j = 1, nl_soil + IF (t_soisno(j,i) > tfrz .and. porsl(j,i) >= 1.e-6) THEN +#ifdef Campbell_SOIL_MODEL + h2osoi_liq_wilting_point(j) = denh2o*dz_soi(j)*porsl(j,i)*((smpswc/psi0(j,i))**(-1/bsw(j,i))) + h2osoi_liq_field_capacity(j) = denh2o*dz_soi(j)*porsl(j,i)*((smpsfc/psi0(j,i))**(-1/bsw(j,i))) + h2osoi_liq_saturation_capacity(j) = denh2o*dz_soi(j)*porsl(j,i) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + h2osoi_liq_wilting_point(j) = soil_vliq_from_psi(smpswc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & + (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) + h2osoi_liq_wilting_point(j) = denh2o*dz_soi(j)*h2osoi_liq_wilting_point(j) + h2osoi_liq_field_capacity(j) = soil_vliq_from_psi(smpsfc, porsl(j,i), theta_r(j,i), psi0(j,i), 5, & + (/alpha_vgm(j,i), n_vgm(j,i), L_vgm(j,i), sc_vgm(j,i), fc_vgm(j,i)/)) + h2osoi_liq_field_capacity(j) = denh2o*dz_soi(j)*h2osoi_liq_field_capacity(j) + h2osoi_liq_saturation_capacity(j) = denh2o*dz_soi(j)*porsl(j,i) +#endif + ENDIF + ENDDO + + ! calculate total irrigation needed in all soil layers + DO m = ps, pe + DO j = 1, nl_soil + IF (.not. reached_max_depth) THEN + IF (z_soi(j) > irrig_max_depth) THEN + reached_max_depth = .true. + ELSEIF (j > nbedrock) THEN + reached_max_depth = .true. + ELSEIF (t_soisno(j,i) <= tfrz) THEN + reached_max_depth = .true. + ELSE + h2osoi_liq_tot = h2osoi_liq_tot + wliq_soisno(j,i) + h2osoi_liq_wilting_point_tot = h2osoi_liq_wilting_point_tot + h2osoi_liq_wilting_point(j) + h2osoi_liq_field_capacity_tot = h2osoi_liq_field_capacity_tot + h2osoi_liq_field_capacity(j) + h2osoi_liq_saturation_capacity_tot = h2osoi_liq_saturation_capacity_tot + h2osoi_liq_saturation_capacity(j) + ENDIF + ENDIF + ENDDO + IF (irrig_method_p(m) == irrig_method_drip .or. irrig_method_p(m) == irrig_method_sprinkler .or. & + irrig_method_p(m) == irrig_method_flood) THEN + ! flood irrigation threshold at field capacity, but irrigation amount at saturation capacity + h2osoi_liq_target_tot = h2osoi_liq_field_capacity_tot + ELSEIF (irrig_method_p(m) == irrig_method_paddy) THEN + h2osoi_liq_target_tot = h2osoi_liq_saturation_capacity_tot + ELSE + ! default irrigation is sprinkler irrigation + h2osoi_liq_target_tot = h2osoi_liq_field_capacity_tot + ENDIF + ENDDO + + ! calculate irrigation threshold + deficit_irrig(i) = 0._r8 + h2osoi_liq_at_threshold = h2osoi_liq_wilting_point_tot + irrig_threshold_fraction * (h2osoi_liq_target_tot - h2osoi_liq_wilting_point_tot) + + ! calculate total irrigation + DO m = ps, pe + IF (h2osoi_liq_tot < h2osoi_liq_at_threshold) THEN + IF (irrig_method_p(m) == irrig_method_sprinkler) THEN + deficit_irrig(i) = irrig_supply_fraction * (h2osoi_liq_field_capacity_tot - h2osoi_liq_tot) + ! deficit_irrig(i) = irrig_supply_fraction * (h2osoi_liq_field_capacity_tot - h2osoi_liq_tot + potential_evapotranspiration(i)) + ELSEIF (irrig_method_p(m) == irrig_method_flood) THEN + deficit_irrig(i) = irrig_supply_fraction * (h2osoi_liq_saturation_capacity_tot - h2osoi_liq_tot) + ELSE + deficit_irrig(i) = irrig_supply_fraction * (h2osoi_liq_field_capacity_tot - h2osoi_liq_tot) + ENDIF + ELSE + deficit_irrig(i) = 0 + ENDIF + ENDDO + + END SUBROUTINE CalIrrigationPotentialNeeded + + SUBROUTINE CalIrrigationApplicationFluxes(i,deltim,qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy) + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate irrigation application fluxes for each irrigated crop patch + integer , intent(in) :: i + real(r8), intent(in) :: deltim + real(r8), intent(out):: qflx_irrig_drip,qflx_irrig_sprinkler,qflx_irrig_flood,qflx_irrig_paddy + + integer :: ps, pe, m + + ps = patch_pft_s(i) + pe = patch_pft_e(i) + + qflx_irrig_drip = 0._r8 + qflx_irrig_sprinkler = 0._r8 + qflx_irrig_flood = 0._r8 + qflx_irrig_paddy = 0._r8 + + ! add irrigation fluxes to precipitation or land surface + DO m = ps, pe + IF (n_irrig_steps_left(i) > 0) THEN + n_irrig_steps_left(i) = n_irrig_steps_left(i) -1 + IF (waterstorage(i) - irrig_rate(i)*deltim < 0._r8) irrig_rate(i) = waterstorage(i)/deltim + waterstorage(i) = max(waterstorage(i) - irrig_rate(i)*deltim, 0._r8) + IF (irrig_method_p(m) == irrig_method_drip) THEN + qflx_irrig_drip = irrig_rate(i) + ELSEIF (irrig_method_p(m) == irrig_method_sprinkler) THEN + qflx_irrig_sprinkler = irrig_rate(i) + ELSEIF (irrig_method_p(m) == irrig_method_flood) THEN + qflx_irrig_flood = irrig_rate(i) + ELSEIF (irrig_method_p(m) == irrig_method_paddy) THEN + qflx_irrig_paddy = irrig_rate(i) + ELSE + qflx_irrig_sprinkler = irrig_rate(i) + ENDIF + ELSE + irrig_rate(i) = 0._r8 + ENDIF + ENDDO + END SUBROUTINE CalIrrigationApplicationFluxes + + SUBROUTINE PointNeedsCheckForIrrig(i,ps,pe,idate,deltim,dlon,npcropmin,check_for_irrig) + ! DESCRIPTION: + ! This SUBROUTINE is used to calculate whether irrigation needed in each patch + integer , intent(in) :: i + integer , intent(in) :: ps, pe + integer , intent(in) :: idate(3) + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dlon + integer , intent(in) :: npcropmin + logical , intent(out):: check_for_irrig + + ! local variable + integer :: m, ivt + real(r8):: ldate(3) + real(r8):: seconds_since_irrig_start_time + + ! adjust flood irrigation in rice to paddy irrigaiton + DO m = ps, pe + ivt = pftclass(m) + IF ((ivt == 62) .and. (irrig_method_p(m) == irrig_method_flood)) THEN + irrig_method_p(m) = irrig_method_paddy + ENDIF + ENDDO + + DO m = ps, pe + ivt = pftclass(m) + IF ((ivt >= npcropmin) .and. (irrig_crop(ivt)) .and. & + (cphase_p(m) >= irrig_min_cphase) .and. (cphase_p(m)= 0._r8) .and. (seconds_since_irrig_start_time < deltim)) THEN + check_for_irrig = .true. + ELSE + check_for_irrig = .false. + ENDIF + ELSE + check_for_irrig = .false. + ENDIF + ENDDO + + END SUBROUTINE PointNeedsCheckForIrrig + + ! SUBROUTINE CalPotentialEvapotranspiration(i,idate,dlon,deltim) + ! ! DESCRIPTION: + ! ! This SUBROUTINE is used to calculate daily potential evapotranspiration + ! integer , intent(in) :: i + ! integer , intent(in) :: idate(3) + ! real(r8), intent(in) :: dlon + ! real(r8), intent(in) :: deltim + ! ! local variable + ! real(r8):: ldate(3) + ! real(r8):: seconds_since_irrig_start_time + ! real(r8) :: es,esdT,qs,qsdT ! saturation vapour pressure + ! real(r8) :: evsat ! vapour pressure + ! real(r8) :: ur ! wind speed + ! real(r8) :: delta ! slope of saturation vapour pressure curve + ! real(r8) :: gamma ! Psychrometric constant + + ! IF (DEF_simulation_time%greenwich) THEN + ! CALL gmt2local(idate, dlon, ldate) + ! seconds_since_irrig_start_time = ldate(3) - irrig_start_time + deltim + ! ELSE + ! seconds_since_irrig_start_time = idate(3) - irrig_start_time + deltim + ! ENDIF + + ! IF (((seconds_since_irrig_start_time-deltim) >= 0) .and. ((seconds_since_irrig_start_time-deltim) < deltim)) THEN + ! tairday(i) = (forc_t(i)-tfrz)*deltim/86400 + ! usday(i) = forc_us(i)*deltim/86400 + ! vsday(i) = forc_vs(i)*deltim/86400 + ! pairday(i) = forc_psrf(i)*deltim/86400/1000 + ! rnetday(i) = (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 + ! fgrndday(i) = fgrnd(i)*deltim/1000000 + ! ELSE + ! tairday(i) = tairday(i) + (forc_t(i)-tfrz)*deltim/86400 + ! usday(i) = usday(i) + forc_us(i)*deltim/86400 + ! vsday(i) = vsday(i) + forc_vs(i)*deltim/86400 + ! pairday(i) = pairday(i) + forc_psrf(i)*deltim/86400/1000 + ! rnetday(i) = rnetday(i) + (sabg(i)+sabvsun(i)+sabvsha(i)-olrg(i)+forc_frl(i))*deltim/1000000 + ! fgrndday(i) = fgrndday(i) + fgrnd(i)*deltim/1000000 + ! ENDIF + + ! IF ((seconds_since_irrig_start_time >= 0) .and. (seconds_since_irrig_start_time < deltim)) THEN + ! CALL qsadv(tairday(i),pairday(i),es,esdT,qs,qsdT) + ! IF (tairday(i) > 0)THEN + ! evsat = 0.611*EXP(17.27*tairday(i)/(tairday(i)+237.3)) + ! ELSE + ! evsat = 0.611*EXP(21.87*tairday(i)/(tairday(i)+265.5)) + ! ENDIF + ! ur = max(0.1,sqrt(usday(i)*usday(i)+vsday(i)*vsday(i))) + ! delta = 4098*evsat/((tairday(i)+237.3)*(tairday(i)+237.3)) + ! gamma = 0.665*0.001*pairday(i) + ! potential_evapotranspiration(i) = (0.408*delta*(rnetday(i)-fgrndday(i))+gamma*(900/(tairday(i)+273))*ur* & + ! (evsat-es))/(delta+(gamma*(1+0.34*ur))) + ! ENDIF + ! END SUBROUTINE CalPotentialEvapotranspiration + + SUBROUTINE CalIrrigationLimitedSupply(i,nl_soil,deltim,dz_soi,zi_soi) + ! DESCRIPTION: + ! This subroutine is used to calculate how much irrigation supplied in each irrigated crop patch with water supply restriction + integer, intent(in) :: i + integer, intent(in) :: nl_soil + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dz_soi(1:nl_soil) + real(r8), intent(in) :: zi_soi(1:nl_soil) + + real(r8) :: waterstorage_supply + + IF (deficit_irrig(i) > 0._r8) THEN + IF (DEF_IRRIGATION_ALLOCATION == 1) THEN + actual_irrig(i) = deficit_irrig(i) + waterstorage(i) = waterstorage(i) + actual_irrig(i) + ELSEIF (DEF_IRRIGATION_ALLOCATION == 2) THEN + waterstorage_supply = min(waterstorage(i), deficit_irrig(i)) + waterstorage_supply = max(waterstorage_supply, 0._r8) + actual_irrig(i) = actual_irrig(i) + waterstorage_supply + ! irrigation withdraw from ground water (unconfined and confined) + IF (deficit_irrig(i) > actual_irrig(i)) THEN + groundwater_demand(i) = max(deficit_irrig(i) - actual_irrig(i), 0._r8) + CALL CalGroudwaterWithdrawal(i,nl_soil,deltim,dz_soi,zi_soi) + actual_irrig(i) = actual_irrig(i) + groundwater_supply(i) + waterstorage(i) = waterstorage(i) + groundwater_supply(i) + ENDIF + ELSEIF (DEF_IRRIGATION_ALLOCATION == 3) THEN + waterstorage_supply = min(waterstorage(i), deficit_irrig(i)) + waterstorage_supply = max(waterstorage_supply, 0._r8) + actual_irrig(i) = actual_irrig(i) + waterstorage_supply + ! irrigation withdraw from ground water (unconfined and confined) + IF (deficit_irrig(i) > actual_irrig(i)) THEN + groundwater_demand(i) = max((deficit_irrig(i) - actual_irrig(i))*irrig_gw_alloc(i), 0._r8) + CALL CalGroudwaterWithdrawal(i,nl_soil,deltim,dz_soi,zi_soi) + actual_irrig(i) = actual_irrig(i) + groundwater_supply(i) + waterstorage(i) = waterstorage(i) + groundwater_supply(i) + ENDIF + ENDIF + ENDIF + END SUBROUTINE CalIrrigationLimitedSupply + + + SUBROUTINE CalGroudwaterWithdrawal(i,nl_soil,deltim,dz_soi,zi_soi) + ! DESCRIPTION: + ! This subroutine is used to calculate irrigation withdrawals for groudwater + integer, intent(in) :: i + integer, intent(in) :: nl_soil + real(r8), intent(in) :: deltim + real(r8), intent(in) :: dz_soi(1:nl_soil) + real(r8), intent(in) :: zi_soi(1:nl_soil) + + IF (.not. DEF_USE_VariablySaturatedFlow) THEN + CALL CalWithdrawalWATER(i,nl_soil,deltim,dz_soi,zi_soi) + ELSE + groundwater_supply(i) = groundwater_demand(i) + ENDIF + END SUBROUTINE CalGroudwaterWithdrawal + + + + subroutine CalWithdrawalWATER(i,nl_soil,deltim,dz_soi,zi_soi) + ! DESCRIPTION: + ! This subroutine is used to calculate how much irrigation supplied in each irrigated crop patch with groundwater supply restriction + IMPLICIT NONE + integer, INTENT(in) :: i + integer, INTENT(in) :: nl_soil + real(r8), INTENT(in) :: deltim ! land model time step (sec) + real(r8), INTENT(in) :: dz_soi (1:nl_soil) ! layer depth (m) + real(r8), INTENT(in) :: zi_soi (1:nl_soil) ! interface level below a "z" level (m) + + ! LOCAL ARGUMENTS + integer :: j ! indices + integer :: jwt ! index of the soil layer right above the water table (-) + real(r8) :: dzmm(1:nl_soil) ! layer thickness (mm) + real(r8) :: vol_ice(1:nl_soil)! partitial volume of ice lens in layer + real(r8) :: eff_porosity(1:nl_soil)! effective porosity = porosity - vol_ice + real(r8) :: xs ! water needed to bring soil moisture to watmin (mm) + real(r8) :: xsi ! excess soil water above saturation at layer i (mm) + real(r8) :: xs1 ! excess soil water above saturation at layer 1 (mm) + real(r8) :: pump_total + real(r8) :: pump_layer + real(r8) :: max_groundwater_supply + real(r8) :: s_y + real(r8) :: rous ! specific yield [-] + ! ------------------------------------------------------------------------- + + do j = 1, nl_soil + vol_ice(j) = min(porsl(j,i), wice_soisno(j,i)/(dz_soi(j)*denice)) + eff_porosity(j) = max(0.01, porsl(j,i)-vol_ice(j)) + end do + + ! Convert layer thicknesses from m to mm + DO j = 1,nl_soil + dzmm(j) = dz_soi(j)*1000. + ENDDO + + ! The layer index of the first unsaturated layer, + ! i.e., the layer right above the water table + jwt = nl_soil + ! allow jwt to equal zero when zwt is in top layer + DO j = 1, nl_soil + IF(zwt(i) <= zi_soi(j)) THEN + jwt = j-1 + exit + ENDIF + ENDDO + + rous = porsl(nl_soil,i)*(1.-(1.-1.e3*zwt(i)/psi0(nl_soil,i))**(-1./bsw(nl_soil,i))) + rous = max(rous,0.02) + + !-- Water table is below the soil column ---------------------------------------- + IF (jwt == nl_soil) THEN + max_groundwater_supply = max(1.e3*(zwt_stand(i)-zwt(i))*rous, 0._r8) + groundwater_supply(i) = min(groundwater_demand(i), max_groundwater_supply) + wa(i) = wa(i) - groundwater_supply(i) + zwt(i) = max(0., zwt(i) + groundwater_supply(i)/1000./rous) + wliq_soisno(nl_soil,i) = wliq_soisno(nl_soil,i) + max(0.,(wa(i)-5000.)) + wa(i) = min(wa(i), 5000.) + ELSE + !-- Water table within soil layers 1-9 ------------------------------------------ + !============================== RSUB_TOP ========================================= + !-- Now remove water via pump + pump_total = - groundwater_demand(i) + DO j = jwt+1, nl_soil + ! use analytical expression for specific yield + s_y = porsl(j,i) * ( 1. - (1.-1.e3*zwt(i)/psi0(j,i))**(-1./bsw(j,i))) + s_y = max(s_y,0.02) + + pump_layer = max(pump_total, -(s_y*(zi_soi(j)-zwt(i))*1.e3)) + pump_layer = min(pump_layer, 0.) + wliq_soisno(j,i) = wliq_soisno(j,i) + pump_layer + + pump_total = pump_total - pump_layer + groundwater_supply(i) = groundwater_supply(i) - pump_layer + + IF (pump_total >= 0.) THEN + zwt(i) = max(0.,zwt(i) - pump_layer/s_y/1000.) + exit + ELSE + zwt(i) = zi_soi(j) + ENDIF + ENDDO + !-- Remove residual drainage ------------------------------------------------ + max_groundwater_supply = max(1.e3*(zwt_stand(i)-zwt(i))*rous, 0._r8) + pump_total = min(-pump_total, max_groundwater_supply) + pump_total = max(pump_total, 0._r8) + groundwater_supply(i) = groundwater_supply(i) + pump_total + zwt(i) = max(0., zwt(i) + pump_total/1000./rous) + wa(i) = wa(i) - pump_total + + !-- Recompute jwt --------------------------------------------------------------- + ! allow jwt to equal zero when zwt is in top layer + jwt = nl_soil + DO j = 1, nl_soil + IF (zwt(i) <= zi_soi(j)) THEN + jwt = j-1 + exit + ENDIF + ENDDO + ENDIF ! end of jwt if construct + + zwt(i) = max(0.0,zwt(i)) + zwt(i) = min(80.,zwt(i)) + + + ! Correction [2] + ! NON-physically based corection on wliq_soisno + ! Limit wliq_soisno to be greater than or equal to watmin. + ! Get water needed to bring wliq_soisno equal watmin from lower layer. + ! If insufficient water in soil layers, get from aquifer water + xs = 0. + DO j = 1, nl_soil + IF (wliq_soisno(j,i) < 0.) THEN + xs = xs + wliq_soisno(j,i) + wliq_soisno(j,i) = 0. + ENDIF + ENDDO + wa(i) = wa(i) + xs + END SUBROUTINE CalWithdrawalWATER + +END MODULE MOD_Irrigation +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIEmpirical.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIEmpirical.F90 new file mode 100644 index 0000000000..93ac924bf9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIEmpirical.F90 @@ -0,0 +1,139 @@ +#include + +MODULE MOD_LAIEmpirical + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LAI_empirical + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE LAI_empirical(ivt,nl_soil,rootfr,t,lai,sai,fveg,green) + +!----------------------------------------------------------------------- +! provides leaf and stem area parameters +! Original author: Yongjiu Dai, 08/31/2002 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ivt !land cover type + integer, intent(in) :: nl_soil !number of soil layers + + real(r8), intent(in) :: rootfr(1:nl_soil) !root fraction + real(r8), intent(in) :: t(1:nl_soil) !soil temperature + real(r8), intent(out) :: lai !leaf area index + real(r8), intent(out) :: sai !Stem area index + real(r8), intent(out) :: fveg !fractional cover of vegetation + real(r8), intent(out) :: green !greenness + +!-------------------------- Local Variables ---------------------------- + real(r8) f ! + real(r8) roota !accumulates root fraction + integer jrt !number of soil layers with 90% root fraction + integer j !number of soil layers + +!----------------------------------------------------------------------- +#if (defined LULC_USGS) +! Maximum fractional cover of vegetation [-] + real(r8), dimension(24), parameter :: & + vegc=(/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, 0.0, & + 1.0, 1.0, 0.0, 1.0, 1.0, 1.0, 0.0, 0.0 /) +! Maximum leaf area index, the numbers are based on the data of +! "worldwide historical estimates of leaf area index, 1932-2000" : +! http://www.daac.ornl.gov/global_vegetation/HistoricalLai/data" + real(r8), dimension(24), parameter :: & + xla=(/1.50, 3.29, 4.18, 3.50, 2.50, 3.60, 2.02, 1.53, & + 2.00, 0.85, 4.43, 4.42, 4.56, 3.95, 4.50, 0.00, & + 4.00, 3.63, 0.00, 0.64, 1.60, 1.00, 0.00, 0.00 /) +! Minimum leaf area index + real(r8), dimension(24), parameter :: & + xla0=(/1.00, 0.50, 0.50, 0.50, 1.00, 0.50, 0.50, 0.50, & + 0.50, 0.30, 0.50, 0.50, 4.00, 4.00, 4.00, 0.00, & + 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) +! Stem area index [-] + real(r8), dimension(24), parameter :: & + sai0=(/0.20, 0.20, 0.30, 0.30, 0.50, 0.50, 1.00, 0.50, & + 1.00, 0.50, 2.00, 2.00, 2.00, 2.00, 2.00, 0.00, & + 2.00, 2.00, 0.00, 0.10, 0.10, 0.10, 0.00, 0.00 /) +#elif (defined SIB2_CLASSIFICATION) + real(r8), dimension(11), parameter :: & + vegc=(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0/) + real(r8), dimension(11), parameter :: & + xla =(/4.8, 3.9, 5.6, 5.5, 4.6, 1.7, 1.3, 2.1, 3.6, 0.0, 0.0/) + real(r8), dimension(11), parameter :: & + xla0=(/4.0, 0.6, 0.5, 5.0, 0.5, 0.3, 0.6, 0.4, 0.2, 0.0, 0.0/) + real(r8), dimension(11), parameter :: & + sai0=(/1.6, 1.8, 1.6, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.0, 0.0/) +#elif (defined BATS_CLASSIFICATION) + real(r8), dimension(19), parameter :: & + vegc=(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 1.0, 1.0,& + 1.0, 0.0, 1.0, 0.0, 0.0, 1.0, 1.0, 1.0, 1.0/) + real(r8), dimension(19), parameter :: & + xla =(/5.1, 1.6, 4.8, 4.8, 4.8, 5.4, 4.8, 0.0, 3.6, 4.8,& + 0.6, 0.0, 4.8, 0.0, 0.0, 4.8, 4.8, 4.8, 4.8/) + real(r8), dimension(19), parameter :: & + xla0=(/0.425, 0.4, 4.0, 0.8, 0.8, 4.5, 0.4, 0.0, 0.3, 0.4,& + 0.05, 0.0, 0.4, 0.0, 0.0, 4.0, 0.8, 2.4, 2.4/) + real(r8), dimension(19), parameter :: & + sai0=(/0.425, 3.2, 1.6, 1.6, 1.6, 1.8, 1.6, 0.0, 0.3, 0.4,& + 0.2, 0.0, 1.6, 0.0, 0.0, 1.6, 1.6, 1.6, 1.6/) +#elif (defined OGE_CLASSIFICATION) + +#else +!#elif(defined LULC_IGBP) + real(r8), dimension(17), parameter :: & + vegc=(/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, 0.0, 1.0, 0.0/) + real(r8), dimension(17), parameter :: & + xla =(/4.8, 5.4, 4.8, 4.8, 4.7, 4.7, 1.6, 4.7, 4.8, 1.7,& + 4.6, 4.9, 3.8, 4.8, 0.0, 0.06, 0.0/) + real(r8), dimension(17), parameter :: & + xla0=(/4.0, 4.5, 0.8, 0.8, 2.2, 1.6, 0.15, 1.8, 0.9, 0.4,& + 0.4, 0.4, 0.9, 2.0, 0.0, 0.006, 0.0/) + real(r8), dimension(17), parameter :: & + sai0=(/1.6, 1.8, 1.6, 1.6, 1.5, 1.5, 0.45, 1.4, 1.6, 3.1,& + 1.6, 0.4, 1.1, 1.3, 0.0, 0.14, 0.0/) +#endif + +!----------------------------------------------------------------------- + roota = 0. + jrt = 1 + DO j = 1, nl_soil + roota = roota + rootfr(j) + IF(roota>0.9)THEN + jrt = j + EXIT + ENDIF + ENDDO + +! Adjust leaf area index for seasonal variation + + f = max(0.0,1.-0.0016*max(298.-t(jrt),0.0)**2) + lai = xla(ivt) + (xla0(ivt)-xla(ivt))*(1.-f) + +! Sum leaf area index and stem area index + sai = sai0(ivt) + +! Fractional vegetation cover + fveg = vegc(ivt) + + green = 0.0 + IF(fveg > 0.) green = 1.0 + + END SUBROUTINE LAI_empirical + +END MODULE MOD_LAIEmpirical diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 new file mode 100644 index 0000000000..c1dd5caffa --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LAIReadin.F90 @@ -0,0 +1,219 @@ +#include + +MODULE MOD_LAIReadin + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LAI_readin + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE LAI_readin (year, time, dir_landdata) +!======================================================================= +! Read in the LAI, the LAI dataset was created by Yuan et al. (2011) +! http://globalchange.bnu.edu.cn +! +! Created by Yongjiu Dai, March, 2014 +!======================================================================= + + USE MOD_Precision + USE MOD_Namelist + USE MOD_MPAS_MPI + USE MOD_UserDefFun + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + + USE MOD_Vars_Global + USE MOD_Const_LC +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT + USE MOD_Vars_PFTimeVariables +#endif +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + integer, intent(in) :: year, time + character(len=256), intent(in) :: dir_landdata + + ! Local variables + integer :: iyear, itime + character(len=256) :: cyear, ctime + character(len=256) :: landdir, lndname + integer :: m, npatch, pc + +#ifdef LULC_USGS + real(r8), dimension(24), parameter :: & ! Maximum fractional cover of vegetation [-] + vegc=(/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, 0.0, & + 1.0, 1.0, 0.0, 1.0, 1.0, 1.0, 0.0, 0.0 /) +#endif + + ! READ in Leaf area index and stem area index + + landdir = trim(dir_landdata) // '/LAI' + +#ifdef SinglePoint +#ifndef URBAN_MODEL + IF (USE_SITE_LAI) THEN + iyear = minloc(abs(SITE_LAI_year-year), dim=1) + ELSE + iyear = findloc_ud(SITE_LAI_year == min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year))) + ENDIF + + IF (.not. DEF_LAI_MONTHLY) THEN + itime = (time-1)/8 + 1 + ENDIF +#endif +#endif + +#if (defined LULC_USGS || defined LULC_IGBP) + +#ifdef SinglePoint +#ifndef URBAN_MODEL + IF (DEF_LAI_MONTHLY) THEN + tlai(:) = SITE_LAI_monthly(time,iyear) + tsai(:) = SITE_SAI_monthly(time,iyear) + ELSE + tlai(:) = SITE_LAI_8day(itime,iyear) + ENDIF +#endif +#else + IF (DEF_LAI_MONTHLY) THEN + write(cyear,'(i4.4)') min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year) ) + write(ctime,'(i2.2)') time + + lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai) + + lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'SAI_patches', landpatch, tsai) + ELSE + write(cyear,'(i4.4)') min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year) ) + write(ctime,'(i3.3)') time + lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai) + ENDIF +#endif + + IF (.true.) THEN + IF (numpatch > 0) THEN + + DO npatch = 1, numpatch + m = patchclass(npatch) +#ifdef URBAN_MODEL + IF(m == URBAN) CYCLE +#endif + IF(m == 0 .or. m == WATERBODY)THEN + fveg(npatch) = 0. + tlai(npatch) = 0. + tsai(npatch) = 0. + green(npatch) = 0. + ELSE + fveg(npatch) = fveg0(m) !fraction of veg. cover + IF (fveg0(m) > 0) THEN + tlai(npatch) = tlai(npatch)/fveg0(m) !leaf area index + IF (DEF_LAI_MONTHLY) THEN + tsai(npatch) = tsai(npatch)/fveg0(m) !stem are index + ELSE + tsai(npatch) = sai0(m) !stem are index + ENDIF + green(npatch) = 1. !fraction of green leaf + ELSE + tlai(npatch) = 0. + tsai(npatch) = 0. + green(npatch) = 0. + ENDIF + ENDIF + ENDDO + + ENDIF + ENDIF + +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +#ifdef SinglePoint + +#ifndef URBAN_MODEL + IF (.not. DEF_USE_LAIFEEDBACK)THEN + IF (patchtypes(SITE_landtype) == 0) THEN + tlai_p(:) = pack(SITE_LAI_pfts_monthly(:,time,iyear), SITE_pctpfts > 0.) + tsai_p(:) = pack(SITE_SAI_pfts_monthly(:,time,iyear), SITE_pctpfts > 0.) + tlai(:) = sum (SITE_LAI_pfts_monthly(:,time,iyear) * SITE_pctpfts) + tsai(:) = sum (SITE_SAI_pfts_monthly(:,time,iyear) * SITE_pctpfts) + ELSE + tlai(:) = SITE_LAI_monthly(time,iyear) + tsai(:) = SITE_SAI_monthly(time,iyear) + ENDIF + ELSE + IF (patchtypes(SITE_landtype) == 0) THEN + tsai_p(:) = pack(SITE_SAI_pfts_monthly(:,time,iyear), SITE_pctpfts > 0.) + tsai(:) = sum (SITE_SAI_pfts_monthly(:,time,iyear) * SITE_pctpfts) + ELSE + tsai(:) = SITE_SAI_monthly(time,iyear) + ENDIF + ENDIF +#endif +#else + + write(cyear,'(i4.4)') min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year) ) + write(ctime,'(i2.2)') time + IF (.not. DEF_USE_LAIFEEDBACK)THEN + lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'LAI_patches', landpatch, tlai ) + ENDIF + lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_patches'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'SAI_patches', landpatch, tsai ) + IF (.not. DEF_USE_LAIFEEDBACK)THEN + lndname = trim(landdir)//'/'//trim(cyear)//'/LAI_pfts'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'LAI_pfts', landpft, tlai_p ) + ENDIF + lndname = trim(landdir)//'/'//trim(cyear)//'/SAI_pfts'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'SAI_pfts', landpft, tsai_p ) + +#endif + + IF (.true.) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + +#ifdef URBAN_MODEL + IF (m == URBAN) CYCLE +#endif + !TODO@yuan: may need to revise patch LAI/SAI + green(npatch) = 1. + fveg (npatch) = fveg0(m) + + IF (m == WATERBODY) THEN + fveg(npatch) = 0. + tlai(npatch) = 0. + tsai(npatch) = 0. + green(npatch) = 0. + ENDIF + + ENDDO + ENDIF + ENDIF + +#endif + + END SUBROUTINE LAI_readin + +END MODULE MOD_LAIReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Lake.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Lake.F90 new file mode 100644 index 0000000000..98305452ad --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Lake.F90 @@ -0,0 +1,2186 @@ +#include + +MODULE MOD_Lake + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Simulating energy balance processes of land water body +! +! !REFERENCES: +! Dai et al, 2018, The lake scheme of the common land model and its performance evaluation. +! Chinese Science Bulletin, 63(28-29), 3002-3021, https://doi.org/10.1360/N972018-00609 +! +! Original author: Yongjiu Dai 04/2014/ +! +! !REVISIONS: +! Nan Wei, 01/2018: interaction btw prec and lake surface including phase change of prec and water body +! Nan Wei, 06/2018: update heat conductivity of water body and soil below and snow hydrology +! Hua Yuan, 01/2023: added snow layer absorption in melting calculation +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: newsnow_lake + PUBLIC :: laketem + PUBLIC :: snowwater_lake + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: roughness_lake + PRIVATE :: hConductivity_lake + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + + SUBROUTINE newsnow_lake ( USE_Dynamic_Lake, & + ! "in" arguments + ! --------------- + maxsnl , nl_lake , deltim , dz_lake ,& + pg_rain , pg_snow , t_precip , bifall ,& + + ! "inout" arguments + ! ------------------ + t_lake , zi_soisno , z_soisno ,& + dz_soisno , t_soisno , wliq_soisno , wice_soisno ,& + fiold , snl , sag , scv ,& + snowdp , lake_icefrac ) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Add new snow nodes and interaction btw prec and lake surface including phase +! change of prec and water body +! +! Original author: Yongjiu Dai, 04/2014 +! +! !REVISIONS: +! Nan Wei, 01/2018: update interaction btw prec and lake surface +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, denh2o, cpliq, cpice, hfus + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + logical, intent(in) :: USE_Dynamic_Lake + + integer, intent(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: nl_lake ! number of soil layers + real(r8), intent(in) :: deltim ! seconds in a time step [second] + real(r8), intent(inout) :: pg_rain ! liquid water onto ground [kg/(m2 s)] + real(r8), intent(inout) :: pg_snow ! ice onto ground [kg/(m2 s)] + real(r8), intent(in) :: t_precip ! snowfall/rainfall temperature [kelvin] + real(r8), intent(in) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + + real(r8), intent(inout) :: dz_lake(1:nl_lake) ! lake layer thickness (m) + real(r8), intent(inout) :: zi_soisno(maxsnl:0) ! interface level below a "z" level (m) + real(r8), intent(inout) :: z_soisno(maxsnl+1:0) ! snow layer depth (m) + real(r8), intent(inout) :: dz_soisno(maxsnl+1:0) ! snow layer thickness (m) + real(r8), intent(inout) :: t_soisno(maxsnl+1:0) ! snow layer temperature [K] + real(r8), intent(inout) :: wliq_soisno(maxsnl+1:0) ! snow layer liquid water (kg/m2) + real(r8), intent(inout) :: wice_soisno(maxsnl+1:0) ! snow layer ice lens (kg/m2) + real(r8), intent(inout) :: fiold(maxsnl+1:0) ! fraction of ice relative to the total water + integer, intent(inout) :: snl ! number of snow layers + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + real(r8), intent(inout) :: scv ! snow mass (kg/m2) + real(r8), intent(inout) :: snowdp ! snow depth (m) + real(r8), intent(inout) :: lake_icefrac(1:nl_lake) ! mass fraction of lake layer that is frozen + real(r8), intent(inout) :: t_lake(1:nl_lake) ! lake layer temperature (m) + +!-------------------------- Local Variables ---------------------------- + + integer lb + integer newnode ! signification when new snow node is set, (1=yes, 0=non) + real(r8) dz_snowf ! layer thickness rate change due to precipitation [m/s] + real(r8) a, b, c, d, e, f, g, h + real(r8) wice_lake(1:nl_lake), wliq_lake(1:nl_lake), tw + +!----------------------------------------------------------------------- + + newnode = 0 + dz_snowf = pg_snow/bifall + snowdp = snowdp + dz_snowf*deltim + scv = scv + pg_snow*deltim ! snow water equivalent (mm) + + + zi_soisno(0) = 0. + + IF (snl==0 .and. snowdp < 0.01) THEN ! no snow layer, energy exchange between prec and lake surface + + a = cpliq*pg_rain*deltim*(t_precip-tfrz) !cool down rainfall to tfrz + b = pg_rain*deltim*hfus !all rainfall frozen + c = cpice*denh2o*dz_lake(1)*lake_icefrac(1)*(tfrz-t_lake(1)) !warm up lake surface ice to tfrz + d = denh2o*dz_lake(1)*lake_icefrac(1)*hfus !all lake surface ice melt + e = cpice*pg_snow*deltim*(tfrz-t_precip) !warm up snowfall to tfrz + f = pg_snow*deltim*hfus !all snowfall melt + g = cpliq*denh2o*dz_lake(1)*(1-lake_icefrac(1))*(t_lake(1)-tfrz) !cool down lake surface water to tfrz + h = denh2o*dz_lake(1)*(1-lake_icefrac(1))*hfus !all lake surface water frozen + sag = 0.0 + + IF (lake_icefrac(1) > 0.999) THEN + ! all rainfall frozen, release heat to warm up frozen lake surface + IF (a+b<=c) THEN + tw=min(tfrz,t_precip) + t_lake(1)=(a+b+cpice*(pg_rain+pg_snow)*deltim*tw+cpice*denh2o*dz_lake(1)*t_lake(1)*lake_icefrac(1))/& + (cpice*denh2o*dz_lake(1)*lake_icefrac(1)+cpice*(pg_rain+pg_snow)*deltim) + scv = scv+pg_rain*deltim + snowdp = snowdp + pg_rain*deltim/bifall + pg_snow = pg_snow+pg_rain + pg_rain = 0.0 + ! prec tem at tfrz, partial rainfall frozen ->release heat -> warm up lake surface to tfrz (no latent heat) + ELSEIF (a<=c) THEN + t_lake(1)=tfrz + scv = scv + (c-a)/hfus + snowdp = snowdp + (c-a)/(hfus*bifall) + pg_snow = pg_snow + min(pg_rain,(c-a)/(hfus*deltim)) + pg_rain = max(0.0,pg_rain - (c-a)/(hfus*deltim)) + ! lake surface tem at tfrz, partial lake surface melt -> absorb heat -> cool down rainfall to tfrz (no latent heat) + ELSEIF (a<=c+d) THEN + t_lake(1)=tfrz + wice_lake(1) = denh2o*dz_lake(1) - (a-c)/hfus + wliq_lake(1) = (a-c)/hfus + lake_icefrac(1) = wice_lake(1)/(wice_lake(1) + wliq_lake(1)) + ! all lake surface melt, absorb heat to cool down rainfall + ELSE !(a>c+d) + t_lake(1)=(cpliq*pg_rain*deltim*t_precip+cpliq*denh2o*dz_lake(1)*tfrz-c-d)/& + (cpliq*denh2o*dz_lake(1)+cpliq*pg_rain*deltim) + lake_icefrac(1) = 0.0 + ENDIF + + IF (snowdp>=0.01) THEN !frozen rain may make new snow layer + snl = -1 + newnode = 1 + dz_soisno(0) = snowdp ! meter + z_soisno (0) = -0.5*dz_soisno(0) + zi_soisno(-1) = -dz_soisno(0) + sag = 0. ! snow age + + t_soisno (0) = t_lake(1) ! K + wice_soisno(0) = scv ! kg/m2 + wliq_soisno(0) = 0. ! kg/m2 + fiold(0) = 1. + ENDIF + + ELSEIF (lake_icefrac(1) >= 0.001) THEN + IF (pg_rain > 0.0 .and. pg_snow > 0.0) THEN + t_lake(1)=tfrz + ELSEIF (pg_rain > 0.0) THEN + IF (a>=d) THEN + t_lake(1)=(cpliq*pg_rain*deltim*t_precip+cpliq*denh2o*dz_lake(1)*tfrz-d)/& + (cpliq*denh2o*dz_lake(1)+cpliq*pg_rain*deltim) + lake_icefrac(1) = 0.0 + ELSE + t_lake(1)=tfrz + wice_lake(1) = denh2o*dz_lake(1)*lake_icefrac(1) - a/hfus + wliq_lake(1) = denh2o*dz_lake(1)*(1-lake_icefrac(1)) + a/hfus + lake_icefrac(1) = wice_lake(1)/(wice_lake(1) + wliq_lake(1)) + ENDIF + ELSEIF (pg_snow > 0.0) THEN + IF (e>=h) THEN + t_lake(1)=(h+cpice*denh2o*dz_lake(1)*tfrz+cpice*pg_snow*deltim*t_precip)/& + (cpice*pg_snow*deltim+cpice*denh2o*dz_lake(1)) + lake_icefrac(1) = 1.0 + ELSE + t_lake(1)=tfrz + wice_lake(1) = denh2o*dz_lake(1)*lake_icefrac(1) + e/hfus + wliq_lake(1) = denh2o*dz_lake(1)*(1-lake_icefrac(1)) - e/hfus + lake_icefrac(1) = wice_lake(1)/(wice_lake(1) + wliq_lake(1)) + ENDIF + ENDIF + + ELSE + ! all snowfall melt, absorb heat to cool down lake surface water + IF (e+f<=g) THEN + tw=max(tfrz,t_precip) + t_lake(1)=(cpliq*denh2o*dz_lake(1)*t_lake(1)*(1-lake_icefrac(1))+cpliq*(pg_rain+pg_snow)*deltim*tw-e-f)/& + (cpliq*(pg_rain+pg_snow)*deltim+cpliq*denh2o*dz_lake(1)*(1-lake_icefrac(1))) + scv = scv - pg_snow*deltim + snowdp = snowdp - dz_snowf*deltim + pg_rain = pg_rain + pg_snow + pg_snow = 0.0 + ! prec tem at tfrz, partial snowfall melt ->absorb heat -> cool down lake surface to tfrz (no latent heat) + ELSEIF (e<=g) THEN + t_lake(1) = tfrz + scv = scv - (g-e)/hfus + snowdp = snowdp - (g-e)/(hfus*bifall) + pg_rain = pg_rain + min(pg_snow, (g-e)/(hfus*deltim)) + pg_snow = max(0.0, pg_snow - (g-e)/(hfus*deltim)) + ! lake surface tem at tfrz, partial lake surface frozen -> release heat -> warm up snowfall to tfrz (no latent heat) + ELSEIF (e<=g+h) THEN + t_lake(1) = tfrz + wice_lake(1) = (e-g)/hfus + wliq_lake(1) = denh2o*dz_lake(1) - (e-g)/hfus + lake_icefrac(1) = wice_lake(1)/(wice_lake(1) + wliq_lake(1)) + ! all lake surface frozen, release heat to warm up snowfall + ELSE !(e>g+h) + t_lake(1) = (g+h+cpice*denh2o*dz_lake(1)*tfrz+cpice*pg_snow*deltim*t_precip)/& + (cpice*pg_snow*deltim+cpice*denh2o*dz_lake(1)) + lake_icefrac(1) = 1.0 + ENDIF + ENDIF + + IF (USE_Dynamic_Lake .and. (snl == 0)) THEN + + wliq_lake(1) = dz_lake(1) * (1-lake_icefrac(1)) + pg_rain*deltim*1.e-3 + wice_lake(1) = dz_lake(1) * lake_icefrac(1) + dz_lake(1) = wliq_lake(1) + wice_lake(1) + lake_icefrac(1) = wice_lake(1) / dz_lake(1) + + CALL adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + + ENDIF + + ELSEIF (snl==0 .and. snowdp >= 0.01) THEN + + ! only ice part of snowfall is added here, the liquid part will be added later + snl = -1 + newnode = 1 + dz_soisno(0) = snowdp ! meter + z_soisno (0) = -0.5*dz_soisno(0) + zi_soisno(-1) = -dz_soisno(0) + sag = 0. ! snow age + + t_soisno (0) = min(tfrz, t_precip) ! K + wice_soisno(0) = scv ! kg/m2 + wliq_soisno(0) = 0. ! kg/m2 + fiold(0) = 1. + + ELSE ! ( snl<0 .and. newnode ==0 ) + + lb = snl + 1 + t_soisno(lb) = ( (wice_soisno(lb)*cpice+wliq_soisno(lb)*cpliq)*t_soisno(lb) & + + (pg_rain*cpliq + pg_snow*cpice)*deltim*t_precip ) & + / ( wice_soisno(lb)*cpice + wliq_soisno(lb)*cpliq & + + pg_rain*deltim*cpliq + pg_snow*deltim*cpice ) + + t_soisno(lb) = min(tfrz, t_soisno(lb)) + wice_soisno(lb) = wice_soisno(lb)+deltim*pg_snow + dz_soisno(lb) = dz_soisno(lb)+dz_snowf*deltim + z_soisno(lb) = zi_soisno(lb) - 0.5*dz_soisno(lb) + zi_soisno(lb-1) = zi_soisno(lb) - dz_soisno(lb) + + ENDIF + + END SUBROUTINE newsnow_lake + + + + SUBROUTINE laketem (& + ! "in" arguments + ! ------------------- + patchtype , maxsnl , nl_soil , nl_lake ,& + dlat , deltim , forc_hgt_u , forc_hgt_t,& + forc_hgt_q , forc_us , forc_vs , forc_t ,& + forc_q , forc_rhoair , forc_psrf , forc_sols ,& + forc_soll , forc_solsd , forc_solld , sabg ,& + forc_frl , dz_soisno , z_soisno , zi_soisno ,& + dz_lake , lakedepth , vf_quartz , vf_gravels,& + vf_om , vf_sand , wf_gravels , wf_sand ,& + porsl , csol , k_solids , & + dksatu , dksatf , dkdry , & + BA_alpha , BA_beta , hpbl , & + + ! "inout" arguments + ! ------------------- + t_grnd , scv , snowdp , t_soisno ,& + wliq_soisno , wice_soisno , imelt_soisno , t_lake ,& + lake_icefrac , savedtke1 , & + +! SNICAR model variables + snofrz ,sabg_snow_lyr, & +! END SNICAR model variables + + ! "out" arguments + ! ------------------- + taux , tauy , fsena ,& + fevpa , lfevpa , fseng , fevpg ,& + qseva , qsubl , qsdew , qfros ,& + olrg , fgrnd , tref , qref ,& + trad , emis , z0m , zol ,& + rib , ustar , qstar , tstar ,& + fm , fh , fq , sm ,& + urban_call) + +! ------------------------ code history --------------------------- +! purpose: lake temperature and snow on frozen lake +! initial Yongjiu Dai, 2000 +! Zack Subin, 2009 +! Yongjiu Dai, /12/2012/, /04/2014/, 06/2018 +! Nan Wei, /06/2018/ +! +! ------------------------ notes ---------------------------------- +! Lakes have variable depth, possible snow layers above, freezing & +! thawing of lake water, and soil layers with active temperature and +! gas diffusion below. +! +! Calculates temperatures in the 25-30 layer column of (possible) snow, +! lake water, soil, and bedrock beneath lake. Snow and soil +! temperatures are determined as in SoilTemperature, except for +! appropriate boundary conditions at the top of the snow (the flux is +! fixed to be the ground heat flux), the bottom of the snow (adjacent +! to top lake layer), and the top of the soil (adjacent to the bottom +! lake layer). Also, the soil is kept fully saturated. The whole +! column is solved simultaneously as one tridiagonal matrix. +! +! calculate lake temperatures from one-dimensional thermal +! stratification model based on eddy diffusion concepts to represent +! vertical mixing of heat +! +! d ts d d ts 1 ds +! ---- = -- [(km + ke) ----] + -- -- +! dt dz dz cw dz +! where: ts = temperature (kelvin) +! t = time (s) +! z = depth (m) +! km = molecular diffusion coefficient (m**2/s) +! ke = eddy diffusion coefficient (m**2/s) +! cw = heat capacity (j/m**3/kelvin) +! s = heat source term (w/m**2) +! +! use crank-nicholson method to set up tridiagonal system of equations to +! solve for ts at time n+1, where the temperature equation for layer i is +! r_i = a_i [ts_i-1] n+1 + b_i [ts_i] n+1 + c_i [ts_i+1] n+1 +! the solution conserves energy as +! cw*([ts( 1)] n+1 - [ts( 1)] n)*dz( 1)/dt + ... + +! cw*([ts(nl_lake)] n+1 - [ts(nl_lake)] n)*dz(nl_lake)/dt = fin +! where +! [ts] n = old temperature (kelvin) +! [ts] n+1 = new temperature (kelvin) +! fin = heat flux into lake (w/m**2) +! = beta*sabg_snow_lyr(1)+forc_frl-olrg-fsena-lfevpa-hm + phi(1) + ... + phi(nl_lake) +! +! !REVISIONS: +! Yongjiu Dai and Hua Yuan, 01/2023: added SNICAR for layer solar absorption, ground heat +! flux, temperature and freezing mass calculations +! Shaofeng Liu, 05/2023: add option to call moninobuk_leddy, the LargeEddy +! surface turbulence scheme (LZD2022); +! make a proper update of um. +! +! ----------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz,hvap,hfus,hsub,tkwat,tkice,tkair,stefnc,& + vonkar,grav,cpliq,cpice,cpair,denh2o,denice,rgas + USE MOD_FrictionVelocity + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_SNICAR + USE MOD_TurbulenceLEddy + USE MOD_Qsadv + USE MOD_SoilThermalParameters + USE MOD_Utils + + IMPLICIT NONE +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: patchtype ! land patch type (4=deep lake, 5=shallow lake) + integer, intent(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: nl_soil ! number of soil layers + integer, intent(in) :: nl_lake ! number of lake layers + + real(r8), intent(in) :: dlat ! latitude (radians) + real(r8), intent(in) :: deltim ! seconds in a time step (s) + real(r8), intent(in) :: forc_hgt_u ! observational height of wind [m] + real(r8), intent(in) :: forc_hgt_t ! observational height of temperature [m] + real(r8), intent(in) :: forc_hgt_q ! observational height of humidity [m] + real(r8), intent(in) :: forc_us ! wind component in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind component in northward direction [m/s] + real(r8), intent(in) :: forc_t ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: forc_q ! specific humidity at agcm reference height [kg/kg] + real(r8), intent(in) :: forc_rhoair ! density air [kg/m3] + real(r8), intent(in) :: forc_psrf ! atmosphere pressure at the surface [pa] + real(r8), intent(in) :: forc_sols ! atm vis direct beam solar rad onto srf [W/m2] + real(r8), intent(in) :: forc_soll ! atm nir direct beam solar rad onto srf [W/m2] + real(r8), intent(in) :: forc_solsd ! atm vis diffuse solar rad onto srf [W/m2] + real(r8), intent(in) :: forc_solld ! atm nir diffuse solar rad onto srf [W/m2] + real(r8), intent(in) :: forc_frl ! atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: sabg ! solar radiation absorbed by ground [W/m2] + + real(r8), intent(in) :: dz_soisno(maxsnl+1:nl_soil) ! soil/snow layer thickness (m) + real(r8), intent(in) :: z_soisno(maxsnl+1:nl_soil) ! soil/snow node depth [m] + real(r8), intent(in) :: zi_soisno(maxsnl:nl_soil) ! soil/snow depth of layer interface [m] + + real(r8), intent(in) :: dz_lake(nl_lake) ! lake layer thickness (m) + real(r8), intent(in) :: lakedepth ! column lake depth (m) + + real(r8), intent(in) :: vf_quartz (1:nl_soil) ! volumetric fraction of quartz within mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) ! volumetric fraction of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) ! volumetric fraction of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) ! volumetric fraction of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) ! gravimetric fraction of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) ! gravimetric fraction of sand + real(r8), intent(in) :: porsl(1:nl_soil) ! soil porosity [-] + + real(r8), intent(in) :: csol(1:nl_soil) ! heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids(1:nl_soil) ! thermal conductivity of mineralssoil [W/m-K] + real(r8), intent(in) :: dksatu(1:nl_soil) ! thermal conductivity of saturated unfrozen soil [W/m-K] + real(r8), intent(in) :: dksatf(1:nl_soil) ! thermal conductivity of saturated frozen soil [W/m-K] + real(r8), intent(in) :: dkdry(1:nl_soil) ! thermal conductivity of dry soil [W/m-K] + real(r8), intent(in) :: BA_alpha(1:nl_soil) ! alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), intent(in) :: BA_beta(1:nl_soil) ! beta in Balland and Arp(2005) thermal conductivity scheme + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(inout) :: t_grnd ! surface temperature (kelvin) + real(r8), intent(inout) :: scv ! snow water equivalent [mm] + real(r8), intent(inout) :: snowdp ! snow depth [mm] + + real(r8), intent(inout) :: t_soisno (maxsnl+1:nl_soil) ! soil/snow temperature [K] + real(r8), intent(inout) :: wliq_soisno (maxsnl+1:nl_soil) ! soil/snow liquid water (kg/m2) + real(r8), intent(inout) :: wice_soisno (maxsnl+1:nl_soil) ! soil/snow ice lens (kg/m2) + integer, intent(inout) :: imelt_soisno(maxsnl+1:nl_soil) ! soil/snow flag for melting (=1), freezing (=2), Not=0 (new) + + real(r8), intent(inout) :: t_lake(nl_lake) ! lake temperature (kelvin) + real(r8), intent(inout) :: lake_icefrac(nl_lake) ! lake mass fraction of lake layer that is frozen + real(r8), intent(inout) :: savedtke1 ! top level eddy conductivity (W/m K) + +! SNICAR model variables + real(r8), intent(out) :: snofrz (maxsnl+1:0) ! snow freezing rate (col,lyr) [kg m-2 s-1] + real(r8), intent(in) :: sabg_snow_lyr(maxsnl+1:1) ! solar radiation absorbed by ground [W/m2] +! END SNICAR model variables + + real(r8), intent(out) :: taux ! wind stress: E-W [kg/m/s**2] + real(r8), intent(out) :: tauy ! wind stress: N-S [kg/m/s**2] + real(r8), intent(out) :: fsena ! sensible heat from canopy height to atmosphere [W/m2] + real(r8), intent(out) :: fevpa ! evapotranspiration from canopy height to atmosphere [mm/s] + real(r8), intent(out) :: lfevpa ! latent heat flux from canopy height to atmosphere [W/m2] + + real(r8), intent(out) :: fseng ! sensible heat flux from ground [W/m2] + real(r8), intent(out) :: fevpg ! evaporation heat flux from ground [mm/s] + + real(r8), intent(out) :: qseva ! ground surface evaporation rate (mm h2o/s) + real(r8), intent(out) :: qsubl ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), intent(out) :: qsdew ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), intent(out) :: qfros ! ground surface frosting formation (mm H2O /s) [+] + + real(r8), intent(out) :: olrg ! outgoing long-wave radiation from ground+canopy + real(r8), intent(out) :: fgrnd ! ground heat flux [W/m2] + + real(r8), intent(out) :: tref ! 2 m height air temperature [kelvin] + real(r8), intent(out) :: qref ! 2 m height air specific humidity + real(r8), intent(out) :: trad ! radiative temperature [K] + + real(r8), intent(out) :: emis ! averaged bulk surface emissivity + real(r8), intent(out) :: z0m ! effective roughness [m] + real(r8), intent(out) :: zol ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), intent(out) :: rib ! bulk Richardson number in surface layer + real(r8), intent(out) :: ustar ! u* in similarity theory [m/s] + real(r8), intent(out) :: qstar ! q* in similarity theory [kg/kg] + real(r8), intent(out) :: tstar ! t* in similarity theory [K] + real(r8), intent(out) :: fm ! integral of profile function for momentum + real(r8), intent(out) :: fh ! integral of profile function for heat + real(r8), intent(out) :: fq ! integral of profile function for moisture + real(r8), intent(out) :: sm ! rate of snowmelt [mm/s, kg/(m2 s)] + logical, optional, intent(in) :: urban_call ! whether it is a urban CALL + +!-------------------------- Local Variables ---------------------------- +! ---------------- local variables in surface temp and fluxes calculation ----------------- + integer idlak ! index of lake, 1 = deep lake, 2 = shallow lake + real(r8) z_lake (nl_lake) ! lake node depth (middle point of layer) (m) + + real(r8) ax ! used in iteration loop for calculating t_grnd (numerator of NR solution) + real(r8) bx ! used in iteration loop for calculating t_grnd (denomin. of NR solution) + real(r8) beta1 ! coefficient of conective velocity [-] + real(r8) degdT ! d(eg)/dT + real(r8) displax ! zero- displacement height [m] + real(r8) dqh ! diff of humidity between ref. height and surface + real(r8) dth ! diff of virtual temp. between ref. height and surface + real(r8) dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8) dzsur ! 1/2 the top layer thickness (m) + real(r8) tsur ! top layer temperature + real(r8) rhosnow ! partial density of water (ice + liquid) + real(r8) eg ! water vapor pressure at temperature T [pa] + real(r8) emg ! ground emissivity (0.97 for snow, + real(r8) errore ! lake temperature energy conservation error (w/m**2) + real(r8) hm ! energy residual [W/m2] + real(r8) htvp ! latent heat of vapor of water (or sublimation) [j/kg] + real(r8) obu ! monin-obukhov length (m) + real(r8) obuold ! monin-obukhov length of previous iteration + real(r8) qsatg ! saturated humidity [kg/kg] + real(r8) qsatgdT ! d(qsatg)/dT + + real(r8) ram ! aerodynamical resistance [s/m] + real(r8) rah ! thermal resistance [s/m] + real(r8) raw ! moisture resistance [s/m] + real(r8) stftg3 ! emg*sb*t_grnd*t_grnd*t_grnd + real(r8) fh2m ! relation for temperature at 2m + real(r8) fq2m ! relation for specific humidity at 2m + real(r8) fm10m ! integral of profile function for momentum at 10m + real(r8) t_grnd_bef0 ! initial ground temperature + real(r8) t_grnd_bef ! initial ground temperature + real(r8) thm ! intermediate variable (forc_t+0.0098*forc_hgt_t) + real(r8) th ! potential temperature (kelvin) + real(r8) thv ! virtual potential temperature (kelvin) + real(r8) thvstar ! virtual potential temperature scaling parameter + real(r8) tksur ! thermal conductivity of snow/soil (w/m/kelvin) + real(r8) um ! wind speed including the stability effect [m/s] + real(r8) ur ! wind speed at reference height [m/s] + real(r8) visa ! kinematic viscosity of dry air [m2/s] + real(r8) wc ! convective velocity [m/s] + real(r8) wc2 ! wc*wc + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) zii ! convective boundary height [m] + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) z0mg ! roughness length over ground, momentum [m] + real(r8) z0hg ! roughness length over ground, sensible heat [m] + real(r8) z0qg ! roughness length over ground, latent heat [m] + + real(r8) wliq_lake(nl_lake) ! lake liquid water (kg/m2) + real(r8) wice_lake(nl_lake) ! lake ice lens (kg/m2) + real(r8) vf_water(1:nl_soil) ! volumetric fraction liquid water within underlying soil + real(r8) vf_ice(1:nl_soil) ! volumetric fraction ice lens within underlying soil + + real(r8) fgrnd1 ! ground heat flux into the first snow/lake layer [W/m2] + +! ---------------- local variables in lake/snow/soil temperature calculation -------------- + real(r8), parameter :: cur0 = 0.01 ! min. Charnock parameter + real(r8), parameter :: curm = 0.1 ! maximum Charnock parameter + real(r8), parameter :: fcrit = 22. ! critical dimensionless fetch for Charnock parameter (Vickers & Mahrt 1997) + ! but converted to USE u instead of u* (Subin et al. 2011) + real(r8), parameter :: mixfact = 5. ! Mixing enhancement factor. + real(r8), parameter :: depthcrit = 25. ! (m) Depth beneath which to enhance mixing + real(r8), parameter :: fangmult = 5. ! Multiplier for unfrozen diffusivity + real(r8), parameter :: minmultdepth = 20. ! (m) Minimum depth for imposing fangmult + real(r8), parameter :: cnfac = 0.5 ! Crank Nicholson factor between 0 and 1 + + !-------------------- + real(r8) fetch ! lake fetch (m) + real(r8) cur ! Charnock parameter (-) + real(r8) betavis ! + real(r8) betaprime ! Effective beta + real(r8) tdmax ! temperature of maximum water density + real(r8) cfus ! effective heat of fusion per unit volume + real(r8) tkice_eff ! effective conductivity since layer depth is constant + real(r8) cice_eff ! effective heat capacity of ice (using density of + ! water because layer depth is not adjusted when freezing + real(r8) cwat ! specific heat capacity of water (j/m**3/kelvin) + + !-------------------- + real(r8) rhow(nl_lake) ! density of water (kg/m**3) + real(r8) fin ! heat flux into lake - flux out of lake (w/m**2) + real(r8) phi(nl_lake) ! solar radiation absorbed by layer (w/m**2) + real(r8) phi_soil ! solar radiation into top soil layer (W/m^2) + real(r8) phidum ! temporary value of phi + + integer imelt_lake(1:nl_lake) ! lake flag for melting or freezing snow and soil layer [-] + real(r8) cv_lake(1:nl_lake) ! heat capacity [J/(m2 K)] + real(r8) tk_lake(1:nl_lake) ! thermal conductivity at layer node [W/(m K)] + real(r8) cv_soisno(maxsnl+1:nl_soil) ! heat capacity of soil/snow [J/(m2 K)] + real(r8) tk_soisno(maxsnl+1:nl_soil) ! thermal conductivity of soil/snow [W/(m K)] (at interface below, except for j=0) + real(r8) hcap(1:nl_soil) ! J/(m3 K) + real(r8) thk(maxsnl+1:nl_soil) ! W/(m K) + real(r8) tktopsoil ! thermal conductivity of the top soil layer [W/(m K)] + + real(r8) t_soisno_bef(maxsnl+1:nl_soil) ! beginning soil/snow temp for E cons. check [K] + real(r8) t_lake_bef(1:nl_lake) ! beginning lake temp for energy conservation check [K] + real(r8) wice_soisno_bef(maxsnl+1:0) ! ice lens [kg/m2] + + real(r8) cvx (maxsnl+1:nl_lake+nl_soil) ! heat capacity for whole column [J/(m2 K)] + real(r8) tkix (maxsnl+1:nl_lake+nl_soil) ! thermal conductivity at layer interfaces for whole column [W/(m K)] + real(r8) phix (maxsnl+1:nl_lake+nl_soil) ! solar source term for whole column [W/m**2] + real(r8) zx (maxsnl+1:nl_lake+nl_soil) ! interface depth (+ below surface) for whole column [m] + real(r8) tx (maxsnl+1:nl_lake+nl_soil) ! temperature of whole column [K] + real(r8) tx_bef (maxsnl+1:nl_lake+nl_soil) ! beginning lake/snow/soil temp for energy conservation check [K] + real(r8) factx (maxsnl+1:nl_lake+nl_soil) ! coefficient used in computing tridiagonal matrix + real(r8) fnx (maxsnl+1:nl_lake+nl_soil) ! heat diffusion through the layer interface below [W/m2] + real(r8) a (maxsnl+1:nl_lake+nl_soil) ! "a" vector for tridiagonal matrix + real(r8) b (maxsnl+1:nl_lake+nl_soil) ! "b" vector for tridiagonal matrix + real(r8) c (maxsnl+1:nl_lake+nl_soil) ! "c" vector for tridiagonal matrix + real(r8) r (maxsnl+1:nl_lake+nl_soil) ! "r" vector for tridiagonal solution + real(r8) fn1 (maxsnl+1:nl_lake+nl_soil) ! heat diffusion through the layer interface below [W/m2] + real(r8) brr (maxsnl+1:nl_lake+nl_soil) ! + integer imelt_x(maxsnl+1:nl_lake+nl_soil) ! flag for melting (=1), freezing (=2), Not=0 (new) + + real(r8) dzm ! used in computing tridiagonal matrix [m] + real(r8) dzp ! used in computing tridiagonal matrix [m] + real(r8) zin ! depth at top of layer (m) + real(r8) zout ! depth at bottom of layer (m) + real(r8) rsfin ! relative flux of solar radiation into layer + real(r8) rsfout ! relative flux of solar radiation out of layer + real(r8) eta ! light extinction coefficient (/m): depends on lake type + real(r8) za(2) ! base of surface absorption layer (m): depends on lake type + !-------------------- + + real(r8) hs ! net ground heat flux into the surface + real(r8) dhsdT ! temperature derivative of "hs" + real(r8) heatavail ! available energy for melting or freezing (J/m^2) + real(r8) heatrem ! energy residual or loss after melting or freezing + real(r8) melt ! actual melting (+) or freezing (-) [kg/m2] + real(r8) xmf ! total per-column latent heat abs. from phase change (J/m^2) + !-------------------- + + real(r8) ocvts ! (cwat*(t_lake[n ])*dz_lake + real(r8) ncvts ! (cwat*(t_lake[n+1])*dz_lake + real(r8) esum1 ! temp for checking energy (J/m^2) + real(r8) esum2 ! "" + real(r8) zsum ! temp for putting ice at the top during convection (m) + real(r8) errsoi ! soil/lake energy conservation error (W/m^2) + + real(r8) iceav ! used in calc aver ice for convectively mixed layers + real(r8) qav ! used in calc aver heat content for conv. mixed layers + real(r8) tav ! used in aver temp for convectively mixed layers + real(r8) tav_froz ! used in aver temp for convectively mixed layers (C) + real(r8) tav_unfr ! " + real(r8) nav ! used in aver temp for convectively mixed layers + + real(r8) fevpg_lim ! temporary evap_soi limited by top snow layer content [mm/s] + real(r8) scv_temp ! temporary h2osno [kg/m^2] + real(r8) tmp ! + real(r8) h_fin ! + real(r8) h_finDT ! + real(r8) del_T_grnd! + !real(r8) savedtke1 + + integer iter ! iteration index + integer convernum ! number of time when del_T_grnd < 0.01 + integer nmozsgn ! number of times moz changes sign + +! assign iteration parameters + integer, parameter :: itmax = 40 ! maximum number of iteration + integer, parameter :: itmin = 6 ! minimum number of iteration + real(r8),parameter :: delmax = 3.0 ! maximum change in lake temperature [K] + real(r8),parameter :: dtmin = 0.01 ! max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 ! max limit for energy flux convergence [w/m2] + + !-------------------- + + integer nl_sls ! abs(snl)+nl_lake+nl_soil + integer snl ! number of snow layers (minimum -5) + integer lb ! lower bound of arrays + integer jprime ! j - nl_lake + + integer i,j ! do loop or array index + +! ====================================================================== +!*[1] constants and model parameters +! ====================================================================== + + +! constants for lake temperature model + za = (/0.5, 0.6/) + cwat = cpliq*denh2o ! water heat capacity per unit volume + cice_eff = cpice*denh2o ! use water density because layer depth is not adjusted for freezing + cfus = hfus*denh2o ! latent heat per unit volume + tkice_eff = tkice * denice/denh2o ! effective conductivity since layer depth is constant + emg = 0.97 ! surface emissivity + +! define snow layer on ice lake + snl = 0 + DO j=maxsnl+1,0 + IF(wliq_soisno(j)+wice_soisno(j)>0.) snl=snl-1 + ENDDO + lb = snl + 1 + +! latent heat + IF (t_grnd > tfrz )THEN + htvp = hvap + ELSE + htvp = hsub + ENDIF + +! define levels + z_lake(1) = dz_lake(1) / 2. + DO j = 2, nl_lake + z_lake(j) = z_lake(j-1) + (dz_lake(j-1) + dz_lake(j))/2. + ENDDO + +! Base on lake depth, assuming that small lakes are likely to be shallower +! Estimate crudely based on lake depth + IF (z_lake(nl_lake) < 4.) THEN + idlak = 1 + fetch = 100. ! shallow lake + ELSE + idlak = 2 + fetch = 25.*z_lake(nl_lake) ! deep lake + ENDIF + + +! ====================================================================== +!*[2] pre-processing for the calculation of the surface temperature and fluxes +! ====================================================================== + + IF (.not. DEF_USE_SNICAR .or. present(urban_call)) THEN + IF (snl == 0) THEN + ! calculate the nir fraction of absorbed solar. + betaprime = (forc_soll+forc_solld)/max(1.e-5,forc_sols+forc_soll+forc_solsd+forc_solld) + betavis = 0. ! The fraction of the visible (e.g. vis not nir from atm) sunlight + ! absorbed in ~1 m of water (the surface layer za_lake). + ! This is roughly the fraction over 700 nm but may depend on the details + ! of atmospheric radiative transfer. + ! As long as NIR = 700 nm and up, this can be zero. + betaprime = betaprime + (1.0-betaprime)*betavis + ELSE + ! or frozen but no snow layers or + ! currently ignore the transmission of solar in snow and ice layers + ! to be updated in the future version + betaprime = 1.0 + ENDIF + + ELSE + ! calculate the nir fraction of absorbed solar. + betaprime = (forc_soll+forc_solld)/max(1.e-5,forc_sols+forc_soll+forc_solsd+forc_solld) + betavis = 0. ! The fraction of the visible (e.g. vis not nir from atm) sunlight + ! absorbed in ~1 m of water (the surface layer za_lake). + ! This is roughly the fraction over 700 nm but may depend on the details + ! of atmospheric radiative transfer. + ! As long as NIR = 700 nm and up, this can be zero. + betaprime = betaprime + (1.0-betaprime)*betavis + ENDIF + + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) +! potential temperature at the reference height + beta1=1. ! - (in computing W_*) + zii = 1000. ! m (pbl height) + thm = forc_t + 0.0098*forc_hgt_t ! intermediate variable equivalent to + ! forc_t*(pgcm/forc_psrf)**(rgas/cpair) + th = forc_t*(100000./forc_psrf)**(rgas/cpair) ! potential T + thv = th*(1.+0.61*forc_q) ! virtual potential T + ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) ! limit set to 0.1 + +! Initialization variables + nmozsgn = 0 + obuold = 0. + dth = thm-t_grnd + dqh = forc_q-qsatg + dthv = dth*(1.+0.61*forc_q)+0.61*th*dqh + zldis = forc_hgt_u-0. + +! Roughness lengths, allow all roughness lengths to be prognostic + ustar=0.06 + wc=0.5 + + ! Kinematic viscosity of dry air (m2/s)- Andreas (1989) CRREL Rep. 89-11 + visa=1.326e-5*(1.+6.542e-3*(forc_t-tfrz) & + + 8.301e-6*(forc_t-tfrz)**2 - 4.84e-9*(forc_t-tfrz)**3) + + cur = cur0 + curm * exp( max( -(fetch*grav/ur/ur)**(1./3.)/fcrit, & ! Fetch-limited + -(z_lake(nl_lake)*grav)**0.5/ur ) ) ! depth-limited + + IF(dthv.ge.0.) THEN + um=max(ur,0.1) + ELSE + um=sqrt(ur*ur+wc*wc) + ENDIF + + DO i=1,5 + z0mg=0.013*ustar*ustar/grav+0.11*visa/ustar + ustar=vonkar*um/log(zldis/z0mg) + ENDDO + + CALL roughness_lake (snl,t_grnd,t_lake(1),lake_icefrac(1),forc_psrf,& + cur,ustar,z0mg,z0hg,z0qg) + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + + IF (snl == 0) THEN + dzsur = dz_lake(1)/2. + ELSE + dzsur = z_soisno(lb)-zi_soisno(lb-1) + ENDIF + + + iter = 1 + del_T_grnd = 1.0 ! t_grnd diff + convernum = 0 ! number of time when del_T_grnd <= 0.01 + + +! ====================================================================== +!*[3] Begin stability iteration and temperature and fluxes calculation +! ====================================================================== + + + ! ===================================== + ITERATION : DO WHILE (iter <= itmax) + ! ===================================== + + t_grnd_bef = t_grnd + + IF (t_grnd_bef > tfrz .and. t_lake(1) > tfrz .and. snl == 0) THEN + tksur = savedtke1 !water molecular conductivity + tsur = t_lake(1) + htvp = hvap + ELSEIF (snl == 0) THEN !frozen but no snow layers + tksur = tkice ! This is an approximation because the whole layer may not be frozen, and it is not + ! accounting for the physical (but not nominal) expansion of the frozen layer. + tsur = t_lake(1) + htvp = hsub + ELSE + ! need to calculate thermal conductivity of the top snow layer + rhosnow = (wice_soisno(lb)+wliq_soisno(lb))/dz_soisno(lb) + tksur = tkair + (7.75e-5*rhosnow + 1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + tsur = t_soisno(lb) + htvp = hsub + ENDIF + +! Evaluated stability-dependent variables using moz from prior iteration + displax = 0. + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(forc_hgt_u,forc_hgt_t,forc_hgt_q,displax,z0mg,z0hg,z0qg,obu,um, hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(forc_hgt_u,forc_hgt_t,forc_hgt_q,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + +! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + stftg3 = emg*stefnc*t_grnd_bef*t_grnd_bef*t_grnd_bef + + ax = betaprime*sabg + emg*forc_frl + 3.*stftg3*t_grnd_bef & + + forc_rhoair*cpair/rah*thm & + - htvp*forc_rhoair/raw*(qsatg-qsatgdT*t_grnd_bef - forc_q) & + + tksur*tsur/dzsur + + bx = 4.*stftg3 + forc_rhoair*cpair/rah & + + htvp*forc_rhoair/raw*qsatgdT + tksur/dzsur + + t_grnd = ax/bx + + !----------------------------------------------------------------- + ! h_fin = betaprime*sabg + emg*forc_frl + 3.*stftg3*t_grnd_bef & ! + ! + forc_rhoair*cpair/rah*thm & ! + ! - htvp*forc_rhoair/raw*(qsatg-qsatgdT*t_grnd_bef - forc_q) ! + ! h_finDT = 4.*stftg3 + forc_rhoair*cpair/rah & ! + ! + htvp*forc_rhoair/raw*qsatgdT ! + ! del_T_grnd = t_grnd - t_grnd_bef ! + !----------------------------------------------------------------! + +! surface fluxes of momentum, sensible and latent +! using ground temperatures from previous time step + + fseng = forc_rhoair*cpair*(t_grnd-thm)/rah + fevpg = forc_rhoair*(qsatg+qsatgdT*(t_grnd-t_grnd_bef)-forc_q)/raw + + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) + dth = thm-t_grnd + dqh = forc_q-qsatg + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + thvstar = tstar*(1.+0.61*forc_q)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF(zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + IF(zeta >= 0.)THEN + um = max(ur,0.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*forc_hgt_u,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta1*beta1*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + CALL roughness_lake (snl,t_grnd,t_lake(1),lake_icefrac(1),forc_psrf,& + cur,ustar,z0mg,z0hg,z0qg) + + iter = iter + 1 + del_T_grnd = abs(t_grnd - t_grnd_bef) + + IF(iter .gt. itmin) THEN + IF(del_T_grnd <= dtmin) THEN + convernum = convernum + 1 + ENDIF + IF(convernum >= 4) EXIT + ENDIF + + ! =============================================== + ENDDO ITERATION ! end of stability iteration + ! =============================================== + +!*---------------------------------------------------------------------- +!*Zack Subin, 3/27/09 +!*Since they are now a function of whatever t_grnd was before cooling +!*to freezing temperature, then this value should be used in the derivative correction term. +!*Allow convection if ground temp is colder than lake but warmer than 4C, or warmer than +!*lake which is warmer than freezing but less than 4C. + tdmax = tfrz + 4.0 + IF ( (snl < 0 .or. t_lake(1) <= tfrz) .and. t_grnd > tfrz) THEN + t_grnd_bef = t_grnd + t_grnd = tfrz + fseng = forc_rhoair*cpair*(t_grnd-thm)/rah + fevpg = forc_rhoair*(qsatg+qsatgdT*(t_grnd-t_grnd_bef)-forc_q)/raw + ELSEIF ( (t_lake(1) > t_grnd .and. t_grnd > tdmax) .or. & + (t_lake(1) < t_grnd .and. t_lake(1) > tfrz .and. t_grnd < tdmax) ) THEN + ! Convective mixing will occur at surface + t_grnd_bef = t_grnd + t_grnd = t_lake(1) + fseng = forc_rhoair*cpair*(t_grnd-thm)/rah + fevpg = forc_rhoair*(qsatg+qsatgdT*(t_grnd-t_grnd_bef)-forc_q)/raw + ENDIF +!*---------------------------------------------------------------------- + +! net longwave from ground to atmosphere + stftg3 = emg*stefnc*t_grnd_bef*t_grnd_bef*t_grnd_bef + olrg = (1.-emg)*forc_frl + emg*stefnc*t_grnd_bef**4 + 4.*stftg3*(t_grnd - t_grnd_bef) + IF (t_grnd > tfrz )THEN + htvp = hvap + ELSE + htvp = hsub + ENDIF + +!The actual heat flux from the ground interface into the lake, not including the light that penetrates the surface. + fgrnd1 = betaprime*sabg + forc_frl - olrg - fseng - htvp*fevpg + + ! January 12, 2023 by Yongjiu Dai + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + hs = sabg_snow_lyr(lb) + forc_frl - olrg - fseng - htvp*fevpg + dhsdT = 0.0 + ENDIF + +!------------------------------------------------------------ +! Set up vector r and vectors a, b, c that define tridiagonal matrix +! snow and lake and soil layer temperature +!------------------------------------------------------------ + +!------------------------------------------------------------ +! Lake density +!------------------------------------------------------------ + + DO j = 1, nl_lake + rhow(j) = (1.-lake_icefrac(j))*denh2o*(1.0-1.9549e-05*(abs(t_lake(j)-277.))**1.68) & + + lake_icefrac(j)*denice + ! allow for ice fraction; assume constant ice density. + ! this is not the correct average-weighting but that's OK because the density will only + ! be used for convection for lakes with ice, and the ice fraction will dominate the + ! density differences between layers. + ! using this average will make sure that surface ice is treated properly during + ! convective mixing. + ENDDO + +!------------------------------------------------------------ +! Diffusivity and implied thermal "conductivity" = diffusivity * cwat +!------------------------------------------------------------ + + DO j = 1, nl_lake + cv_lake(j) = dz_lake(j) * (cwat*(1.-lake_icefrac(j)) + cice_eff*lake_icefrac(j)) + ENDDO + + CALL hConductivity_lake(nl_lake,snl,t_grnd,& + z_lake,t_lake,lake_icefrac,rhow,& + dlat,ustar,z0mg,lakedepth,depthcrit,tk_lake,savedtke1) + +!------------------------------------------------------------ +! Set the thermal properties of the snow above frozen lake and underlying soil +! and check initial energy content. +!------------------------------------------------------------ + + lb = snl+1 + DO i = 1, nl_soil + vf_water(i) = wliq_soisno(i)/(dz_soisno(i)*denh2o) + vf_ice(i) = wice_soisno(i)/(dz_soisno(i)*denice) + CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& + wf_gravels(i),wf_sand(i),k_solids(i),& + csol(i),dkdry(i),dksatu(i),dksatf(i),& + BA_alpha(i),BA_beta(i),& + t_soisno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) + cv_soisno(i) = hcap(i)*dz_soisno(i) + ENDDO + +! Snow heat capacity and conductivity + IF(lb <=0 )THEN + DO j = lb, 0 + cv_soisno(j) = cpliq*wliq_soisno(j) + cpice*wice_soisno(j) + rhosnow = (wice_soisno(j)+wliq_soisno(j))/dz_soisno(j) + thk(j) = tkair + (7.75e-5*rhosnow + 1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO i = lb, nl_soil-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top soil node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and soil + +! modified by Nan Wei, 08/25/2014 + IF (i /= 0) THEN + tk_soisno(i) = thk(i)*thk(i+1)*(z_soisno(i+1)-z_soisno(i)) & + /(thk(i)*(z_soisno(i+1)-zi_soisno(i))+thk(i+1)*(zi_soisno(i)-z_soisno(i))) + ELSE + tk_soisno(i) = thk(i) + ENDIF + ENDDO + tk_soisno(nl_soil) = 0. + tktopsoil = thk(1) + +! Sum cv_lake*t_lake for energy check +! Include latent heat term, and use tfrz as reference temperature +! to prevent abrupt change in heat content due to changing heat capacity with phase change. + + ! This will need to be over all soil / lake / snow layers. Lake is below. + ocvts = 0. + DO j = 1, nl_lake + ocvts = ocvts + cv_lake(j)*(t_lake(j)-tfrz) + cfus*dz_lake(j)*(1.-lake_icefrac(j)) + ENDDO + + ! Now DO for soil / snow layers + DO j = lb, nl_soil + ocvts = ocvts + cv_soisno(j)*(t_soisno(j)-tfrz) + hfus*wliq_soisno(j) + IF (j == 1 .and. scv > 0. .and. j == lb) THEN + ocvts = ocvts - scv*hfus + ENDIF + ENDDO + + ! Set up solar source terms (phix) + ! Modified January 12, 2023 by Yongjiu Dai + IF (.not. DEF_USE_SNICAR .or. present(urban_call)) THEN + IF ((t_grnd > tfrz .and. t_lake(1) > tfrz .and. snl == 0)) THEN !no snow cover, unfrozen layer lakes + DO j = 1, nl_lake + ! extinction coefficient from surface data (1/m), if no eta from surface data, + ! set eta, the extinction coefficient, according to L Hakanson, Aquatic Sciences, 1995 + ! (regression of secchi depth with lake depth for small glacial basin lakes), and the + ! Poole & Atkins expression for extinction coefficient of 1.7 / secchi Depth (m). + + eta = 1.1925*max(lakedepth,1.)**(-0.424) + zin = z_lake(j) - 0.5*dz_lake(j) + zout = z_lake(j) + 0.5*dz_lake(j) + rsfin = exp( -eta*max( zin-za(idlak),0. ) ) ! the radiation within surface layer (z= 0.0) THEN + IF(lb <= 0)THEN + qseva = min(wliq_soisno(lb)/deltim, fevpg) + qsubl = fevpg - qseva + ELSE + qseva = min((1.-lake_icefrac(1))*1000.*dz_lake(1)/deltim, fevpg) + qsubl = fevpg - qseva + ENDIF + ELSE + IF (t_grnd < tfrz) THEN + qfros = abs(fevpg) + ELSE + qsdew = abs(fevpg) + ENDIF + ENDIF + + +#if (defined CoLMDEBUG) + ! sum energy content and total energy into lake for energy check. any errors will be from the + ! tridiagonal solution. + esum1 = 0.0 + esum2 = 0.0 + DO j = lb, nl_lake + nl_soil + esum1 = esum1 + (tx(j)-tx_bef(j))*cvx(j) + esum2 = esum2 + (tx(j)-tfrz)*cvx(j) + ENDDO + ! fgrnd includes all the solar radiation absorbed in the lake, + errsoi = esum1/deltim - fgrnd + IF(abs(errsoi) > 0.1) THEN + write(6,*)'energy conservation error in LAND WATER COLUMN during tridiagonal solution,', & + 'error (W/m^2):', errsoi, fgrnd + ENDIF +#endif + + +!------------------------------------------------------------ +!*[4] Phase change +!------------------------------------------------------------ + + sm = 0.0 + xmf = 0.0 + imelt_soisno(:) = 0 + imelt_lake(:) = 0 + + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + wice_soisno_bef(lb:0) = wice_soisno(lb:0) + ENDIF + + ! Check for case of snow without snow layers and top lake layer temp above freezing. + + IF (snl == 0 .and. scv > 0. .and. t_lake(1) > tfrz) THEN + heatavail = (t_lake(1) - tfrz) * cv_lake(1) + melt = min(scv, heatavail/hfus) + heatrem = max(heatavail - melt*hfus, 0.) !catch small negative value to keep t at tfrz + t_lake(1) = tfrz + heatrem/(cv_lake(1)) + + snowdp = max(0., snowdp*(1. - melt/scv)) + scv = scv - melt + + IF (scv < 1.e-12) scv = 0. ! prevent tiny residuals + IF (snowdp < 1.e-12) snowdp = 0. ! prevent tiny residuals + sm = sm + melt/deltim + xmf = xmf + melt*hfus + ENDIF + + ! Lake phase change + DO j = 1,nl_lake + IF (t_lake(j) > tfrz .and. lake_icefrac(j) > 0.) THEN ! melting + imelt_lake(j) = 1 + heatavail = (t_lake(j) - tfrz) * cv_lake(j) + melt = min(lake_icefrac(j)*denh2o*dz_lake(j), heatavail/hfus) + !denh2o is used because layer thickness is not adjusted for freezing + heatrem = max(heatavail - melt*hfus, 0.) !catch small negative value to keep t at tfrz + ELSEIF (t_lake(j) < tfrz .and. lake_icefrac(j) < 1.) THEN !freezing + imelt_lake(j) = 2 + heatavail = (t_lake(j) - tfrz) * cv_lake(j) + melt = max(-(1.-lake_icefrac(j))*denh2o*dz_lake(j), heatavail/hfus) + !denh2o is used because layer thickness is not adjusted for freezing + heatrem = min(heatavail - melt*hfus, 0.) !catch small positive value to keep t at tfrz + ENDIF + ! Update temperature and ice fraction. + IF (imelt_lake(j) > 0) THEN + lake_icefrac(j) = lake_icefrac(j) - melt/(denh2o*dz_lake(j)) + IF (lake_icefrac(j) > 1.-1.e-12) lake_icefrac(j) = 1. ! prevent tiny residuals + IF (lake_icefrac(j) < 1.e-12) lake_icefrac(j) = 0. ! prevent tiny residuals + cv_lake(j) = cv_lake(j) + melt*(cpliq-cpice) ! update heat capacity + t_lake(j) = tfrz + heatrem/cv_lake(j) + xmf = xmf + melt*hfus + ENDIF + ENDDO + + ! snow & soil phase change. currently, does not DO freezing point depression. + DO j = snl+1,nl_soil + IF (t_soisno(j) > tfrz .and. wice_soisno(j) > 0.) THEN ! melting + imelt_soisno(j) = 1 + heatavail = (t_soisno(j) - tfrz) * cv_soisno(j) + melt = min(wice_soisno(j), heatavail/hfus) + heatrem = max(heatavail - melt*hfus, 0.) !catch small negative value to keep t at tfrz + IF (j <= 0) sm = sm + melt/deltim + ELSEIF (t_soisno(j) < tfrz .and. wliq_soisno(j) > 0.) THEN !freezing + imelt_soisno(j) = 2 + heatavail = (t_soisno(j) - tfrz) * cv_soisno(j) + melt = max(-wliq_soisno(j), heatavail/hfus) + heatrem = min(heatavail - melt*hfus, 0.) !catch small positive value to keep t at tfrz + ENDIF + + ! Update temperature and soil components. + IF (imelt_soisno(j) > 0) THEN + wice_soisno(j) = wice_soisno(j) - melt + wliq_soisno(j) = wliq_soisno(j) + melt + IF (wice_soisno(j) < 1.e-12) wice_soisno(j) = 0. ! prevent tiny residuals + IF (wliq_soisno(j) < 1.e-12) wliq_soisno(j) = 0. ! prevent tiny residuals + cv_soisno(j) = cv_soisno(j) + melt*(cpliq-cpice) ! update heat capacity + t_soisno(j) = tfrz + heatrem/cv_soisno(j) + xmf = xmf + melt*hfus + ENDIF + ENDDO + !------------------------------------------------------------ + + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + !for SNICAR: layer freezing mass flux (positive): + DO j = lb, 0 + IF (imelt_soisno(j)==2 .and. j<1) THEN + snofrz(j) = max(0._r8,(wice_soisno(j)-wice_soisno_bef(j)))/deltim + ENDIF + ENDDO + ENDIF + +#if (defined CoLMDEBUG) + ! second energy check and water check. now check energy balance before and after phase + ! change, considering the possibility of changed heat capacity during phase change, by + ! using initial heat capacity in the first step, final heat capacity in the second step, + ! and differences from tfrz only to avoid enthalpy correction for (cpliq-cpice)*melt*tfrz. + ! also check soil water sum. + DO j = 1, nl_lake + esum2 = esum2 - (t_lake(j)-tfrz)*cv_lake(j) + ENDDO + + DO j = lb, nl_soil + esum2 = esum2 - (t_soisno(j)-tfrz)*cv_soisno(j) + ENDDO + + esum2 = esum2 - xmf + errsoi = esum2/deltim + + IF(abs(errsoi) > 0.1) THEN + write(6,*) 'energy conservation error in LAND WATER COLUMN during phase change, error (W/m^2):', errsoi + ENDIF + +#endif + +!------------------------------------------------------------ +!*[5] Convective mixing: make sure fracice*dz is conserved, heat content c*dz*T is conserved, and +! all ice ends up at the top. Done over all lakes even IF frozen. +! Either an unstable density profile or ice in a layer below an incompletely frozen layer will trigger. +!------------------------------------------------------------ + + ! recalculate density + DO j = 1, nl_lake + rhow(j) = (1.-lake_icefrac(j))*1000.*(1.0-1.9549e-05*(abs(t_lake(j)-277.))**1.68) & + + lake_icefrac(j)*denice + ENDDO + + DO j = 1, nl_lake-1 + qav = 0. + nav = 0. + iceav = 0. + + IF (rhow(j)>rhow(j+1) .or. (lake_icefrac(j)<1.0 .and. lake_icefrac(j+1)>0.)) THEN + DO i = 1, j+1 + qav = qav + dz_lake(i)*(t_lake(i)-tfrz) * & + ((1. - lake_icefrac(i))*cwat + lake_icefrac(i)*cice_eff) + iceav = iceav + lake_icefrac(i)*dz_lake(i) + nav = nav + dz_lake(i) + ENDDO + + qav = qav/nav + iceav = iceav/nav + !IF the average temperature is above freezing, put the extra energy into the water. + !IF it is below freezing, take it away from the ice. + IF (qav > 0.) THEN + tav_froz = 0. !Celsius + tav_unfr = qav / ((1. - iceav)*cwat) + ELSEIF (qav < 0.) THEN + tav_froz = qav / (iceav*cice_eff) + tav_unfr = 0. !Celsius + ELSE + tav_froz = 0. + tav_unfr = 0. + ENDIF + ENDIF + + IF (nav > 0.) THEN + DO i = 1, j+1 + + !put all the ice at the top. + !if the average temperature is above freezing, put the extra energy into the water. + !if it is below freezing, take it away from the ice. + !for the layer with both ice & water, be careful to use the average temperature + !that preserves the correct total heat content given what the heat capacity of that + !layer will actually be. + + IF (i == 1) zsum = 0. + IF ((zsum+dz_lake(i))/nav <= iceav) THEN + lake_icefrac(i) = 1. + t_lake(i) = tav_froz + tfrz + ELSEIF (zsum/nav < iceav) THEN + lake_icefrac(i) = (iceav*nav - zsum) / dz_lake(i) + ! Find average value that preserves correct heat content. + t_lake(i) = ( lake_icefrac(i)*tav_froz*cice_eff & + + (1. - lake_icefrac(i))*tav_unfr*cwat ) & + / ( lake_icefrac(i)*cice_eff + (1-lake_icefrac(i))*cwat ) + tfrz + ELSE + lake_icefrac(i) = 0. + t_lake(i) = tav_unfr + tfrz + ENDIF + zsum = zsum + dz_lake(i) + + rhow(i) = (1.-lake_icefrac(i))*1000.*(1.-1.9549e-05*(abs(t_lake(i)-277.))**1.68) & + + lake_icefrac(i)*denice + ENDDO + ENDIF + ENDDO + +!------------------------------------------------------------ +!*[6] Re-evaluate thermal properties and sum energy content. +!------------------------------------------------------------ + ! for lake + DO j = 1, nl_lake + cv_lake(j) = dz_lake(j) * (cwat*(1.-lake_icefrac(j)) + cice_eff*lake_icefrac(j)) + ENDDO + + ! do as above to sum energy content + ncvts = 0. + DO j = 1, nl_lake + ncvts = ncvts + cv_lake(j)*(t_lake(j)-tfrz) + cfus*dz_lake(j)*(1.-lake_icefrac(j)) + ENDDO + + DO j = lb, nl_soil + ncvts = ncvts + cv_soisno(j)*(t_soisno(j)-tfrz) + hfus*wliq_soisno(j) + IF (j == 1 .and. scv > 0. .and. j == lb) THEN + ncvts = ncvts - scv*hfus + ENDIF + ENDDO + + ! check energy conservation. + errsoi = (ncvts-ocvts)/deltim - fgrnd + IF (abs(errsoi) < 0.10) THEN + fseng = fseng - errsoi + fsena = fseng + fgrnd = fgrnd + errsoi + errsoi = 0. + ELSE + print*, "energy conservation error in LAND WATER COLUMN during convective mixing", errsoi,fgrnd,ncvts,ocvts + ENDIF + + + END SUBROUTINE laketem + + + + SUBROUTINE snowwater_lake ( USE_Dynamic_Lake, & + ! "in" arguments + ! --------------------------- + maxsnl , nl_soil , nl_lake , deltim ,& + ssi , wimp , porsl , pg_rain ,& + pg_snow , dz_lake , imelt , fiold ,& + qseva , qsubl , qsdew , qfros ,& + + ! "inout" arguments + ! --------------------------- + z_soisno , dz_soisno , zi_soisno , t_soisno ,& + wice_soisno , wliq_soisno , t_lake , lake_icefrac ,& + qout_snowb , & + fseng , fgrnd , snl , scv ,& + snowdp , sm , forc_us , forc_vs ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho , mss_bcphi , mss_ocpho , mss_ocphi ,& + mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ,& +! END SNICAR model variables + urban_call ) + +!----------------------------------------------------------------------------------------------- +! Calculation of Lake Hydrology. Lake water mass is kept constant. The +! soil is simply maintained at volumetric saturation if ice melting +! frees up pore space. +! +! Called: +! -> snowwater: change of snow mass and snow water onto soil +! -> snowcompaction: compaction of snow layers +! -> combinesnowlayers: combine snow layers that are thinner than minimum +! -> dividesnowlayers: subdivide snow layers that are thicker than maximum +! +! Initial: Yongjiu Dai, December, 2012 +! April, 2014 +! !REVISIONS: +! Nan Wei, 06/2018: update snow hydrology above lake +! Yongjiu Dai, 01/2023: added for SNICAR model effects for snowwater, +! combinesnowlayers, dividesnowlayers processes by calling snowwater_snicar(), +! SnowLayersCombine_snicar, SnowLayersDivide_snicar() +!----------------------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: denh2o, denice, hfus, tfrz, cpliq, cpice + USE MOD_SoilSnowHydrology + USE MOD_SnowLayersCombineDivide + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + logical, intent(in) :: USE_Dynamic_Lake + + integer, intent(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: nl_soil ! number of soil layers + integer, intent(in) :: nl_lake ! number of soil layers + + real(r8), intent(in) :: deltim ! seconds in a time step (sec) + real(r8), intent(in) :: ssi ! irreducible water saturation of snow + real(r8), intent(in) :: wimp ! water impermeable if porosity less than wimp + real(r8), intent(in) :: porsl(1:nl_soil) ! volumetric soil water at saturation (porosity) + + real(r8), intent(in) :: pg_rain ! rainfall incident on ground [mm/s] + real(r8), intent(in) :: pg_snow ! snowfall incident on ground [mm/s] + + real(r8), intent(inout) :: dz_lake(1:nl_lake) ! layer thickness for lake (m) + + integer, intent(in) :: imelt(maxsnl+1:0) ! signifies if node in melting (imelt = 1) + real(r8), intent(in) :: fiold(maxsnl+1:0) ! fraction of ice relative to the total water content at the previous time step + real(r8), intent(in) :: qseva ! ground surface evaporation rate (mm h2o/s) + real(r8), intent(in) :: qsubl ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), intent(in) :: qsdew ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), intent(in) :: qfros ! ground surface frosting formation (mm H2O /s) [+] + + real(r8), intent(inout) :: z_soisno (maxsnl+1:nl_soil) ! layer depth (m) + real(r8), intent(inout) :: dz_soisno (maxsnl+1:nl_soil) ! layer thickness depth (m) + real(r8), intent(inout) :: zi_soisno (maxsnl:nl_soil) ! interface depth (m) + real(r8), intent(inout) :: t_soisno (maxsnl+1:nl_soil) ! snow temperature (Kelvin) + real(r8), intent(inout) :: wice_soisno(maxsnl+1:nl_soil) ! ice lens (kg/m2) + real(r8), intent(inout) :: wliq_soisno(maxsnl+1:nl_soil) ! liquid water (kg/m2) + real(r8), intent(inout) :: t_lake (1:nl_lake) ! lake temperature (Kelvin) + real(r8), intent(inout) :: lake_icefrac(1:nl_lake) ! mass fraction of lake layer that is frozen + real(r8), intent(inout) :: qout_snowb ! rate of water out of snow bottom (mm/s) + + real(r8), intent(inout) :: fseng ! total sensible heat flux (W/m**2) [+ to atm] + real(r8), intent(inout) :: fgrnd ! heat flux into snow / lake (W/m**2) [+ = into soil] + + integer , intent(inout) :: snl ! number of snow layers + real(r8), intent(inout) :: scv ! snow water (mm H2O) + real(r8), intent(inout) :: snowdp ! snow height (m) + real(r8), intent(inout) :: sm ! rate of snow melt (mm H2O /s) + + real(r8), intent(in) :: forc_us + real(r8), intent(in) :: forc_vs + +! SNICAR model variables +! Aerosol Fluxes (Jan. 07, 2023 by Yongjiu Dai) + real(r8), intent(in) :: forc_aer ( 14 ) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + + logical, optional, intent(in) :: urban_call ! whether it is a urban CALL + + real(r8), intent(inout) :: & + mss_bcpho (maxsnl+1:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (maxsnl+1:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (maxsnl+1:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (maxsnl+1:0), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (maxsnl+1:0), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (maxsnl+1:0), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (maxsnl+1:0), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (maxsnl+1:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) +! END SNICAR model variables + +!-------------------------- Local Variables ---------------------------- + logical has_snow_bef + integer j ! indices + integer lb ! lower bound of array + + real(r8) xmf ! snow melt heat flux (W/m**2) + + real(r8) sumsnowice ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] + real(r8) sumsnowliq ! sum of snow liquid if snow layers found above unfrozen lake [kg/m&2] + logical unfrozen ! true if top lake layer is unfrozen with snow layers above + real(r8) heatsum ! used in case above [J/m^2] + real(r8) heatrem ! used in case above [J/m^2] + real(r8) dw_soil + + real(r8) a, b, c, d + real(r8) wice_lake(1:nl_lake) ! ice lens (kg/m2) + real(r8) wliq_lake(1:nl_lake) ! liquid water (kg/m2) + real(r8) t_ave, frac_ +!----------------------------------------------------------------------- + + ! for runoff calculation (assumed no mass change in the land water bodies) + lb = snl + 1 + qout_snowb = 0.0 + + IF (USE_Dynamic_Lake) THEN + has_snow_bef = (snl < 0) + ENDIF + + ! ---------------------------------------------------------- + !*[1] snow layer on frozen lake + ! ---------------------------------------------------------- + IF (snl < 0) THEN + lb = snl + 1 + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + CALL snowwater_SNICAR (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),qout_snowb, & + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ELSE + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),qout_snowb) + ENDIF + + ! Natural compaction and metamorphosis. + lb = snl + 1 + CALL snowcompaction (lb,deltim, & + imelt(lb:0),fiold(lb:0),t_soisno(lb:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),forc_us,forc_vs,dz_soisno(lb:0)) + + ! Combine thin snow elements + lb = maxsnl + 1 + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + CALL snowlayerscombine_SNICAR (lb, snl,& + z_soisno(lb:1),dz_soisno(lb:1),zi_soisno(lb-1:0),& + wliq_soisno(lb:1),wice_soisno(lb:1), t_soisno(lb:1),scv,snowdp, & + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0)) + ELSE + CALL snowlayerscombine (lb, snl,& + z_soisno(lb:1),dz_soisno(lb:1),zi_soisno(lb-1:0),& + wliq_soisno(lb:1),wice_soisno(lb:1),& + t_soisno(lb:1),scv,snowdp) + ENDIF + + ! Divide thick snow elements + IF (snl < 0) THEN + IF (DEF_USE_SNICAR .and. .not. present(urban_call)) THEN + CALL snowlayersdivide_SNICAR (lb,snl,z_soisno(lb:0),dz_soisno(lb:0),zi_soisno(lb-1:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),t_soisno(lb:0) ,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ELSE + CALL snowlayersdivide (lb,snl,z_soisno(lb:0),dz_soisno(lb:0),zi_soisno(lb-1:0),& + wliq_soisno(lb:0),wice_soisno(lb:0),t_soisno(lb:0)) + ENDIF + ENDIF + + ! ---------------------------------------------------------- + !*[2] check for single completely unfrozen snow layer over lake. + ! Modeling this ponding is unnecessary and can cause instability after the timestep + ! when melt is completed, as the temperature after melt can be excessive + ! because the fluxes were calculated with a fixed ground temperature of freezing, but the + ! phase change was unable to restore the temperature to freezing. (Zack Subnin 05/2010) + ! ---------------------------------------------------------- + + IF (snl == -1 .and. wice_soisno(0) == 0.) THEN + ! Remove layer + ! Take extra heat of layer and release to sensible heat in order to maintain energy conservation. + heatrem = cpliq*wliq_soisno(0)*(t_soisno(0) - tfrz) + fseng = fseng + heatrem/deltim + fgrnd = fgrnd - heatrem/deltim + + snl = 0 + scv = 0. + snowdp = 0. + qout_snowb = qout_snowb + wliq_soisno(0)/deltim + wliq_soisno(0) = 0. + ENDIF + + ENDIF + + ! ---------------------------------------------------------- + !*[3] check for snow layers above lake with unfrozen top layer. Mechanically, + ! the snow will fall into the lake and melt or turn to ice. IF the top layer has + ! sufficient heat to melt the snow without freezing, THEN that will be done. + ! Otherwise, the top layer will undergo freezing, but only IF the top layer will + ! not freeze completely. Otherwise, let the snow layers persist and melt by diffusion. + ! ---------------------------------------------------------- + + IF (t_lake(1) > tfrz .and. snl < 0 .and. lake_icefrac(1) < 0.001) THEN ! for unfrozen lake + unfrozen = .true. + ELSE + unfrozen = .false. + ENDIF + + sumsnowice = 0. + sumsnowliq = 0. + heatsum = 0.0 + DO j = snl+1,0 + IF (unfrozen) THEN + sumsnowice = sumsnowice + wice_soisno(j) + sumsnowliq = sumsnowliq + wliq_soisno(j) + heatsum = heatsum + wice_soisno(j)*cpice*(tfrz-t_soisno(j)) & + + wliq_soisno(j)*cpliq*(tfrz-t_soisno(j)) + ENDIF + ENDDO + + IF (unfrozen) THEN + ! changed by weinan as the subroutine newsnow_lake + ! Remove snow and subtract the latent heat from the top layer. + + t_ave = tfrz - heatsum/(sumsnowice*cpice + sumsnowliq*cpliq) + + a = heatsum + b = sumsnowice*hfus + c = (t_lake(1) - tfrz)*cpliq*denh2o*dz_lake(1) + d = denh2o*dz_lake(1)*hfus + + ! all snow melt + IF (c>=a+b)THEN + t_lake(1) = (cpliq*(denh2o*dz_lake(1)*t_lake(1) + (sumsnowice+sumsnowliq)*tfrz) - a - b) / & + (cpliq*(denh2o*dz_lake(1) + sumsnowice + sumsnowliq)) + sm = sm + scv/deltim + qout_snowb = qout_snowb + scv/deltim + scv = 0. + snowdp = 0. + snl = 0 + ! lake partially freezing to melt all snow + ELSEIF(c+d >= a+b)THEN + t_lake(1) = tfrz + sm = sm + scv/deltim + qout_snowb = qout_snowb + scv/deltim + scv = 0. + snowdp = 0. + snl = 0 + lake_icefrac(1) = (a+b-c)/d + + ! snow do not melt while all lake freezing + ! ELSEIF(c+d < a) THEN + ! t_lake(1) = (c+d + cpice*(sumsnowice*t_ave+denh2o*dz_lake(1)*tfrz) + cpliq*sumsnowliq*t_ave)/& + ! (cpice*(sumsnowice+denh2o*dz_lake(1))+cpliq*sumsnowliq) + ! lake_icefrac(1) = 1.0 + ENDIF + ENDIF + + + ! ---------------------------------------------------------- + !*[4] Soil water and ending water balance + ! ---------------------------------------------------------- + ! Here this consists only of making sure that soil is saturated even as it melts and + ! pore space opens up. Conversely, if excess ice is melting and the liquid water exceeds the + ! saturation value, then remove water. + + dw_soil = 0. + + DO j = 1, nl_soil + dw_soil = dw_soil + wliq_soisno(j) + wice_soisno(j) + + a = wliq_soisno(j)/(dz_soisno(j)*denh2o) + wice_soisno(j)/(dz_soisno(j)*denice) + + IF (a < porsl(j)) THEN + wliq_soisno(j) = max(0., (porsl(j)*dz_soisno(j) - wice_soisno(j)/denice)*denh2o ) + wice_soisno(j) = max(0., (porsl(j)*dz_soisno(j) - wliq_soisno(j)/denh2o)*denice ) + ELSE + wliq_soisno(j) = max(0., wliq_soisno(j) - (a - porsl(j))*denh2o*dz_soisno(j) ) + wice_soisno(j) = max(0., (porsl(j)*dz_soisno(j) - wliq_soisno(j)/denh2o)*denice ) + ENDIF + + IF (wliq_soisno(j) > porsl(j)*denh2o*dz_soisno(j)) THEN + wliq_soisno(j) = porsl(j)*denh2o*dz_soisno(j) + wice_soisno(j) = 0.0 + ENDIF + + dw_soil = dw_soil - wliq_soisno(j) - wice_soisno(j) + ENDDO + + IF (USE_Dynamic_Lake) THEN + + IF (has_snow_bef) THEN + wliq_lake(1) = dz_lake(1) * (1-lake_icefrac(1)) + qout_snowb*deltim*1.e-3 + wice_lake(1) = dz_lake(1) * lake_icefrac(1) + ELSE + wliq_lake(1) = dz_lake(1) * (1-lake_icefrac(1)) + (sm + qsdew - qseva)*deltim*1.e-3 + wice_lake(1) = dz_lake(1) * lake_icefrac(1) + (qfros - qsubl)*deltim*1.e-3 + IF (wliq_lake(1) < 0.) THEN + wice_lake(1) = wice_lake(1) + wliq_lake(1) + wliq_lake(1) = 0. + ENDIF + IF (wice_lake(1) < 0.) THEN + wliq_lake(1) = wliq_lake(1) + wice_lake(1) + wice_lake(1) = 0. + ENDIF + ENDIF + + dz_lake(1) = wliq_lake(1) + wice_lake(1) + dz_lake(1) = max(dz_lake(1), 1.e-6) + lake_icefrac(1) = wice_lake(1) / dz_lake(1) + lake_icefrac(1) = min(max(lake_icefrac(1), 0.), 1.) + + dz_lake(nl_lake) = dz_lake(nl_lake) + dw_soil/1.e3 + + IF (dz_lake(nl_lake) < 0.) THEN + j = nl_lake + DO WHILE (dz_lake(j) < 0.) + IF (j > 1) dz_lake(j-1) = dz_lake(j-1) + dz_lake(j) + dz_lake(j) = 0. + j = j - 1 + IF (j == 0) EXIT + ENDDO + ENDIF + + CALL adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + + ENDIF + + END SUBROUTINE snowwater_lake + + + + SUBROUTINE roughness_lake (snl,t_grnd,t_lake,lake_icefrac,forc_psrf,& + cur,ustar,z0mg,z0hg,z0qg) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate lake surface roughness +! +! Original: +! The Community Land Model version 4.5 (CLM4.5) +! +! !REVISIONS: +! Yongjiu Dai, Nan Wei, 01/2018 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz,vonkar,grav + + IMPLICIT NONE + + integer, intent(in) :: snl ! number of snow layers + real(r8), intent(in) :: t_grnd ! ground temperature + real(r8), intent(in) :: t_lake(1) ! surface lake layer temperature [K] + real(r8), intent(in) :: lake_icefrac(1) ! surface lake layer ice mass fraction [0-1] + real(r8), intent(in) :: forc_psrf ! atmosphere pressure at the surface [pa] + + real(r8), intent(in) :: cur ! Charnock parameter (-) + real(r8), intent(in) :: ustar ! u* in similarity theory [m/s] + + real(r8), intent(out) :: z0mg ! roughness length over ground, momentum [m] + real(r8), intent(out) :: z0hg ! roughness length over ground, sensible heat [m] + real(r8), intent(out) :: z0qg ! roughness length over ground, latent heat [m] + + real(r8), parameter :: cus = 0.1 ! empirical constant for roughness under smooth flow + real(r8), parameter :: kva0 = 1.51e-5 ! kinematic viscosity of air (m^2/s) at 20C and 1.013e5 Pa + real(r8), parameter :: prn = 0.713 ! Prandtl # for air at neutral stability + real(r8), parameter :: sch = 0.66 ! Schmidt # for water in air at neutral stability + + real(r8) kva ! kinematic viscosity of air at ground temperature and forcing pressure + real(r8) sqre0 ! root of roughness Reynolds number +!----------------------------------------------------------------------- + + IF (t_grnd > tfrz .and. t_lake(1) > tfrz .and. snl == 0) THEN + kva = kva0 * (t_grnd/293.15)**1.5 * 1.013e5/forc_psrf ! kinematic viscosity of air + z0mg = max(cus*kva/max(ustar,1.e-4),cur*ustar*ustar/grav) ! momentum roughness length + z0mg = max(z0mg, 1.0e-5) ! This limit is redundant with current values. + sqre0 = (max(z0mg*ustar/kva,0.1))**0.5 ! square root of roughness Reynolds number + z0hg = z0mg * exp( -vonkar/prn*( 4.*sqre0 - 3.2) ) ! SH roughness length + z0qg = z0mg * exp( -vonkar/sch*( 4.*sqre0 - 4.2) ) ! LH roughness length + z0qg = max(z0qg, 1.0e-5) ! Minimum allowed roughness length for unfrozen lakes + z0hg = max(z0hg, 1.0e-5) ! set low so it is only to avoid floating point exceptions + ELSEIF (snl == 0) THEN ! frozen lake with ice, and no snow cover + z0mg = 0.001 ! z0mg won't have changed + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + ELSE ! use roughness over snow + z0mg = 0.0024 ! z0mg won't have changed + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + ENDIF + + END SUBROUTINE roughness_lake + + + + SUBROUTINE hConductivity_lake(nl_lake,snl,t_grnd,& + z_lake,t_lake,lake_icefrac,rhow,& + dlat,ustar,z0mg,lakedepth,depthcrit,tk_lake, savedtke1) + +!----------------------------------------------------------------------- +! Diffusivity and implied thermal "conductivity" = diffusivity * cwat +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz,tkwat,tkice,tkair,& + vonkar,grav,cpliq,cpice,cpair,denh2o,denice + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: nl_lake ! number of soil layers + integer, intent(in) :: snl ! number of snow layers + real(r8), intent(in) :: t_grnd ! ground surface temperature [k] + real(r8), intent(in) :: z_lake(nl_lake) ! lake node depth (middle point of layer) (m) + real(r8), intent(in) :: t_lake(nl_lake) ! lake temperature (kelvin) + real(r8), intent(in) :: lake_icefrac(nl_lake) ! lake mass fraction of lake layer that is frozen + real(r8), intent(in) :: rhow(nl_lake) ! density of water (kg/m**3) + + real(r8), intent(in) :: dlat ! latitude (radians) + real(r8), intent(in) :: ustar ! u* in similarity theory [m/s] + real(r8), intent(in) :: z0mg ! roughness length over ground, momentum [m] + real(r8), intent(in) :: lakedepth ! column lake depth (m) + real(r8), intent(in) :: depthcrit ! (m) Depth beneath which to enhance mixing + + + real(r8), intent(out) :: tk_lake(nl_lake) ! thermal conductivity at layer node [W/(m K)] + real(r8), intent(out) :: savedtke1 ! top level eddy conductivity (W/mK) + +!-------------------------- Local Variables ---------------------------- + real(r8) kme(nl_lake) ! molecular + eddy diffusion coefficient (m**2/s) + real(r8) cwat ! specific heat capacity of water (j/m**3/kelvin) + real(r8) den ! used in calculating ri + real(r8) drhodz ! d [rhow] /dz (kg/m**4) + real(r8) fangkm ! (m^2/s) extra diffusivity based on Fang & Stefan 1996 + real(r8) ke ! eddy diffusion coefficient (m**2/s) + real(r8) km ! molecular diffusion coefficient (m**2/s) + real(r8) ks ! coefficient for calculation of decay of eddy diffusivity with depth + real(r8) n2 ! brunt-vaisala frequency (/s**2) + real(r8) num ! used in calculating ri + real(r8) ri ! richardson number + real(r8) tkice_eff ! effective conductivity since layer depth is constant + real(r8) tmp ! + real(r8) u2m ! 2 m wind speed (m/s + real(r8) ws ! surface friction velocity (m/s) + + real(r8), parameter :: mixfact = 5. ! Mixing enhancement factor. + real(r8), parameter :: p0 = 1. ! neutral value of turbulent prandtl number + + + integer j + +! ------------------------------------------------------------------- + + cwat = cpliq*denh2o + tkice_eff = tkice * denice/denh2o ! effective conductivity since layer depth is constant + km = tkwat/cwat ! a constant (molecular diffusivity) + u2m = max(0.1,ustar/vonkar*log(2./z0mg)) + ws = 1.2e-03 * u2m + ks = 6.6 * sqrt( abs(sin(dlat)) ) * (u2m**(-1.84)) + + DO j = 1, nl_lake-1 + drhodz = (rhow(j+1)-rhow(j)) / (z_lake(j+1)-z_lake(j)) + n2 = max(7.5e-5, grav / rhow(j) * drhodz) + num = 40. * n2 * (vonkar*z_lake(j))**2 + tmp = -2.*ks*z_lake(j) ! to avoid underflow computing + IF(tmp < -40.) tmp = -40. ! + den = max( (ws**2) * exp(tmp), 1.e-10 ) + ri = ( -1. + sqrt( max(1.+num/den, 0.) ) ) / 20. + + IF ((t_grnd > tfrz .and. t_lake(1) > tfrz .and. snl == 0) ) THEN + tmp = -ks*z_lake(j) ! to avoid underflow computing + IF(tmp < -40.) tmp = -40. ! + ke = vonkar*ws*z_lake(j)/p0 * exp(tmp) / (1.+37.*ri*ri) + kme(j) = km + ke + + fangkm = 1.039e-8_r8 * max(n2,7.5e-5)**(-0.43) ! Fang & Stefan 1996, citing Ellis et al 1991 + kme(j) = kme(j) + fangkm + + IF (lakedepth >= depthcrit) THEN + kme(j) = kme(j) * mixfact ! Mixing enhancement factor for lake deep than 25m. + ENDIF + tk_lake(j) = kme(j)*cwat + ELSE + kme(j) = km + fangkm = 1.039e-8 * max(n2,7.5e-5)**(-0.43) + kme(j) = kme(j) + fangkm + IF (lakedepth >= depthcrit) THEN + kme(j) = kme(j) * mixfact + ENDIF + tk_lake(j) = kme(j)*cwat*tkice_eff / ((1.-lake_icefrac(j))*tkice_eff & + + kme(j)*cwat*lake_icefrac(j)) + ENDIF + ENDDO + + kme(nl_lake) = kme(nl_lake-1) + savedtke1 = kme(1)*cwat + + IF ((t_grnd > tfrz .and. t_lake(1) > tfrz .and. snl == 0) ) THEN + tk_lake(nl_lake) = tk_lake(nl_lake-1) + ELSE + tk_lake(nl_lake) = kme(nl_lake)*cwat*tkice_eff / ( (1.-lake_icefrac(nl_lake))*tkice_eff & + + kme(nl_lake)*cwat*lake_icefrac(nl_lake) ) + ENDIF + + END SUBROUTINE hConductivity_lake + + + SUBROUTINE adjust_lake_layer (nl_lake, dz_lake, t_lake, lake_icefrac) + + USE MOD_Const_Physical + IMPLICIT NONE + + integer, intent(in) :: nl_lake + real(r8), intent(inout) :: dz_lake (nl_lake) ! lake layer thickness (m) + real(r8), intent(inout) :: t_lake (nl_lake) ! lake temperature (kelvin) + real(r8), intent(inout) :: lake_icefrac(nl_lake) ! lake mass fraction of lake layer that is frozen + + ! Local Variables + integer :: i, j + real(r8) :: wdsrfm, depthratio, resi, resj + real(r8) :: ticesum, tliqsum, wicesum, wliqsum, olp, tliq, tice, a, b, c, d + real(r8) :: dz_lake_new (nl_lake) + real(r8) :: t_lake_new (nl_lake) + real(r8) :: lake_icefrac_new (nl_lake) + real(r8), parameter :: dzlak(10) = (/0.1, 1., 2., 3., 4., 5., 7., 7., 10.45, 10.45/) ! m + + wdsrfm = sum(dz_lake) + + IF(wdsrfm > 1.)THEN + depthratio = wdsrfm / sum(dzlak(1:nl_lake)) + dz_lake_new(1) = dzlak(1) + dz_lake_new(2:nl_lake-1) = dzlak(2:nl_lake-1)*depthratio + dz_lake_new(nl_lake) = dzlak(nl_lake)*depthratio - (dz_lake_new(1) - dzlak(1)*depthratio) + ELSEIF(wdsrfm > 0. .and. wdsrfm <= 1.)THEN + dz_lake_new(:) = wdsrfm / nl_lake + ENDIF + + j = 1 + resj = dz_lake(j) + + DO i = 1, nl_lake + + ticesum = 0. + tliqsum = 0. + wicesum = 0. + wliqsum = 0. + + resi = dz_lake_new(i) + DO WHILE (resi > 1.e-8) + + olp = min(resi, resj) + ticesum = ticesum + olp * lake_icefrac(j) * t_lake(j) + wicesum = wicesum + olp * lake_icefrac(j) + tliqsum = tliqsum + olp * (1-lake_icefrac(j)) * t_lake(j) + wliqsum = wliqsum + olp * (1-lake_icefrac(j)) + + resi = resi - olp + resj = resj - olp + + IF (resj == 0.) THEN + IF (j == nl_lake) THEN + EXIT + ELSE + j = j + 1 + resj = dz_lake(j) + ENDIF + ENDIF + + ENDDO + + IF (wicesum > 0.) tice = ticesum / wicesum + IF (wliqsum > 0.) tliq = tliqsum / wliqsum + + IF ((wliqsum > 0.) .and. (wicesum > 0.)) THEN + + a = cpliq*wliqsum*(tliq-tfrz) + b = cpice*wicesum*(tfrz-tice) + c = wicesum*hfus + d = wliqsum*hfus + + IF (a >= b + c) THEN + wicesum = 0. + wliqsum = dz_lake_new(i) + t_lake_new(i) = tfrz + (a-b-c)/(wliqsum*cpliq) + ELSEIF (a >= b) THEN + wicesum = wicesum - (a-b)/hfus + t_lake_new(i) = tfrz + ELSEIF (a + d < b) THEN + wicesum = dz_lake_new(i) + t_lake_new(i) = tfrz - (b-a-d)/(wicesum*cpice) + ELSE ! (b-d <= a < b) + wicesum = wicesum + (b-a)/hfus + t_lake_new(i) = tfrz + ENDIF + + ELSEIF (wliqsum > 0.) THEN + t_lake_new(i) = tliq + ELSEIF (wicesum > 0.) THEN + t_lake_new(i) = tice + ENDIF + + lake_icefrac_new(i) = wicesum / dz_lake_new(i) + + ENDDO + + dz_lake = dz_lake_new + lake_icefrac = lake_icefrac_new + t_lake = t_lake_new + + END SUBROUTINE adjust_lake_layer + + +END MODULE MOD_Lake diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 new file mode 100644 index 0000000000..d0d067c122 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90 @@ -0,0 +1,2459 @@ +#include +MODULE MOD_LeafInterception +! ----------------------------------------------------------------- +! !DESCRIPTION: +! For calculating vegetation canopy precipitation interception. +! +! This module computes canopy interception and evaporation fluxes. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + !* :SUBROUTINE:"LEAF_interception_CoLM2014" : Leaf interception and drainage schemes based on colm2014 version + !* :SUBROUTINE:"LEAF_interception_CoLM202x" : Leaf interception and drainage schemes besed on new colm version (under development) + !* :SUBROUTINE:"LEAF_interception_CLM4" : Leaf interception and drainage schemes modified from CLM4 + !* :SUBROUTINE:"LEAF_interception_CLM5" : Leaf interception and drainage schemes modified from CLM5 + !* :SUBROUTINE:"LEAF_interception_NOAHMP" : Leaf interception and drainage schemes modified from Noah-MP + !* :SUBROUTINE:"LEAF_interception_MATSIRO" : Leaf interception and drainage schemes modified from MATSIRO 2021 version + !* :SUBROUTINE:"LEAF_interception_VIC" : Leaf interception and drainage schemes modified from VIC + !* :SUBROUTINE:"LEAF_interception_JULES" : Leaf interception and drainage schemes modified from JULES + !* :SUBROUTINE:"LEAF_interception_pftwrap" : wrapper for pft land use classification + +!REVISION HISTORY: +!---------------- + ! 2026.01 Zhongwang Wei: Fully revise CLM4,5,Noah-MP,MATSIRO,VIC and JULES schemes. + ! 2024.04 Hua Yuan: add option to account for vegetation snow process based on Niu et al., 2004 + ! 2023.07 Hua Yuan: remove wrapper PC by using PFT leaf interception + ! 2023.06 Shupeng Zhang @ SYSU + ! 2023.02.23 Zhongwang Wei @ SYSU + ! 2021.12.12 Zhongwang Wei @ SYSU + ! 2020.10.21 Zhongwang Wei @ SYSU + ! 2019.06 Hua Yuan: 1) add wrapper for PFT and PC, and 2) remove sigf by using lai+sai + ! 2014.04 Yongjiu Dai + ! 2002.08.31 Yongjiu Dai + USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop + USE MOD_Const_Physical, only: tfrz, denh2o, denice, cpliq, cpice, hfus + USE MOD_Namelist, only: DEF_Interception_scheme, DEF_VEG_SNOW + + IMPLICIT NONE + + real(r8), parameter :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + real(r8), parameter :: bp = 20. + real(r8), parameter :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + real(r8), parameter :: pcoefs(2,2) = reshape((/20.0_r8, 0.206e-8_r8, 0.0001_r8, 0.9999_r8/), (/2,2/)) + + ! Minimum significant precipitation rate threshold [mm/s] + ! Used across all schemes for numerical stability + real(r8), parameter :: PRECIP_THRESHOLD = 1.0e-8_r8 + + ! Tolerance for interception water balance checks [mm] + ! Used by check_interception_balance subroutine under CoLMDEBUG + real(r8), parameter :: INTERCEPTION_BALANCE_TOL = 1.0e-5_r8 + + !----------------------- Dummy argument -------------------------------- + real(r8) :: satcap ! maximum allowed water on canopy [mm] + real(r8) :: satcap_rain ! maximum allowed rain on canopy [mm] + real(r8) :: satcap_snow ! maximum allowed snow on canopy [mm] + real(r8) :: lsai ! sum of leaf area index and stem area index [-] + real(r8) :: chiv ! leaf angle distribution factor + real(r8) :: ppc ! convective precipitation in time-step [mm] + real(r8) :: ppl ! large-scale precipitation in time-step [mm] + real(r8) :: p0 ! precipitation in time-step [mm] + real(r8) :: fpi ! coefficient of interception + real(r8) :: fpi_rain ! coefficient of interception of rain + real(r8) :: fpi_snow ! coefficient of interception of snow + real(r8) :: alpha_rain ! coefficient of interception of rain + real(r8) :: alpha_snow ! coefficient of interception of snow + real(r8) :: pinf ! interception of precipitation in time step [mm] + real(r8) :: tti_rain ! direct rain throughfall in time step [mm] + real(r8) :: tti_snow ! direct snow throughfall in time step [mm] + real(r8) :: tex_rain ! canopy rain drainage in time step [mm] + real(r8) :: tex_snow ! canopy snow drainage in time step [mm] + real(r8) :: vegt ! sigf*lsai + real(r8) :: xs ! proportion of the grid area where the intercepted rainfall + ! plus the preexisting canopy water storage + real(r8) :: unl_snow_temp,U10,unl_snow_wind,unl_snow + real(r8) :: ap, cp, aa1, bb1, exrain, arg, w + real(r8) :: thru_rain, thru_snow + real(r8) :: xsc_rain, xsc_snow + + real(r8) :: fvegc ! vegetation fraction + real(r8) :: FT ! the temperature factor for snow unloading + real(r8) :: FV ! the wind factor for snow unloading + real(r8) :: ICEDRIP ! snow unloading + + real(r8) :: ldew_smelt + real(r8) :: ldew_frzc + real(r8) :: FP + real(r8) :: int_rain + real(r8) :: int_snow + +CONTAINS + + SUBROUTINE LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Calculation of interception and drainage of precipitation + ! the treatment are based on Sellers et al. (1996) + +!Original Author: +!------------------- + !canopy interception scheme modified by Yongjiu Dai based on Sellers et al. (1996) + +!References: +!------------------- + !---Dai, Y., Zeng, X., Dickinson, R.E., Baker, I., Bonan, G.B., BosiloVICh, + ! M.G., Denning, A.S., Dirmeyer, P.A., Houser, P.R., Niu, G. and Oleson, + ! K.W., 2003. The common land model. Bulletin of the American + ! Meteorological Society, 84(8), pp.1013-1024. + + !---Lawrence, D.M., Thornton, P.E., Oleson, K.W. and Bonan, G.B., 2007. The + ! partitioning of evapotranspiration into transpiration, soil evaporation, + ! and canopy evaporation in a GCM: Impacts on land-atmosphere interaction. + ! Journal of Hydrometeorology, 8(4), pp.862-880. + + !---Oleson, K., Dai, Y., Bonan, B., BosiloVIChm, M., Dickinson, R., + ! Dirmeyer, P., Hoffman, F., Houser, P., Levis, S., Niu, G.Y. and + ! Thornton, P., 2004. Technical description of the community land model + ! (CLM). + + !---Sellers, P.J., Randall, D.A., Collatz, G.J., Berry, J.A., Field, C.B., + ! Dazlich, D.A., Zhang, C., Collelo, G.D. and Bounoua, L., 1996. A revised + ! land surface parameterization (SiB2) for atmospheric GCMs. Part I: + ! Model formulation. Journal of climate, 9(4), pp.676-705. + + !---Sellers, P.J., Tucker, C.J., Collatz, G.J., Los, S.O., Justice, C.O., + ! Dazlich, D.A. and Randall, D.A., 1996. A revised land surface + ! parameterization (SiB2) for atmospheric GCMs. Part II: The generation of + ! global fields of terrestrial biophysical parameters from satellite data. + ! Journal of climate, 9(4), pp.706-737. + + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + !---2024.04.16 Hua Yuan: add option to account for vegetation snow process based on Niu et al., 2004 + !---2023.02.21 Zhongwang Wei @ SYSU : Snow and rain interception + !---2021.12.08 Zhongwang Wei @ SYSU + !---2019.06 Hua Yuan: remove sigf and USE lai+sai for judgement. + !---2014.04 Yongjiu Dai + !---2002.08.31 Yongjiu Dai +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler ! irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: bifall !bulk density of newly fallen dry snow [kg/m3] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(in) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + +!----------------------------------------------------------------------- + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + satcap = dewmx*vegt + satcap_rain = satcap + satcap_snow = 6.6*(0.27+46./bifall)*vegt ! Niu et al., 2004 + satcap_snow = 48.*satcap ! Simple one without snow density input + + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + ppc = (prc_rain + prc_snow)*deltim + ppl = (prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + + w = ldew+p0 + IF (tleaf > tfrz) THEN + xsc_rain = max(0., ldew-satcap) + xsc_snow = 0. + ELSE + xsc_rain = 0. + xsc_snow = max(0., ldew-satcap) + ENDIF + + ldew = ldew - (xsc_rain + xsc_snow) + + !TODO-done: account for vegetation snow + IF ( DEF_VEG_SNOW ) THEN + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) + ldew_rain = ldew_rain - xsc_rain + ldew_snow = ldew_snow - xsc_snow + ldew = ldew_rain + ldew_snow + ENDIF + + ap = pcoefs(2,1) + cp = pcoefs(2,2) + + IF (p0 > 1.e-8) THEN + ap = ppc/p0 * pcoefs(1,1) + ppl/p0 * pcoefs(2,1) + cp = ppc/p0 * pcoefs(1,2) + ppl/p0 * pcoefs(2,2) + + !---------------------------------------------------------------------- + ! proportional saturated area (xs) and leaf drainage(tex) + !----------------------------------------------------------------------- + chiv = chil + IF ( abs(chiv) .le. 0.01 ) chiv = 0.01 + aa1 = 0.5 - 0.633 * chiv - 0.33 * chiv * chiv + bb1 = 0.877 * ( 1. - 2. * aa1 ) + exrain = aa1 + bb1 + + ! coefficient of interception + ! set fraction of potential interception to max 0.25 (Lawrence et al. 2007) + ! assume alpha_rain = alpha_snow + alpha_rain = 0.25 + fpi = alpha_rain * ( 1.-exp(-exrain*lsai) ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi ) + + xs = 1. + IF (p0*fpi>1.e-9) THEN + arg = (satcap-ldew)/(p0*fpi*ap) - cp/ap + IF (arg>1.e-9) THEN + xs = -1./bp * log( arg ) + xs = min( xs, 1. ) + xs = max( xs, 0. ) + ENDIF + ENDIF + + ! assume no fall down of the intercepted snowfall in a time step + ! drainage + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & + - max(0., (satcap-ldew)) * xs + tex_rain = max( tex_rain, 0. ) + ! Ensure physical constraint: tex_rain + tti_rain <= total rain input + tex_rain = min( tex_rain, (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - tti_rain ) + tex_snow = 0. + + ! 04/11/2024, yuan: + !TODO-done: account for snow on vegetation, + IF ( DEF_VEG_SNOW ) THEN + + ! re-calculate leaf rain drainage using ldew_rain + + xs = 1. + IF (p0*fpi>1.e-9) THEN + arg = (satcap_rain-ldew_rain)/(p0*fpi*ap) - cp/ap + IF (arg>1.e-9) THEN + xs = -1./bp * log( arg ) + xs = min( xs, 1. ) + xs = max( xs, 0. ) + ENDIF + ENDIF + + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & + - max(0., (satcap_rain-ldew_rain)) * xs + tex_rain = max( tex_rain, 0. ) + ! Ensure physical constraint: tex_rain + tti_rain <= total rain input + tex_rain = min( tex_rain, (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - tti_rain ) + + ! re-calculate the snow loading rate + + fvegc = 1. - exp(-0.52*lsai) + FP = (ppc + ppl) / (10.*ppc + ppl) + qintr_snow = fvegc * (prc_snow+prl_snow) * FP + qintr_snow = min (qintr_snow, (satcap_snow-ldew_snow)/deltim * (1.-exp(-(prc_snow+prl_snow)*deltim/satcap_snow)) ) + qintr_snow = max (qintr_snow, 0.) + + ! snow unloading rate + + FT = max(0.0, (tleaf - tfrz) / 1.87e5) + FV = sqrt(forc_us*forc_us + forc_vs*forc_vs) / 1.56e5 + tex_snow = max(0., ldew_snow/deltim) * (FV+FT) + tti_snow = (1.0-fvegc)*(prc_snow+prl_snow) + (fvegc*(prc_snow+prl_snow) - qintr_snow) + + ! rate -> mass + + tti_snow = tti_snow * deltim + tex_snow = tex_snow * deltim + ENDIF + +#if (defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10 .and. .not.DEF_VEG_SNOW) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ',ldew,tex_rain,tex_snow,tti_rain,tti_snow,p0 + ENDIF +#endif + + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + ldew = ldew + pinf + + !TODO-done: IF DEF_VEG_SNOW, update ldew_rain, ldew_snow + IF ( DEF_VEG_SNOW ) THEN + ldew_rain = ldew_rain + (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - thru_rain + ldew_snow = ldew_snow + (prc_snow+prl_snow)*deltim - thru_snow + ldew = ldew_rain + ldew_snow + ENDIF + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim + +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code: ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim, satcap + CALL CoLM_stop() + ENDIF + + IF (DEF_VEG_SNOW .and. abs(ldew-ldew_rain-ldew_snow) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code when DEF_VEG_SNOW: ' + write(6,*) ldew, ldew_rain, ldew_snow + CALL CoLM_stop() + ENDIF +#endif + + ELSE + ! 07/15/2023, yuan: #bug found for ldew value reset. + !NOTE: this bug should exist in other interception schemes @Zhongwang. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + + ENDIF + + END SUBROUTINE LEAF_interception_CoLM2014 + + SUBROUTINE LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,& + qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Calculation of interception and drainage of precipitation (under development) + ! the scheme developed by Zhongwang wei @ SYSU (not finished yet) + +!Original Author: +!------------------- + !---Zhongwang Wei @ SYSU + +!References: +!------------------- + !---Zhong, F., Jiang, S., van Dijk, A.I., Ren, L., Schellekens, J. and Miralles, D.G., 2022. + ! Revisiting large-scale interception patterns constrained by a synthesis of global experimental + ! data. Hydrology and Earth System Sciences, 26(21), pp.5647-5667. + !--- + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + !---2023.04.30 Zhongwang Wei @ SYSU : Snow and rain interception +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler ! irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(in) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + satcap = dewmx*vegt + + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + ppc = (prc_rain+prc_snow)*deltim + ppl = (prl_rain+prl_snow+qflx_irrig_sprinkler)*deltim + + w = ldew+p0 + + IF (tleaf > tfrz) THEN + xsc_rain = max(0., ldew-satcap) + xsc_snow = 0. + ELSE + xsc_rain = 0. + xsc_snow = max(0., ldew-satcap) + ENDIF + ldew = ldew - (xsc_rain + xsc_snow) + + ap = pcoefs(2,1) + cp = pcoefs(2,2) + + IF (p0 > 1.e-8) THEN + ap = ppc/p0 * pcoefs(1,1) + ppl/p0 * pcoefs(2,1) + cp = ppc/p0 * pcoefs(1,2) + ppl/p0 * pcoefs(2,2) + !---------------------------------------------------------------------- + ! proportional saturated area (xs) and leaf drainage(tex) + !----------------------------------------------------------------------- + chiv = chil + IF ( abs(chiv) .le. 0.01 ) chiv = 0.01 + aa1 = 0.5 - 0.633 * chiv - 0.33 * chiv * chiv + bb1 = 0.877 * ( 1. - 2. * aa1 ) + exrain = aa1 + bb1 + + ! coefficient of interception + ! set fraction of potential interception to max 0.25 (Lawrence et al. 2007) + alpha_rain = 0.25 + fpi = alpha_rain * ( 1.-exp(-exrain*lsai) ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi ) + + xs = 1. + IF (p0*fpi>1.e-9) THEN + arg = (satcap-ldew)/(p0*fpi*ap) - cp/ap + IF (arg>1.e-9) THEN + xs = -1./bp * log( arg ) + xs = min( xs, 1. ) + xs = max( xs, 0. ) + ENDIF + ENDIF + + ! assume no fall down of the intercepted snowfall in a time step drainage + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi * (ap/bp*(1.-exp(-bp*xs))+cp*xs) & + - max(0., (satcap-ldew)) * xs + tex_rain = max( tex_rain, 0. ) + ! Ensure physical constraint: tex_rain + tti_rain <= total rain input + tex_rain = min( tex_rain, (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - tti_rain ) + tex_snow = 0. + +#if (defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ' + ENDIF +#endif + + ELSE + ! all intercepted by canopy leves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + ldew = ldew + pinf + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim + + +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim, satcap + CALL CoLM_stop() + ENDIF + + CALL check_interception_balance('CoLM202x', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! 07/15/2023, Hua Yuan: bug found for ldew value reset when vegetation disappears + ! Yuan's fix: Release canopy water based on temperature + ! Note: CoLM202x doesn't separate rain/snow storage, so temperature-based + ! release is appropriate (no phase conservation issue for unified storage) + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + END SUBROUTINE LEAF_interception_CoLM202x + + SUBROUTINE LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Canopy interception following CLM4.5 official implementation + ! - Interception efficiency: fpi = 0.25*(1-exp(-0.5*LSAI)) + ! - Drainage method: Simple bucket overflow (when storage exceeds capacity) + ! - Verified against CLM4.5 source code: CTSM-clm4_5_18_r272/src_clm40/biogeophys/Hydrology1Mod.F90 + ! + ! Key features: + ! - No pre-drainage step (unlike some earlier CoLM versions) + ! - No spatial heterogeneity consideration (uniform canopy capacity) + ! - Immediate overflow drainage when capacity is exceeded + +!Original Author: +!------------------- + !Lawrence, D.M. + +!References: +!------------------- + !---Lawrence, D.M., Thornton, P.E., Oleson, K.W. and Bonan, G.B., 2007. + ! The partitioning of evapotranspiration into transpiration, soil evaporation, + ! and canopy evaporation in a GCM: Impacts on land-atmosphere interaction. Journal of Hydrometeorology, 8(4), pp.862-880. + !---Oleson, K.W., Lawrence, D.M., Bonan, G.B., Drewniak, B., Huang, M., Koven, C.D., Levis, S., Li, F., Riley, W.J., Subin, Z.M. and Swenson, S.C., 2013. + ! Technical description of version 4.5 of the Community Land Model (CLM). NCAR Technical Note NCAR/TN-503+ STR. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2023.02.21 Zhongwang Wei @ SYSU : Snow and rain interception + ! 2021.12.08 Zhongwang Wei @ SYSU + ! 2014.04 Yongjiu Dai + ! 2002.08.31 Yongjiu Dai +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(in) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + satcap = dewmx*vegt + + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + ppc = (prc_rain+prc_snow)*deltim + ppl = (prl_rain+prl_snow+qflx_irrig_sprinkler)*deltim + + w = ldew+p0 + + IF (tleaf > tfrz) THEN + xsc_rain = max(0., ldew-satcap) + xsc_snow = 0. + ELSE + xsc_rain = 0. + xsc_snow = max(0., ldew-satcap) + ENDIF + + ldew = ldew - (xsc_rain + xsc_snow) + + IF (p0 > 1.e-8) THEN + exrain =0.5 + ! coefficient of interception + ! set fraction of potential interception to max 0.25 (Lawrence et al. 2007) + alpha_rain = 0.25 + fpi = alpha_rain * ( 1.-exp(-exrain*lsai) ) + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi ) + + ! assume no fall down of the intercepted snowfall in a time step + ! drainage + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi + ldew - satcap + tex_rain = max(tex_rain, 0. ) + ! Ensure physical constraint: tex_rain + tti_rain <= total rain input + tex_rain = min( tex_rain, (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - tti_rain ) + tex_snow = 0. + +#if (defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ' + ENDIF +#endif + + + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + ldew = ldew + pinf + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim + + +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim, satcap + CALL CoLM_stop() + ENDIF +#endif + + ELSE + ! 07/15/2023, yuan: #bug found for ldew value reset. + IF (ldew > 0.) THEN + IF (tleaf > tfrz) THEN + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + pg_snow = prc_snow + prl_snow + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ldew/deltim + ENDIF + ELSE + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + pg_snow = prc_snow + prl_snow + ENDIF + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + + END SUBROUTINE LEAF_interception_CLM4 + + SUBROUTINE LEAF_interception_CLM5 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,& + qintr,qintr_rain,qintr_snow) + +!DESCRIPTION +!=========== + ! Canopy interception following CLM5.0 official implementation + ! - Separate treatment for rain and snow interception + ! - Rain interception: fpi = tanh(LSAI) [or 0.25*(1-exp(-0.5*LSAI))] + ! - Snow interception: fpi = 1-exp(-0.5*LSAI) + ! - Liquid water capacity: 0.1*(LAI+SAI) mm + ! - Snow capacity: 6.0*(LAI+SAI) mm + ! - Simple bucket overflow drainage based on temperature + ! - Snow unloading due to wind and temperature + ! - Verified against CLM5 source: CanopyHydrologyMod.F90 + ! + ! Key features: + ! - No pre-drainage step (fixed from earlier version) + ! - Drainage based on storage, not interception (critical fix) + ! - Temperature-dependent rain/snow drainage + ! - Physics-based snow unloading + +!Original Author: +!------------------- + !Lawrence, D.M. + +!References: +!------------------- + !---Lawrence, D.M., Thornton, P.E., Oleson, K.W. and Bonan, G.B., 2007. + ! The partitioning of evapotranspiration into transpiration, soil evaporation, + ! and canopy evaporation in a GCM: Impacts on land-atmosphere interaction. Journal of Hydrometeorology, 8(4), pp.862-880. + !---Lawrence, D.M., Fisher, R.A., Koven, C.D., Oleson, K.W., Swenson, S.C., Bonan, G., Collier, N., Ghimire, B., + ! van Kampenhout, L., Kennedy, D. and Kluzek, E., 2019. The Community Land Model version 5: + ! Description of new features, benchmarking, and impact of forcing uncertainty. + ! Journal of Advances in Modeling Earth Systems, 11(12), pp.4245-4287. + !---Fan, Y., Meijide, A., Lawrence, D.M., Roupsard, O., Carlson, K.M., Chen, H.Y., + ! Röll, A., Niu, F. and Knohl, A., 2019. Reconciling canopy interception parameterization + ! and rainfall forcing frequency in the Community Land Model for simulating evapotranspiration + ! of rainforests and oil palm plantations in Indonesia. Journal of Advances in Modeling Earth Systems, 11(3), pp.732-751. + + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(in) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + real(r8) :: xsnorun, xliqrun,qflx_prec_intr_rain,qflx_prec_intr_snow + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + p0 = (prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler)*deltim + + ! Ensure ldew is consistent with components at entry + ! CLM5 operates on ldew_rain/ldew_snow and sets ldew = ldew_rain + ldew_snow at exit + ! At entry from initialization or restart, ldew may be inconsistent + ldew = ldew_rain + ldew_snow + + w = ldew+p0 ! For mass balance check + + ! Canopy capacity - CLM5 official values + ! Verified against CanopyHydrologyMod.F90 lines 320, 329-330 + satcap_rain = dewmx*vegt ! liquid water capacity = 0.1*(LAI+SAI) + satcap_snow = satcap_rain*60.0 ! snow capacity = 6.0*(LAI+SAI) + + IF(p0 > 1.e-8) THEN + ! Interception efficiency - CLM5 formulas + ! Rain: CLM5 line 323 (tanh option) or line 325 (exponential option) + ! Snow: CLM5 line 332 + ! Note: CoLM uses tanh for rain; CLM5 default is exponential (CLM4.5) + alpha_rain = 1.0 + alpha_snow = 1.0 + fpi_rain = alpha_rain * tanh(lsai) + fpi_snow = alpha_snow * ( 1.-exp(-0.5*lsai) ) + + ! Direct throughfall - CLM5 lines 334, 337, 341 + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fpi_rain ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fpi_snow ) + + ! Intercepted precipitation - CLM5 line 345 + qflx_prec_intr_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * fpi_rain + qflx_prec_intr_snow = (prc_snow+prl_snow)*deltim * fpi_snow + + ! Water storage of intercepted precipitation - CLM5 lines 347-348 + ! Add interception to storage BEFORE calculating drainage + ldew_rain = max(0., ldew_rain + qflx_prec_intr_rain) + ldew_snow = max(0., ldew_snow + qflx_prec_intr_snow) + + ! Initialize drainage + tex_rain = 0. + tex_snow = 0. + unl_snow = 0. + + ! Snow unloading due to wind and temperature - CLM5 lines ~420-450 + ! (in CLM5 this is in separate unloading section, but physics is same) + IF(ldew_snow > 1.e-8) THEN + U10 = sqrt(forc_us*forc_us+forc_vs*forc_vs) + unl_snow_temp = ldew_snow*(tleaf-tfrz)/(1.87*1.e5) + unl_snow_temp = max(unl_snow_temp,0.0) + unl_snow_wind = U10*ldew_snow/(1.56*1.e5) + unl_snow_wind = max(unl_snow_wind,0.0) + unl_snow = unl_snow_temp+unl_snow_wind + unl_snow = min(unl_snow,ldew_snow) + ldew_snow = ldew_snow - unl_snow + ENDIF + + ! Simple bucket overflow drainage - CLM5 lines 367-379 + ! Separate handling for rain and snow based on temperature + IF (tleaf > tfrz) THEN + ! Above freezing: liquid water drainage + xliqrun = max(0., (ldew_rain - satcap_rain)/deltim) + IF (xliqrun > 0.) THEN + tex_rain = xliqrun * deltim + ldew_rain = satcap_rain + ENDIF + ELSE + ! Below freezing: snow falling off canopy + xsnorun = max(0., (ldew_snow - satcap_snow)/deltim) + IF (xsnorun > 0.) THEN + tex_snow = xsnorun * deltim + ldew_snow = satcap_snow + ENDIF + ENDIF + + ELSE + ! No precipitation - no interception or drainage + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + unl_snow = 0. + ENDIF + + !---------------------------------------------------------------------- + ! Total water reaching ground and interception + !---------------------------------------------------------------------- + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + unl_snow + ldew = ldew_rain + ldew_snow + + pg_rain = thru_rain / deltim + pg_snow = thru_snow / deltim + qintr = (p0 - thru_rain - thru_snow) / deltim + qintr_rain = (prc_rain + prl_rain + qflx_irrig_sprinkler) - thru_rain / deltim + qintr_snow = (prc_snow + prl_snow) - thru_snow / deltim + +#if (defined CoLMDEBUG) + ! Mass balance check + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'Mass balance error in CLM5 interception:' + write(6,*) 'Error:', w, 'ldew:', ldew, 'outflow:', (pg_rain+pg_snow)*deltim + write(6,*) 'satcap_rain:', satcap_rain, 'satcap_snow:', satcap_snow + CALL CoLM_stop() + ENDIF + + CALL check_interception_balance('CLM5', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! 07/15/2023, Hua Yuan: bug found for ldew value reset when vegetation disappears + ! 2026-01-16 improvement: Maintain phase conservation for rain/snow separated schemes + ! Yuan's original fix released water based on temperature, which violates phase conservation + ! for schemes that separate rain and snow storage (ldew_rain vs ldew_snow) + ! + ! Yuan's original code (2023-07-15): + ! IF (ldew > 0.) THEN + ! IF (tleaf > tfrz) THEN + ! pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew/deltim + ! pg_snow = prc_snow + prl_snow + ! ELSE + ! pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ! pg_snow = prc_snow + prl_snow + ldew/deltim + ! ENDIF + ! ELSE + ! pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ! pg_snow = prc_snow + prl_snow + ! ENDIF + ! + ! Improved version: Release liquid and solid water separately to preserve phase states + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew_rain/deltim + pg_snow = prc_snow + prl_snow + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + + END SUBROUTINE LEAF_interception_CLM5 + + SUBROUTINE LEAF_interception_NOAHMP(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Interception and drainage of precipitation + ! the treatment are modified from Noah-MP 5.0 + +!Original Author: +!------------------- + !---Guo-Yue Niu + +!References: +!------------------- + !---Yang, M., Zuo, R., Li, X. and Wang, L., 2019. Improvement test for the canopy interception parameterization scheme + ! in the community land model. Sola, 15, pp.166-171. + !---Niu, G.Y., Yang, Z.L., Mitchell, K.E., Chen, F., Ek, M.B., Barlage, M., Kumar, A., + ! Manning, K., Niyogi, D., Rosero, E. and Tewari, M., 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). + !---He, C., Valayamkunnath, P., Barlage, M., Chen, F., Gochis, D., Cabell, R., Schneider, T., + ! Rasmussen, R., Niu, G.Y., Yang, Z.L. and Niyogi, D., 2023. Modernizing the open-source + ! community Noah-MP land surface model (version 5.0) with enhanced modularity, + ! interoperability, and applicability. EGUsphere, 2023, pp.1-31. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2026.02.11 Zhongwang Wei @ SYSU - Added input clamping, comment fixes + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of solid (frozen) on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + ! Local variables + real(r8) :: PrecipAreaFrac !fraction of gridcell receiving precipitation [-] + real(r8) :: BDFALL + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + ! Calculate vegetation fraction from LAI (alternative to input VegFrac) + fvegc=max(0.05,1.0-exp(-0.52*lsai)) + + ! Maximum canopy water - Noah-MP lines 82, 105 + ! Note: Official Noah-MP uses VegFrac as input variable + ! CoLM uses fvegc calculated from LAI, which is also physically reasonable + satcap_rain = fvegc * dewmx*vegt + BDFALL = 67.92+51.25*EXP(MIN(2.5,(tleaf-273.15))/2.59) + satcap_snow = fvegc * 6.6*(0.27+46./BDFALL) * lsai + satcap_snow = max(0.0,satcap_snow) + + ! Input clamping: prevent negative precipitation (numerical noise) + ! from causing mass balance failures + p0 = MAX(0.0_r8, prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler) * deltim + ppc = MAX(0.0_r8, prc_rain + prc_snow) * deltim + ppl = MAX(0.0_r8, p0 - ppc) + + ! Estimate PrecipAreaFrac based on precipitation type - Noah-MP line 47 + ! Convective precipitation typically covers ~10% of gridcell + ! Stratiform precipitation typically covers ~100% of gridcell + IF (p0 > 1.e-8) THEN + PrecipAreaFrac = (0.1*ppc + 1.0*ppl) / p0 + PrecipAreaFrac = max(0.1, min(1.0, PrecipAreaFrac)) ! constrain to [0.1, 1.0] + ELSE + PrecipAreaFrac = 1.0 + ENDIF + + ! Ensure ldew is consistent with components at entry + ! NoahMP modifies ldew in-place; if ldew != ldew_rain + ldew_snow + ! at entry (e.g., from initialization or restart), mass balance drifts + ldew = ldew_rain + ldew_snow + + w = ldew+p0 + + ! Initialize excess water variables + xsc_rain = 0.0 + xsc_snow = 0.0 + + !snow unloading - Noah-MP lines 113-120 + IF (ldew_snow>1.e-8) THEN + FT = MAX(0.0,(tair - 270.15) / 1.87E5) + FV = SQRT(forc_us*forc_us + forc_vs*forc_vs) / 1.56E5 + ICEDRIP = MAX(0.,ldew_snow) * (FV+FT) !MB: removed /DT + ICEDRIP = MIN(ICEDRIP,ldew_snow) + xsc_snow = xsc_snow+ICEDRIP + ldew_snow = ldew_snow - ICEDRIP + ENDIF + + ! phase change and excess ! + IF (tleaf > tfrz) THEN + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF + ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ELSE + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF + !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ENDIF + ! Resync ldew with components after phase change (CoLM2014 pattern) + ldew = ldew_rain + ldew_snow + + IF (p0 > 1.e-8) THEN + + ! Throughfall: direct precipitation through vegetation gaps - Noah-MP lines 91, 119 + tti_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim * ( 1.-fvegc ) + tti_snow = (prc_snow+prl_snow)*deltim * ( 1.-fvegc ) + + ! Interception and drip calculation - Noah-MP lines 86-90, 109-118 + ! Interception rate [mm/s] + int_rain = fvegc * (prc_rain+prl_rain+qflx_irrig_sprinkler) * PrecipAreaFrac ! max interception capability + int_rain = min(int_rain, (satcap_rain-ldew_rain)/deltim * & + (1.0-exp(-(prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim/satcap_rain))) + int_rain = max(0., int_rain) + + int_snow = fvegc * (prc_snow+prl_snow) * PrecipAreaFrac ! max interception capability + int_snow = min(int_snow, (satcap_snow-ldew_snow)/deltim * & + (1.0-exp(-(prc_snow+prl_snow)*deltim/satcap_snow))) + int_snow = max(0., int_snow) + + ! Drip: excess precipitation on vegetation that cannot be intercepted + tex_rain = (prc_rain+prl_rain+qflx_irrig_sprinkler)*fvegc*deltim - int_rain*deltim + tex_snow = (prc_snow+prl_snow)*fvegc*deltim - int_snow*deltim +#if (defined CoLMDEBUG) + IF (tex_rain+tex_snow+tti_rain+tti_snow-p0 > 1.e-10) THEN + write(6,*) 'tex_ + tti_ > p0 in interception code : ' + ENDIF +#endif + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !BDFALL = 67.92+51.25*EXP(MIN(2.5,(SFCTMP-TFRZ))/2.59) + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + + ! Update rain/snow components following CoLM2014 pattern (lines 322-324) + ldew_rain = ldew_rain + (prc_rain+prl_rain+qflx_irrig_sprinkler)*deltim - thru_rain + ldew_snow = ldew_snow + (prc_snow+prl_snow)*deltim - thru_snow + ldew = ldew_rain + ldew_snow + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim + +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap + CALL CoLM_stop() + ENDIF + + CALL check_interception_balance('NoahMP', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! 07/15/2023, Hua Yuan: bug found for ldew value reset when vegetation disappears + ! Release canopy water separately by phase to preserve phase conservation + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew_rain/deltim + pg_snow = prc_snow + prl_snow + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + + ENDIF + + END SUBROUTINE LEAF_interception_NOAHMP + + + SUBROUTINE LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,& + qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Interception and drainage of precipitation + ! the treatment are modified from MATSIRO 6 (under development) + +!Original Author: +!------------------- + !---MATSIRO6 document writing team∗ + +!References: +!------------------- + !---Tatebe, H., Ogura, T., Nitta, T., Komuro, Y., Ogochi, K., Takemura, T., Sudo, K., Sekiguchi, M., + ! Abe, M., Saito, F. and Chikira, M., 2019. Description and basic evaluation of simulated mean state, + ! internal variability, and climate sensitivity in MIROC6. Geoscientific Model Development, 12(7), pp.2727-2765. 116(D12). + !---Takata, K., Emori, S. and Watanabe, T., 2003. Development of the minimal advanced treatments of surface interaction and + ! runoff. Global and planetary Change, 38(1-2), pp.209-222. + !---Guo, Q., Kino, K., Li, S., Nitta, T., Takeshima, A., Suzuki, K.T., Yoshida, N. and Yoshimura, K., 2021. + ! Description of MATSIRO6. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2026.02.11 Zhongwang Wei @ SYSU - Added input clamping, comment fixes + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU +!======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of solid (frozen) on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + !local + real(r8) :: fint, Ac, dewmx_MATSIRO,ldew_rain_s, ldew_snow_s,ldew_rain_n, ldew_snow_n + real(r8) :: tex_rain_n,tex_rain_s,tex_snow_n,tex_snow_s,tti_rain_n,tti_rain_s,tti_snow_n,tti_snow_s + + !the canopy water capacity per leaf area index is set to 0.2mm + dewmx_MATSIRO = 0.2 + !the fraction of the convective precipitation area is assumed to be uniform (0.1) + Ac = 0.1 + + IF (lai+sai > 1e-6) THEN + lsai = lai + sai + vegt = lsai + ! Input clamping: prevent negative precipitation (numerical noise) + ! from causing mass balance failures + p0 = MAX(0.0_r8, prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler) * deltim + ppc = MAX(0.0_r8, prc_rain + prc_snow) * deltim + ppl = MAX(0.0_r8, p0 - ppc) + + satcap_rain = dewmx_MATSIRO*vegt + satcap_snow = dewmx_MATSIRO*vegt + + ! Ensure ldew is consistent with components at entry + ! MATSIRO modifies ldew in-place; inconsistency at entry propagates to output + ldew = ldew_rain + ldew_snow + + w = ldew+p0 + + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) + + ldew_rain = ldew_rain-xsc_rain + ldew_snow = ldew_snow-xsc_snow + ! phase change and excess ! + IF (tleaf > tfrz) THEN + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF + ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ELSE + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF + !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ENDIF + ! Resync ldew with components after phase change (CoLM2014 pattern) + ldew = ldew_rain + ldew_snow + + IF (p0 > 1.e-8) THEN + ! Interception efficiency - MATSIRO formulation + ! MATSIRO uses simple linear saturation following Takata et al. (2003) + ! Reference: Takata, K., Emori, S., and Watanabe, T. (2003). "Development of the + ! minimal advanced treatments of surface interaction and runoff", Global and + ! Planetary Change, 38, 209-222, doi:10.1016/S0921-8181(03)00030-4 + ! Verified against official MATSIRO source code (matsiro.f90): + ! fctint = min(grlai(ud), 1.d0) + ! When LAI+SAI ≤ 1: efficiency equals LAI+SAI + ! When LAI+SAI > 1: efficiency saturates at 100% + fpi_rain = min(1.0, lai+sai) + fpi_snow = min(1.0, lai+sai) + + !----------------------------------------------------------------------- + ! Storm area + !----------------------------------------------------------------------- + ldew_rain_s = ldew_rain + ((prl_rain+qflx_irrig_sprinkler) * fpi_rain + prc_rain * fpi_rain / Ac) * deltim + ldew_snow_s = ldew_snow + (prl_snow * fpi_snow + prc_snow * fpi_snow / Ac) * deltim + ! + tti_rain_s = (prl_rain+qflx_irrig_sprinkler + prc_rain/Ac) * (1.d0-fpi_rain) * deltim + tti_snow_s = (prl_snow + prc_snow/Ac) * (1.d0-fpi_snow) * deltim + + ! + ! Rutter exponential drainage formula (Rutter et al. 1975) + ! tex = overflow + k1 * exp(k2 * storage) + ! + ! Physical constants from Rutter et al. (1975): + ! - cwb_adrp1 = 1.14e-11 [m/s]: Base dripping coefficient + ! Represents minimum drainage rate when canopy is near saturation + ! - cwb_adrp2 = 3.7e3 [1/m]: Exponential saturation factor + ! Controls how rapidly drainage increases with storage + ! Higher values = more sensitive to storage amount + ! - min(50.0, ...): Overflow protection to prevent EXP(large_number) + ! Caps exponent at 50 to avoid numerical overflow + ! (exp(50) ≈ 5e21, near double precision limit) + ! + ! Unit conversion: 1.14e-11 [m/s] × 1000 [mm/m] = 1.14e-8 [mm/s] + ! + tex_rain_s = max(ldew_rain_s - satcap_rain, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(50.0d0, min(ldew_rain_s,satcap_rain)/1000.* 3.7d3)) + tex_rain_s = min(tex_rain_s, ldew_rain_s) + ldew_rain_s = ldew_rain_s - tex_rain_s + + ! Snow drainage using same Rutter formula (see rain drainage comments above) + tex_snow_s = max(ldew_snow_s - satcap_snow, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(50.0d0, min(ldew_snow_s,satcap_snow)/1000.0* 3.7d3)) + tex_snow_s = min(tex_snow_s, ldew_snow_s) + ldew_snow_s = ldew_snow_s - tex_snow_s + + !------------------------------------------------------------------------- + ! Non-storm area + !------------------------------------------------------------------------- + ldew_rain_n = ldew_rain + (prl_rain+qflx_irrig_sprinkler) * fpi_rain * deltim + ldew_snow_n = ldew_snow + prl_snow * fpi_snow * deltim + + ! + tti_rain_n = (prl_rain+qflx_irrig_sprinkler) * (1.d0-fpi_rain) * deltim + tti_snow_n = (prl_snow) * (1.d0-fpi_snow) * deltim + + ! Rutter drainage for non-storm area (same formula as storm area) + tex_rain_n = max(ldew_rain_n - satcap_rain, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(50.0d0, min(ldew_rain_n,satcap_rain)/1000.* 3.7d3)) + tex_rain_n = min(tex_rain_n, ldew_rain_n) + ldew_rain_n = ldew_rain_n - tex_rain_n + + ! Snow drainage for non-storm area (same Rutter formula) + tex_snow_n = max(ldew_snow_n - satcap_snow, 0.d0) + (1.14d-11)*1000.*deltim*exp(min(50.0d0, min(ldew_snow_n,satcap_snow)/1000.* 3.7d3)) + tex_snow_n = min(tex_snow_n, ldew_snow_n) + ldew_snow_n = ldew_snow_n - tex_snow_n + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + ! Average + !------------------------------------------------------------------------- + ldew_rain = ldew_rain_n + (ldew_rain_s - ldew_rain_n) * Ac + ldew_snow = ldew_snow_n + (ldew_snow_s - ldew_snow_n) * Ac + ldew_rain = max(0.0,ldew_rain) + ldew_snow = max(0.0,ldew_snow) + + tti_rain = tti_rain_n*(1-Ac)+tti_rain_s*Ac + tti_snow = tti_snow_n+(tti_snow_s-tti_snow_n) * Ac + tti_rain = max(0.0,tti_rain) + tti_snow = max(0.0,tti_snow) + + tex_rain = tex_rain_n+(tex_rain_s-tex_rain_n)*Ac + tex_snow = tex_snow_n+(tex_snow_s-tex_snow_n)*Ac + tex_rain = max(0.0,tex_rain) + tex_snow = max(0.0,tex_snow) + !------------------------------------------------------------------------- + +! NOTE: The check "tex+tti > p0" is not applicable to MATSIRO scheme. +! Rutter exponential drainage drains pre-existing canopy water (ldew), +! so tex+tti can legitimately exceed p0. The real mass balance check +! is performed below (w residual check with abort). + + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + !BDFALL = 67.92+51.25*EXP(MIN(2.5,(SFCTMP-TFRZ))/2.59) + + !---------------------------------------------------------------------- + ! total throughfall (thru) and store augmentation + !---------------------------------------------------------------------- + + thru_rain = tti_rain + tex_rain + thru_snow = tti_snow + tex_snow + pinf = p0 - (thru_rain + thru_snow) + + ! Resync ldew with components following CoLM2014 pattern (line 324) + ! In the precip case, ldew_rain/ldew_snow were updated via weighted average + ! In the no-precip case, they remain at post-phase-change values (tiny p0 < 1e-8 ignored) + ldew = ldew_rain + ldew_snow + + pg_rain = (xsc_rain + thru_rain) / deltim + pg_snow = (xsc_snow + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap + CALL CoLM_stop() + ENDIF + + CALL check_interception_balance('MATSIRO', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! No vegetation: all precipitation passes through, release any stored water + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew_rain/deltim + pg_snow = prc_snow + prl_snow + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + END SUBROUTINE LEAF_interception_MATSIRO + + SUBROUTINE LEAF_interception_VIC (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) +!DESCRIPTION +!=========== + ! Calculation of interception and drainage of precipitation + ! the treatment are based on VIC 5.0 (under development) + +!Original Author: +!------------------- + !---Hamman, J.J. AND Liang X. + +!References: +!------------------- + !---Hamman, J.J., Nijssen, B., Bohn, T.J., Gergel, D.R. and Mao, Y., 2018. + ! The Variable Infiltration Capacity model version 5 (VIC-5): Infrastructure + ! improvements for new applications and reproducibility. Geoscientific Model Development, + ! 11(8), pp.3481-3496. + !---Liang, X., Lettenmaier, D.P., Wood, E.F. and Burges, S.J., 1994. + ! A simple hydrologically based model of land surface water and energy fluxes + ! for general circulation models. Journal of Geophysical Research: Atmospheres, 99(D7), + ! pp.14415-14428. + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!REVISION HISTORY +!---------------- + ! 2026.02.11 Zhongwang Wei @ SYSU - Added input clamping, comment fixes + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU +!======================================================================= + + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of solid (frozen) on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + real(r8) :: Imax1,Lr,Snow,Rain,DeltaSnowInt,Wind,BlownSnow,sigf_safe + real(r8) :: MaxInt,Overload,IntRainFract,IntSnowFract,ldew_smelt,MaxWaterInt + + IF (lai+sai > 1e-6 .and. sigf > 1.e-6) THEN + lsai = lai + sai + vegt = lsai + + ! Ensure ldew is consistent with components at entry (grid-scale) + ! VIC sets ldew = ldew_rain + ldew_snow at exit; inconsistency at entry + ! from initialization or restart causes mass balance check to fail + ldew = ldew_rain + ldew_snow + + ! VIC vegetation fraction handling (snow_intercept.c line 132-133) + ! Convert grid-scale storage to per-vegetation values + ! Physical meaning: Storage variables represent water on vegetated fraction only + IF (sigf > 1.e-6) THEN + sigf_safe = max(sigf, 0.01) + ldew_rain = ldew_rain / sigf_safe + ldew_snow = ldew_snow / sigf_safe + ENDIF + + !the maximum bearing capacity of the tree regardless of air temp (Imax1) + Imax1=4.0*lsai*0.0005 *1000.0 ! in mm + MaxInt=0.1*lsai + IF (tair>-272.15) THEN + Lr=4.0 + ELSEIF (tair<=-272.15 .and. tair>=-270.15) THEN + Lr=1.5*(tair-273.15)+5.5 + ELSE + Lr=1.0 + ENDIF + + satcap_snow=0.0005 *Lr *lsai * 1000.0 ! in mm !!! + !/* Calculate total liquid water capacity on branches and in intercepted snow */ + ! VIC physical design: Total liquid water capacity includes two components: + ! 1. Liquid water held in snow matrix (mature/ripe snow at 0°C) + ! 2. Liquid water on leaf surfaces + ! + ! Physical basis: Intercepted snow is a porous medium that can retain liquid water + ! in its interstitial spaces when it reaches 0°C (mature/ripe snow state). + ! This is a fundamental concept in snow hydrology (Colbeck 1972, Jordan 1991). + ! + ! Formula: satcap_rain = SNOW_LIQUID_WATER_CAPACITY * ldew_snow + MaxInt + ! - Term 1 (0.035*ldew_snow): Irreducible liquid water content in snow matrix + ! The 0.035 coefficient represents typical irreducible water saturation (~3.5% by mass) + ! This same parameter is used for ground snowpack in VIC (snow_melt.c, ice_melt.c) + ! - Term 2 (MaxInt=0.1*lsai): Liquid water on leaf/branch surfaces + ! + ! Physical meaning: When intercepted snow becomes ripe (0°C), it can simultaneously hold: + ! - Solid ice framework (ldew_snow) + ! - Liquid water in pore spaces (up to 3.5% of snow mass) + ! - Additional liquid water on vegetation surfaces (MaxInt) + ! When snow completely melts (ldew_snow=0), capacity reverts to leaf-only (MaxInt) + ! + ! Reference: Andreadis et al. (2009) "Modeling snow accumulation and ablation + ! processes in forested environments", WRR, doi:10.1029/2008WR007042 + ! + ! Rain capacity = snow matrix water retention + leaf surface capacity + ! When snow melts completely (ldew_snow→0), capacity reverts to just MaxInt + satcap_rain = 0.035 * ldew_snow + MaxInt ! in mm + + ! Input clamping: prevent negative precipitation (numerical noise) + ! from causing mass balance failures + p0 = MAX(0.0_r8, prc_rain + prc_snow + prl_rain + prl_snow + qflx_irrig_sprinkler) * deltim + ppc = MAX(0.0_r8, prc_rain + prc_snow) * deltim + ppl = MAX(0.0_r8, p0 - ppc) + w = ldew+p0 + + xsc_rain = max(0., ldew_rain-satcap_rain) + xsc_snow = max(0., ldew_snow-satcap_snow) + + ldew_rain = ldew_rain-xsc_rain + ldew_snow = ldew_snow-xsc_snow + ! phase change and excess ! + IF (tleaf > tfrz) THEN + IF (ldew_snow>1.e-8) THEN + ldew_smelt = MIN(ldew_snow,(tleaf-tfrz)*CICE*ldew_snow/DENICE/(HFUS)) + ldew_smelt = MAX(ldew_smelt,0.0) + ldew_snow = ldew_snow-ldew_smelt + ldew_rain = ldew_rain+ldew_smelt + xsc_rain = xsc_rain + MAX(0., ldew_rain-satcap_rain) + ldew_rain = ldew_rain - MAX(0., ldew_rain-satcap_rain) + ENDIF + ! tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ELSE + IF (ldew_rain>1.e-8) THEN + ldew_frzc = MIN(ldew_rain,(tfrz-tleaf)*CWAT*ldew_rain/DENH2O/(HFUS)) + ldew_frzc = MAX(ldew_frzc,0.0) + ldew_snow = ldew_snow+ldew_frzc + ldew_rain = ldew_rain-ldew_frzc + xsc_snow = xsc_snow + MAX(0., ldew_snow-satcap_snow) + ldew_snow = ldew_snow - MAX(0., ldew_snow-satcap_snow) + ENDIF + !tleaf = fvegc*tfrz+ (1.0-fwet)*tleaf + ENDIF + + ! Note: ldew will be resynced as ldew = ldew_rain + ldew_snow at output (line ~1806) + ! No in-place ldew update needed here (CoLM2014 pattern: resync at end) + + IF (p0 > 1.e-8) THEN + ! VIC physical interception algorithm (snow_intercept.c lines 165-176, 224-236) + ! Snow: Dynamic capacity-based model + ! Rain: Empirical efficiency (CLM5 formulation retained for liquid phase) + + ! Snow interception: VIC physical algorithm + ! Interception efficiency decreases as canopy snow load approaches capacity + ! This prevents unphysical continuous interception when branches are saturated + Snow = (prc_snow+prl_snow)*deltim + IF (satcap_snow > 1.e-6 .and. Snow > 1.e-8) THEN + ! DeltaSnowInt = (1 - IntSnow/MaxSnowInt) * SnowFall + ! Physical meaning: Interception efficiency = available capacity / max capacity + DeltaSnowInt = (1.0 - ldew_snow/satcap_snow) * Snow + + ! Ensure intercepted amount doesn't exceed available capacity + IF (DeltaSnowInt + ldew_snow > satcap_snow) THEN + DeltaSnowInt = satcap_snow - ldew_snow + ENDIF + + ! Ensure non-negative + IF (DeltaSnowInt < 0.0) THEN + DeltaSnowInt = 0.0 + ENDIF + ELSE + DeltaSnowInt = 0.0 + ENDIF + + ! VIC throughfall calculation (snow_intercept.c line 204) + ! Throughfall = vegetation area unintercepted + bare area all + ! Physical meaning: + ! - In vegetated fraction (sigf): only non-intercepted part passes through + ! - In bare fraction (1-sigf): all precipitation passes through + ! + ! Use sigf_safe consistently with the storage scaling above. Mixing sigf_safe + ! for state variables with raw sigf for throughfall creates small residuals + ! in the debug mass-balance check when sigf is very small. + tti_snow = (Snow - DeltaSnowInt) * sigf_safe + Snow * (1.0 - sigf_safe) + ldew_snow = ldew_snow + DeltaSnowInt + + ! Rain interception: Original VIC capacity-based algorithm + ! Physical mechanism: Rain is intercepted based on available canopy storage capacity, + ! not a fixed efficiency function. When capacity is available, rain is intercepted; + ! when saturated, excess drains as throughfall. + ! Reference: Andreadis et al. (2009) WRR, VIC snow_intercept.c lines 218-236 + ! This differs from CLM5's empirical efficiency approach (tanh function) + Rain = (prc_rain+prl_rain+ qflx_irrig_sprinkler)*deltim + MaxWaterInt = satcap_rain ! Capacity already computed at line 1538 + + ! Capacity-based interception (VIC original algorithm) + ! If there is available capacity, intercept rain; otherwise it becomes throughfall + IF (ldew_rain + Rain <= MaxWaterInt) THEN + ! All rain can be intercepted (capacity not exceeded) + ldew_rain = ldew_rain + Rain + ! Throughfall: only bare area contribution + tti_rain = Rain * (1.0 - sigf_safe) + ELSE + ! Capacity exceeded: excess becomes throughfall + ! Throughfall = vegetated area excess + bare area all + tti_rain = (ldew_rain + Rain - MaxWaterInt) * sigf_safe + Rain * (1.0 - sigf_safe) + ! Storage saturated at maximum capacity + ldew_rain = MaxWaterInt + ENDIF + + tex_rain = max(0.0,ldew_rain-satcap_rain) + tex_snow = max(0.0,ldew_snow-satcap_snow) + + ldew_rain = ldew_rain - tex_rain + ldew_snow = ldew_snow - tex_snow + + !unload of snow + !* Reduce the amount of intercepted snow if windy and cold. + !Ringyo Shikenjo Tokyo, #54, 1952. + !Bulletin of the Govt. Forest Exp. Station, + !Govt. Forest Exp. Station, Meguro, Tokyo, Japan. + !FORSTX 634.9072 R475r #54. + !Page 146, Figure 10. + + !Reduce the amount of intercepted snow if snowing, windy, and + !cold (< -3 to -5 C). + !Schmidt and Troendle 1992 western snow conference paper. */ + !Note: Use tair (air temperature) instead of tleaf to match + !the original observations by Storck et al. (2002) + Wind= SQRT(forc_us*forc_us + forc_vs*forc_vs) + IF (tair-273.15<-3.0 .and. Wind> 1.0) THEN + BlownSnow=(0.2*Wind -0.2)* ldew_snow + BlownSnow = min(ldew_snow,BlownSnow) + tex_snow = tex_snow + BlownSnow + ldew_snow = ldew_snow - BlownSnow + ENDIF + !/* at this point we have calculated the amount of snowfall intercepted and + !/* the amount of rainfall intercepted. These values have been + !/* appropriately subtracted from SnowFall and RainFall to determine + !/* SnowThroughfall and RainThroughfall. However, we can end up with the + !/* condition that the total intercepted rain plus intercepted snow is + !/* greater than the maximum bearing capacity of the tree regardless of air + !/* temp (Imax1). The following routine will adjust ldew_rain and ldew_snow + !/* by triggering mass release due to overloading. Of course since ldew_rain + !/* and ldew_snow are mixed, we need to slough them of as fixed fractions */ + IF (ldew_rain + ldew_snow > Imax1) THEN + ! /*THEN trigger structural unloading*/ + Overload = (ldew_snow + ldew_rain) - Imax1 + ! Prevent division by zero in extreme low LAI conditions + IF (ldew_rain + ldew_snow > 1.e-10) THEN + IntRainFract = ldew_rain / (ldew_rain + ldew_snow) + IntSnowFract = 1.0 - IntRainFract + ELSE + ! Default to equal partition when total is negligible + IntRainFract = 0.5 + IntSnowFract = 0.5 + ENDIF + ldew_rain = ldew_rain - Overload * IntRainFract + ldew_snow = ldew_snow - Overload * IntSnowFract + tex_rain = tex_rain + Overload*IntRainFract + tex_snow = tex_snow + Overload*IntSnowFract + ENDIF + +! NOTE: The check "tex+tti > p0" is not applicable to VIC scheme. +! VIC's tex includes drainage of pre-existing canopy water (ldew) from +! capacity overflow, wind unloading, and structural overloading. +! Additionally, tti includes bare-fraction precipitation. +! The real mass balance check is performed below (w residual check with abort). + + ELSE + ! all intercepted by canopy leaves for very small precipitation + tti_rain = 0. + tti_snow = 0. + tex_rain = 0. + tex_snow = 0. + ENDIF + + + ! tex_rain/tex_snow are per-vegetation quantities, must scale by sigf_safe + ! to convert to grid-scale before adding to grid-scale tti_rain/tti_snow + thru_rain = tti_rain + tex_rain * sigf_safe + thru_snow = tti_snow + tex_snow * sigf_safe + + ! VIC safety check: When snow completely melts, liquid water capacity + ! reverts from (0.035*ldew_snow + MaxInt) to just (MaxInt) + ! Must drain excess water that can no longer be held + ! Reference: VIC snow_intercept.c lines 522-526 + IF (ldew_snow < 1.e-6 .and. ldew_rain > MaxInt) THEN + thru_rain = thru_rain + (ldew_rain - MaxInt) * sigf_safe + ldew_rain = MaxInt + ENDIF + + ! VIC vegetation fraction handling (snow_intercept.c line 515-520) + ! Convert per-vegetation storage back to grid-scale values + ! Use sigf_safe consistently with the division at entry (line 1534-1535) + IF (sigf > 1.e-6) THEN + ldew_rain = ldew_rain * sigf_safe + ldew_snow = ldew_snow * sigf_safe + ENDIF + + ! Update total canopy water storage (grid-scale) + ldew = ldew_rain + ldew_snow + pinf = p0 - (thru_rain + thru_snow) + + ! xsc_rain/xsc_snow are per-vegetation, scale to grid-scale + pg_rain = (xsc_rain * sigf_safe + thru_rain) / deltim + pg_snow = (xsc_snow * sigf_safe + thru_snow) / deltim + qintr = pinf / deltim + + qintr_rain = prc_rain + prl_rain + qflx_irrig_sprinkler - thru_rain / deltim + qintr_snow = prc_snow + prl_snow - thru_snow / deltim +#if (defined CoLMDEBUG) + w = w - ldew - (pg_rain+pg_snow)*deltim + IF (abs(w) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'something wrong in interception code : ' + write(6,*) w, ldew, (pg_rain+pg_snow)*deltim !, satcap + CALL CoLM_stop() + ENDIF + + CALL check_interception_balance('VIC', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + + ELSE + ! No vegetation: all precipitation passes through, release any stored water + pg_rain = prc_rain + prl_rain + qflx_irrig_sprinkler + ldew_rain/deltim + pg_snow = prc_snow + prl_snow + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + END SUBROUTINE LEAF_interception_VIC + + SUBROUTINE LEAF_interception_JULES(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) + !DESCRIPTION + !=========== + ! Official JULES canopy interception scheme + ! Rain: Rutter (1971) penetration model (sieve_jls_mod.F90) + ! Snow: Exponential saturation model with unloading (canopysnow_mod.F90) + ! + ! 2026-02 Fixes: + ! - Added vegetation fraction (sigf) scaling: interception occurs on vegetated area only. + ! - Added non-negative clamping for precipitation inputs to ensure mass balance. + ! - Fixed mass balance check: ldew resync before sigf division (VIC pattern). + + !Original Author: + !------------------- + !---Rutter et al. (1971, 1975) - Rain interception model + !---JULES team (Best et al. 2011) - Snow interception model + !---Zhongwang Wei @ SYSU - CoLM implementation + + !References: + !------------------- + !---Rutter et al. (1971): A predictive model of rainfall interception in forests, 1. + ! Derivation of the model from observations in a plantation of Corsican pine. + ! Agricultural Meteorology, 9, 367-384. + !---Rutter et al. (1975): A predictive model of rainfall interception in forests, 2. + ! Generalization of the model and comparison with observations in some coniferous + ! and hardwood stands. Journal of Applied Ecology, 12, 367-380. + !---Best et al. (2011): The Joint UK Land Environment Simulator (JULES), model description - + ! Part 1: Energy and water fluxes. Geosci. Model Dev. 4:677-699. + !---Clark et al. (2011): The Joint UK Land Environment Simulator (JULES), model description - + ! Part 2: Carbon fluxes and vegetation dynamics. Geosci. Model Dev. 4:701-722. + + !ANCILLARY FUNCTIONS AND SUBROUTINES + !------------------- + + !REVISION HISTORY + !---------------- + ! 2026.02.11 Zhongwang Wei @ SYSU - Added wind-dependent snow unloading (JULES fidelity D3) + ! 2026.02.11 Zhongwang Wei @ SYSU - Added sigf scaling, input clamping, mass balance fix + ! 2026.01.16 Zhongwang Wei @ SYSU - Converted to official JULES Rutter model + ! 2023.02.21 Zhongwang Wei @ SYSU + ! 2021.12.08 Zhongwang Wei @ SYSU + !======================================================================= + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] (unused in JULES; retained for interface compatibility) + real(r8), intent(in) :: forc_us !wind speed [m/s] + real(r8), intent(in) :: forc_vs !wind speed [m/s] + real(r8), intent(in) :: chil !leaf angle distribution factor (unused in JULES) + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water flux [mm/s] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] (read-only in JULES) + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of solid on foliage [mm] + real(r8), intent(in) :: z0m !roughness length (unused in JULES) + real(r8), intent(in) :: hu !forcing height of U (unused in JULES) + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) [NOTE: can be negative during canopy release] + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) [NOTE: can be negative during canopy release] + + ! Local variables + real(r8) :: snowinterceptfact ! Snow interception efficiency (0.7) + real(r8) :: snowunloadfact ! Snow unloading factor due to melt (0.4) + real(r8) :: unload_rate_cnst ! Constant background unloading rate [s⁻¹] + real(r8) :: unload_rate_u ! Wind-dependent unloading rate [s⁻¹/(m/s)] + real(r8) :: unload_backgrnd ! Total background unloading rate [s⁻¹] + real(r8) :: Wind ! Wind speed [m/s] + real(r8) :: area ! Precipitation area fraction + real(r8) :: can_cpy_rain ! Canopy capacity for rain [mm] + real(r8) :: can_cpy_snow ! Canopy capacity for snow [mm] + real(r8) :: r_rain ! Rain rate [mm/s] (clamped, non-negative) + real(r8) :: r_snow ! Snow rate [mm/s] (clamped, non-negative) + real(r8) :: can_ratio ! Canopy saturation ratio (can_wcnt/can_cpy) + real(r8) :: aexp ! Exponential term in Rutter model + real(r8) :: tfall_rain ! Rain throughfall [mm/s] + real(r8) :: tfall_snow ! Snow throughfall [mm/s] + real(r8) :: intercept_rain ! Rain interception in timestep [mm] + real(r8) :: intercept_snow ! Snow interception in timestep [mm] + real(r8) :: unload_snow ! Snow unloading in timestep [mm] + real(r8) :: melt_rate ! Canopy snow melt rate [mm/s] + real(r8) :: melt_factor ! Dimensionless melt energy ratio: CICE/(DENICE*HFUS) + real(r8) :: frz_factor ! Dimensionless freeze energy ratio: CWAT/(DENH2O*HFUS) + real(r8) :: smallp ! Small positive number + real(r8) :: lsai_l ! total LAI+SAI (local) + real(r8) :: p0_l, ppc_l, ppl_l ! precipitation sums (local) + real(r8) :: w_l ! mass balance check variable (local) + real(r8) :: ldew_frzc ! freezing water amount + real(r8) :: xsc_rain, xsc_snow ! excess water drained after phase change + real(r8) :: sigf_safe ! safe vegetation fraction (>= 0.01) + real(r8) :: thru_rain, thru_snow ! grid-scale throughfall [mm] + + IF (lai+sai > 1e-6 .AND. sigf > 1.e-6) THEN + lsai_l = lai + sai + + !====================================================================== + ! Input Clamping (Mass Balance Safety) + !====================================================================== + ! Negative precipitation inputs (numerical noise) cause mass balance failures. + ! Clamp all inputs to 0.0 before any calculations. + r_rain = MAX(0.0_r8, prc_rain + prl_rain + qflx_irrig_sprinkler) + r_snow = MAX(0.0_r8, prc_snow + prl_snow) + + ! Clamp canopy state: negative values from restart or upstream bugs + ! would be amplified by sigf division and cause mass balance abort + ldew_rain = MAX(0.0_r8, ldew_rain) + ldew_snow = MAX(0.0_r8, ldew_snow) + + !====================================================================== + ! JULES Parameters - Official values from JULES source code + !====================================================================== + snowinterceptfact = 0.7 ! Snow interception efficiency (jules_snow_mod.F90) + snowunloadfact = 0.4 ! Snow unloading factor (canopysnow_mod.F90) + unload_rate_cnst = 2.31e-6 ! Constant background unloading rate [s⁻¹] + unload_rate_u = 5.56e-7 ! Wind-dependent unloading rate [s⁻¹/(m/s)] + Wind = SQRT(forc_us**2 + forc_vs**2) + unload_backgrnd = unload_rate_cnst + unload_rate_u * Wind + can_cpy_snow = 4.4 * lsai_l ! Snow capacity [mm] (snowloadlai parameter) + can_cpy_rain = 0.1 * lsai_l ! Rain capacity [mm] (JULES PFT parameter) + smallp = EPSILON(1.0_r8) ! Machine epsilon for numerical stability + + !====================================================================== + ! Precipitation totals and mass balance reference (GRID-SCALE) + !====================================================================== + ! Use clamped rates for consistency + p0_l = (r_rain + r_snow) * deltim + ppc_l = MAX(0.0_r8, prc_rain + prc_snow) * deltim + ppl_l = p0_l - ppc_l + ! Clamp ppl_l to avoid negative from clamping differences + ppl_l = MAX(0.0_r8, ppl_l) + + IF (p0_l > 1.e-8) THEN + ! Convective precip ~10% of grid, stratiform ~100% of grid + area = (0.1*ppc_l + 1.0*ppl_l) / p0_l + area = max(0.1, min(1.0, area)) + ELSE + area = 1.0 + ENDIF + + ! Ensure ldew is consistent with components at entry (GRID-SCALE) + ! Must be done BEFORE sigf division to keep w_l in grid-scale units + ldew = ldew_rain + ldew_snow + + ! Mass balance reference: grid-scale storage + grid-scale precipitation + w_l = ldew + p0_l + + !====================================================================== + ! Vegetation Fraction Scaling (sigf) + !====================================================================== + ! JULES physics operates on the vegetated area only. + ! Convert grid-averaged storage to per-vegetation values. + ! (Matching VIC pattern: divide before physics, multiply after) + ! Note: outer guard guarantees sigf > 1e-6; floor at 0.01 prevents + ! extreme amplification when sigf is very small but positive. + sigf_safe = max(sigf, 0.01_r8) + ldew_rain = ldew_rain / sigf_safe + ldew_snow = ldew_snow / sigf_safe + + !====================================================================== + ! Phase change (melting/freezing) - Do BEFORE interception + !====================================================================== + ! Pre-compute dimensionless energy ratios to avoid large intermediate + ! products (e.g. CICE*ldew_snow ~1e8) that can trap under -ffpe-trap. + ! melt_factor = CICE / (DENICE * HFUS) ≈ 0.00684 [K⁻¹] + ! frz_factor = CWAT / (DENH2O * HFUS) ≈ 0.01256 [K⁻¹] + melt_factor = CICE / (DENICE * HFUS) + frz_factor = CWAT / (DENH2O * HFUS) + + IF (tleaf > tfrz) THEN + ! Canopy snow melting + IF (ldew_snow > 1.e-8) THEN + melt_rate = MIN(ldew_snow/deltim, & + (tleaf - tfrz) * melt_factor * ldew_snow / deltim) + melt_rate = MAX(melt_rate, 0.0_r8) + ldew_snow = ldew_snow - melt_rate * deltim + ldew_snow = MAX(ldew_snow, 0.0_r8) ! prevent -eps from FP rounding + ldew_rain = ldew_rain + melt_rate * deltim + ELSE + melt_rate = 0.0_r8 + ENDIF + ELSE + ! Canopy rain freezing + IF (ldew_rain > 1.e-8) THEN + ldew_frzc = MIN(ldew_rain, & + (tfrz - tleaf) * frz_factor * ldew_rain) + ldew_frzc = MAX(ldew_frzc, 0.0_r8) + ldew_snow = ldew_snow + ldew_frzc + ldew_rain = ldew_rain - ldew_frzc + ldew_rain = MAX(ldew_rain, 0.0_r8) ! prevent -eps from FP rounding + ENDIF + melt_rate = 0.0_r8 + ENDIF + + !====================================================================== + ! Drain excess water after phase change + ! When snow melts to rain, ldew_rain can greatly exceed can_cpy_rain + ! When rain freezes to snow, ldew_snow can exceed can_cpy_snow + !====================================================================== + xsc_rain = 0.0 + xsc_snow = 0.0 + IF (ldew_rain > can_cpy_rain) THEN + xsc_rain = ldew_rain - can_cpy_rain + ldew_rain = can_cpy_rain + ENDIF + IF (ldew_snow > can_cpy_snow) THEN + xsc_snow = ldew_snow - can_cpy_snow + ldew_snow = can_cpy_snow + ENDIF + + !====================================================================== + ! RAIN INTERCEPTION: Rutter (1971) Penetration Model + ! From JULES sieve_jls_mod.F90 lines 125-142 + !====================================================================== + IF (can_cpy_rain > 0.0 .AND. r_rain > smallp) THEN + ! Exponential term (JULES lines 126-132) + aexp = exp(max(-50.0_r8, -area * can_cpy_rain / (r_rain * deltim))) + + ! Canopy saturation ratio (JULES lines 134-136) + can_ratio = ldew_rain / can_cpy_rain + can_ratio = MAX(0.0, MIN(can_ratio, 1.0)) + + ! Rutter throughfall formula (JULES line 137) + tfall_rain = r_rain * ((1.0 - can_ratio) * aexp + can_ratio) + ELSE + tfall_rain = r_rain + ENDIF + + ! Update canopy water content (JULES line 142) + intercept_rain = (r_rain - tfall_rain) * deltim + ldew_rain = ldew_rain + intercept_rain + + ! Post-Rutter drainage: discrete timestep can overshoot capacity + IF (ldew_rain > can_cpy_rain) THEN + tfall_rain = tfall_rain + (ldew_rain - can_cpy_rain) / deltim + ldew_rain = can_cpy_rain + ENDIF + + !====================================================================== + ! SNOW INTERCEPTION: Exponential Saturation Model with Unloading + ! From JULES canopysnow_mod.F90 lines 131-145 + !====================================================================== + ! Snow unloading occurs regardless of snowfall (continuous process) + unload_snow = snowunloadfact * melt_rate * deltim & + + unload_backgrnd * ldew_snow * deltim + unload_snow = MAX(MIN(unload_snow, ldew_snow), 0.0) + ldew_snow = ldew_snow - unload_snow + + IF (r_snow > smallp) THEN + ! Snow interception (JULES lines 131-132) + intercept_snow = snowinterceptfact * (can_cpy_snow - ldew_snow) * & + (1.0 - EXP(MAX(-50.0_r8, -r_snow * deltim / can_cpy_snow))) + intercept_snow = MAX(0.0, intercept_snow) + + ! Update canopy snow + ldew_snow = ldew_snow + intercept_snow + + ! Snowfall to ground = snowfall - intercepted + unloaded + tfall_snow = r_snow - intercept_snow / deltim + unload_snow / deltim + + ! Post-interception drainage + IF (ldew_snow > can_cpy_snow) THEN + tfall_snow = tfall_snow + (ldew_snow - can_cpy_snow) / deltim + ldew_snow = can_cpy_snow + ENDIF + ELSE + intercept_snow = 0.0 + ! No snowfall, but unloaded snow still reaches ground + tfall_snow = r_snow + unload_snow / deltim + ENDIF + + !====================================================================== + ! Output fluxes: Per-vegetation → Grid-scale (VIC pattern) + !====================================================================== + ! tfall_rain/tfall_snow are per-vegetation throughfall rates [mm/s] + ! xsc_rain/xsc_snow are per-vegetation excess [mm] + ! Combine: vegetated area throughfall + bare ground direct precipitation + + ! Grid-scale throughfall [mm] (for mass balance check) + ! IMPORTANT: Use sigf_safe consistently (not sigf) to ensure exact mass balance + ! When sigf < 0.01, sigf_safe = 0.01 != sigf, mixing them creates a residual + thru_rain = (tfall_rain * deltim + xsc_rain) * sigf_safe + r_rain * deltim * (1.0 - sigf_safe) + thru_snow = (tfall_snow * deltim + xsc_snow) * sigf_safe + r_snow * deltim * (1.0 - sigf_safe) + + ! Convert throughfall to rate [mm/s] + pg_rain = thru_rain / deltim + pg_snow = thru_snow / deltim + + ! Rescale state variables back to grid-averaged + ldew_rain = ldew_rain * sigf_safe + ldew_snow = ldew_snow * sigf_safe + + ! Update total canopy water (grid-scale) + ldew = ldew_rain + ldew_snow + + ! Interception = total input - total output - storage change + ! Using the VIC approach: qintr = (p0 - thru) / deltim + qintr = (p0_l - thru_rain - thru_snow) / deltim + + ! Phase-separated interception rates + ! NOTE: These can be NEGATIVE when pre-existing canopy storage drains + ! (e.g., excess from phase change or prior timestep). Negative values + ! represent net canopy release, not a mass balance error. + ! Algebraic identity: qintr_rain + qintr_snow == qintr (exact). + qintr_rain = r_rain - pg_rain + qintr_snow = r_snow - pg_snow + +#if (defined CoLMDEBUG) + ! Mass balance check: w_l (grid-scale old storage + precip) should equal + ! new grid-scale storage + grid-scale ground flux + w_l = w_l - ldew - (pg_rain + pg_snow) * deltim + IF (abs(w_l) > 1.e-6) THEN + write(6,*) 'JULES interception mass balance error: ', w_l + write(6,*) 'ldew=', ldew, ' pg*dt=', (pg_rain+pg_snow)*deltim + CALL CoLM_stop() + ENDIF + + CALL check_interception_balance('JULES', & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) +#endif + ELSE + ! No vegetation: all precipitation passes through, release any stored water + ! Clamp raw precipitation to prevent negative pg (matching vegetated branch) + pg_rain = MAX(0.0_r8, prc_rain + prl_rain + qflx_irrig_sprinkler) + ldew_rain/deltim + pg_snow = MAX(0.0_r8, prc_snow + prl_snow) + ldew_snow/deltim + + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + qintr = 0. + qintr_rain = 0. + qintr_snow = 0. + ENDIF + END SUBROUTINE LEAF_interception_JULES + + SUBROUTINE LEAF_interception_wrap(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf, & + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall, & + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain, & + pg_snow,qintr,qintr_rain,qintr_snow ) +!DESCRIPTION +!=========== + !wrapper for calculation of canopy interception using USGS or IGBP land cover classification + +!ANCILLARY FUNCTIONS AND SUBROUTINES +!------------------- + +!Original Author: +!------------------- + !---Shupeng Zhang + +!References: + + +!REVISION HISTORY +!---------------- + + IMPLICIT NONE + + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: chil !leaf angle distribution factor + real(r8), intent(in) :: prc_rain !convective rainfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water [mm/s] + real(r8), intent(in) :: bifall !bulk density of newly fallen dry snow [kg/m3] + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: tair !air temperature [K] + real(r8), intent(inout) :: tleaf !sunlit canopy leaf temperature [K] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_rain !depth of liquid on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of liquid on foliage [mm] + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + + + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + IF (DEF_Interception_scheme==1) THEN + CALL LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ELSEIF (DEF_Interception_scheme==2) THEN + CALL LEAF_interception_CLM4 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ELSEIF (DEF_Interception_scheme==3) THEN + CALL LEAF_interception_CLM5(deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ELSEIF (DEF_Interception_scheme==4) THEN + CALL LEAF_interception_NoahMP (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ELSEIF (DEF_Interception_scheme==5) THEN + CALL LEAF_interception_matsiro (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + + ELSEIF (DEF_Interception_scheme==6) THEN + CALL LEAF_interception_vic (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + + ELSEIF (DEF_Interception_scheme==7) THEN + CALL LEAF_interception_JULES (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + + ELSEIF (DEF_Interception_scheme==8) THEN + CALL LEAF_interception_colm202x (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tair,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,& + pg_snow,qintr,qintr_rain,qintr_snow) + ENDIF + + END SUBROUTINE LEAF_interception_wrap + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE LEAF_interception_pftwrap (ipatch,deltim,dewmx,forc_us,forc_vs,forc_t,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,hu,pg_rain,pg_snow,qintr,qintr_rain,qintr_snow) + +! ----------------------------------------------------------------- +! !DESCRIPTION: +! wrapper for calculation of canopy interception for PFTs within a land cover type. +! +! Created by Hua Yuan, 06/2019 +! +! !REVISION HISTORY: +! 2023.02.21 Zhongwang Wei @ SYSU: add different options of canopy interception for PFTs +! +! ----------------------------------------------------------------- + + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Const_Physical, only: tfrz + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Vars_1DPFTFluxes + USE MOD_Const_PFT + IMPLICIT NONE + + integer, intent(in) :: ipatch !patch index + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: dewmx !maximum dew [mm] + real(r8), intent(in) :: forc_us !wind speed + real(r8), intent(in) :: forc_vs !wind speed + real(r8), intent(in) :: forc_t !air temperature + real(r8), intent(in) :: z0m !roughness length + real(r8), intent(in) :: hu !forcing height of U + real(r8), intent(inout) :: ldew_rain !depth of water on foliage [mm] + real(r8), intent(inout) :: ldew_snow !depth of water on foliage [mm] + real(r8), intent(in) :: prc_rain !convective ranfall [mm/s] + real(r8), intent(in) :: prc_snow !convective snowfall [mm/s] + real(r8), intent(in) :: prl_rain !large-scale rainfall [mm/s] + real(r8), intent(in) :: prl_snow !large-scale snowfall [mm/s] + real(r8), intent(in) :: qflx_irrig_sprinkler !irrigation and sprinkler water [mm/s] + real(r8), intent(in) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + + real(r8), intent(inout) :: ldew !depth of water on foliage [mm] + real(r8), intent(out) :: pg_rain !rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: pg_snow !snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qintr !interception [kg/(m2 s)] + real(r8), intent(out) :: qintr_rain !rainfall interception (mm h2o/s) + real(r8), intent(out) :: qintr_snow !snowfall interception (mm h2o/s) + + integer i, p, ps, pe +#ifdef CROP + integer :: irrig_flag ! 1 if sprinker, 2 if others +#endif + real(r8) pg_rain_tmp, pg_snow_tmp + + pg_rain_tmp = 0. + pg_snow_tmp = 0. + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + IF (DEF_Interception_scheme==1) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==2) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_clm4 (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==3) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_clm5 (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==4) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_NoahMP (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==5) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_MATSIRO (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==6) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_VIC (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==7) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_JULES (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ELSEIF (DEF_Interception_scheme==8) THEN + DO i = ps, pe + p = pftclass(i) + CALL LEAF_interception_CoLM202x (deltim,dewmx,forc_us,forc_vs,chil_p(p),sigf_p(i),lai_p(i),sai_p(i),forc_t,tleaf_p(i),& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,& + ldew_p(i),ldew_rain_p(i),ldew_snow_p(i),z0m_p(i),hu,pg_rain,pg_snow,qintr_p(i),qintr_rain_p(i),qintr_snow_p(i)) + pg_rain_tmp = pg_rain_tmp + pg_rain*pftfrac(i) + pg_snow_tmp = pg_snow_tmp + pg_snow*pftfrac(i) + ENDDO + ENDIF + + pg_rain = pg_rain_tmp + pg_snow = pg_snow_tmp + ldew = sum( ldew_p(ps:pe) * pftfrac(ps:pe)) + ldew_rain = sum( ldew_rain_p(ps:pe) * pftfrac(ps:pe)) + ldew_snow = sum( ldew_snow_p(ps:pe) * pftfrac(ps:pe)) + qintr = sum(qintr_p(ps:pe) * pftfrac(ps:pe)) + qintr_rain = sum(qintr_rain_p(ps:pe) * pftfrac(ps:pe)) + qintr_snow = sum(qintr_snow_p(ps:pe) * pftfrac(ps:pe)) + + END SUBROUTINE LEAF_interception_pftwrap +#endif + + SUBROUTINE check_interception_balance(scheme_name, & + ldew, ldew_rain, ldew_snow, pg_rain, pg_snow, & + qintr, qintr_rain, qintr_snow) + + ! Validates interception water balance consistency. + ! Called from CoLMDEBUG blocks after each scheme completes. + + character(len=*), intent(in) :: scheme_name + real(r8), intent(in) :: ldew, ldew_rain, ldew_snow + real(r8), intent(in) :: pg_rain, pg_snow + real(r8), intent(in) :: qintr, qintr_rain, qintr_snow + + ! Check A: component consistency (ldew == ldew_rain + ldew_snow) + IF (abs(ldew - (ldew_rain + ldew_snow)) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'Component consistency error in ', scheme_name, ':' + write(6,*) 'ldew=', ldew, ' ldew_rain+ldew_snow=', ldew_rain+ldew_snow + write(6,*) 'diff=', ldew - (ldew_rain + ldew_snow) + CALL CoLM_stop() + ENDIF + + ! Check B: non-negativity + IF (ldew < -INTERCEPTION_BALANCE_TOL .or. & + ldew_rain < -INTERCEPTION_BALANCE_TOL .or. & + ldew_snow < -INTERCEPTION_BALANCE_TOL .or. & + pg_rain < -INTERCEPTION_BALANCE_TOL .or. & + pg_snow < -INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'Negative value error in ', scheme_name, ':' + write(6,*) 'ldew=', ldew, ' ldew_rain=', ldew_rain, ' ldew_snow=', ldew_snow + write(6,*) 'pg_rain=', pg_rain, ' pg_snow=', pg_snow + CALL CoLM_stop() + ENDIF + + ! Check C: flux consistency (qintr == qintr_rain + qintr_snow) + IF (abs(qintr - (qintr_rain + qintr_snow)) > INTERCEPTION_BALANCE_TOL) THEN + write(6,*) 'Flux consistency error in ', scheme_name, ':' + write(6,*) 'qintr=', qintr, ' qintr_rain+qintr_snow=', qintr_rain+qintr_snow + write(6,*) 'diff=', qintr - (qintr_rain + qintr_snow) + CALL CoLM_stop() + ENDIF + + END SUBROUTINE check_interception_balance + +END MODULE MOD_LeafInterception diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 new file mode 100644 index 0000000000..35c3fa20bf --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperature.F90 @@ -0,0 +1,1568 @@ +#include + +MODULE MOD_LeafTemperature + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_RSS_SCHEME, DEF_Interception_scheme, DEF_SPLIT_SOILSNOW, & + DEF_VEG_SNOW + USE MOD_MPAS_MPI + + IMPLICIT NONE + + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LeafTemperature + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: dewfraction +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE LeafTemperature ( & + ipatch ,ivt ,deltim ,csoilc ,dewmx ,htvp ,& + lai ,sai ,htop ,hbot ,sqrtdi ,effcon ,& + vmax25 ,c3c4 ,slti ,hlti ,shti ,hhti ,trda ,& + trdm ,trop ,g1 ,g0 ,gradm ,binter ,& + extkn ,extkb ,extkd ,hu ,ht ,hq ,& + us ,vs ,thm ,th ,thv ,qm ,& + psrf ,rhoair ,parsun ,parsha ,sabv ,frl ,& + fsun ,thermk ,rstfacsun ,rstfacsha ,gssun ,gssha ,& + po2m ,pco2m ,z0h_g ,obug ,ustarg ,zlnd ,& + zsno ,fsno ,sigf ,etrc ,tg ,qg ,& + rss ,t_soil ,t_snow ,q_soil ,q_snow ,dqgdT ,& + emg ,tl ,ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + taux ,tauy ,fseng ,fseng_soil ,fseng_snow ,fevpg ,& + fevpg_soil ,fevpg_snow ,cgrnd ,cgrndl ,cgrnds ,tref ,& + qref ,rst ,assim ,respc ,fsenl ,fevpl ,& + etr ,dlrad ,ulrad ,z0m ,zol ,rib ,& + ustar ,qstar ,tstar ,fm ,fh ,fq ,& + rootfr ,& +!Plant Hydraulic variables + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,psi50_sha ,& + psi50_xyl ,psi50_root ,ck ,vegwp ,gs0sun ,gs0sha ,& + assimsun ,etrsun ,assimsha ,etrsha ,& +!Ozone stress variables + o3coefv_sun,o3coefv_sha,o3coefg_sun,o3coefg_sha,& + lai_old ,o3uptakesun,o3uptakesha,forc_ozone ,& +!End ozone stress variables +!WUE stomata model parameter + lambda ,& +!End WUE stomata model parameter + hpbl ,& + qintr_rain ,qintr_snow ,t_precip ,hprl ,dheatl ,smp ,& + hk ,hksati ,rootflux ) + +!======================================================================= +! !DESCRIPTION: +! Foliage energy conservation is given by foliage energy budget equation +! Rnet - Hf - LEf = 0 +! The equation is solved by Newton-Raphson iteration, in which this +! iteration includes the calculation of the photosynthesis and stomatal +! resistance, and the integration of turbulent flux profiles. The +! sensible and latent heat transfer between foliage and atmosphere and +! ground is linked by the equations: +! Ha = Hf + Hg and Ea = Ef + Eg +! +! Original author: Yongjiu Dai, August 15, 2001 +! +! !REVISIONS: +! +! 09/2014, Hua Yuan: imbalanced energy due to T/q adjustment is +! allocated to sensible heat flux. +! +! 10/2017, Hua Yuan: added options for z0, displa, rb and rd +! calculation (Dai, Y., Yuan, H., Xin, Q., Wang, D., +! Shangguan, W., Zhang, S., et al. (2019). Different +! representations of canopy structure—A large source of +! uncertainty in global land surface modeling. Agricultural +! and Forest Meteorology, 269-270, 119-135. +! https://doi.org/10.1016/j.agrformet.2019.02.006 +! +! 10/2019, Hua Yuan: change only the leaf temperature from two-leaf +! to one-leaf (due to large differences may exist between +! sunlit/shaded leaf temperature. +! +! 01/2021, Xingjie Lu and Nan Wei: added plant hydraulic process +! interface. +! +! 01/2021, Nan Wei: added interaction btw prec and canopy. +! +! 05/2023, Shaofeng Liu: add option to call moninobuk_leddy, the +! LargeEddy surface turbulence scheme (LZD2022); make a proper +! update of um. +! +! 04/2024, Hua Yuan: add option to account for vegetation snow process. +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: vonkar, grav, hvap, hsub, cpair, stefnc, cpliq, cpice, & + hfus, tfrz, denice, denh2o + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_TurbulenceLEddy + USE MOD_AssimStomataConductance + USE MOD_Vars_1DForcing, only: forc_height_mode + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_Const_LC, only: z0mr, displar + USE MOD_PlantHydraulic, only:PlantHydraulicStress_twoleaf, getvegwp_twoleaf + USE MOD_Ozone, only: CalcOzoneStress + USE MOD_Qsadv + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: ipatch,ivt + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + csoilc, &! drag coefficient for soil under canopy [-] + dewmx, &! maximum dew + htvp ! latent heat of evaporation (/sublimation) [J/kg] + +! vegetation parameters + real(r8), intent(inout) :: & + sai ! stem area index [-] + real(r8), intent(in) :: & + sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] + htop, &! PFT crown top height [m] + hbot, &! PFT crown bot height [m] + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + shti, &! slope of high temperature inhibition function (s1) + hhti, &! 1/2 point of high temperature inhibition function (s2) + slti, &! slope of low temperature inhibition function (s3) + hlti, &! 1/2 point of low temperature inhibition function (s4) + trda, &! temperature coefficient in gs-a model (s5) + trdm, &! temperature coefficient in gs-a model (s6) + trop, &! temperature coefficient in gs-a model (273+25) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept +!Ozone WUE stomata model parameter + lambda, &! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + extkn ! coefficient of leaf nitrogen allocation + integer , intent(in) :: & + c3c4 ! 1 for c3, 0 for c4 + real(r8), intent(in) :: & ! for plant hydraulic scheme + kmax_sun, &! Plant Hydraulics Parameters + kmax_sha, &! Plant Hydraulics Parameters + kmax_xyl, &! Plant Hydraulics Parameters + kmax_root, &! Plant Hydraulics Parameters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck ! shape-fitting parameter for vulnerability curve (-) + real(r8), intent(inout) :: & + vegwp(1:nvegwcs),&! vegetation water potential + gs0sun, &! maximum stomata conductance of sunlit leaf + gs0sha ! maximum stomata conductance of shaded leaf + +! input variables + real(r8), intent(in) :: & + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + qm, &! specific humidity at reference height [kg/kg] + psrf, &! pressure at reference height [pa] + rhoair, &! density air [kg/m**3] + + lai, &! adjusted leaf area index for seasonal variation [-] + parsun, &! par absorbed per unit lai [w/m**2] + parsha, &! par absorbed per unit lai [w/m**2] + sabv, &! solar radiation absorbed by vegetation [W/m2] + frl, &! atmospheric infrared (longwave) radiation [W/m2] + fsun, &! sunlit fraction of canopy + + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + thermk, &! canopy gap fraction for tir radiation + + po2m, &! atmospheric partial pressure o2 (pa) + pco2m, &! atmospheric partial pressure co2 (pa) + + z0h_g, &! bare soil roughness length, sensible heat [m] + obug, &! bare soil obu + ustarg, &! bare soil ustar + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno, &! fraction of snow cover on ground + + sigf, &! fraction of veg cover, excluding snow-covered veg [-] + etrc, &! maximum possible transpiration rate (mm/s) + tg, &! ground surface temperature [K] + t_soil, &! ground surface soil temperature [K] + t_snow, &! ground surface snow temperature [K] + qg, &! specific humidity at ground surface [kg/kg] + q_soil, &! specific humidity at ground soil surface [kg/kg] + q_snow, &! specific humidity at ground snow surface [kg/kg] + dqgdT, &! temperature derivative of "qg" + rss, &! soil surface resistance [s/m] + emg ! vegetation emissivity + + real(r8), intent(in) :: & + t_precip, &! snowfall/rainfall temperature [kelvin] + qintr_rain, &! rainfall interception (mm h2o/s) + qintr_snow, &! snowfall interception (mm h2o/s) + smp (1:nl_soil), &! soil matrix potential + rootfr (1:nl_soil), &! root fraction + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + hk (1:nl_soil) ! soil hydraulic conductance + real(r8), intent(in) :: & + hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(inout) :: & + tl, &! leaf temperature [K] + ldew, &! depth of water on foliage [mm] + ldew_rain, &! depth of rain on foliage [mm] + ldew_snow ! depth of snow on foliage [mm] + + real(r8), intent(out) :: & + fwet_snow ! vegetation snow fractional cover [-] + + real(r8), intent(inout) :: & +!Ozone stress variables + lai_old ,&! lai in last time step + o3uptakesun,&! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha,&! Ozone does, shaded leaf (mmol O3/m^2) + forc_ozone +!End ozone stress variables + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fseng, &! sensible heat flux from ground [W/m2] + fseng_soil, &! sensible heat flux from ground soil [W/m2] + fseng_snow, &! sensible heat flux from ground snow [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + fevpg_soil, &! evaporation heat flux from ground soil [mm/s] + fevpg_snow, &! evaporation heat flux from ground snow [mm/s] + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + tref, &! 2 m height air temperature (kelvin) + qref, &! 2 m height air specific humidity + rstfacsun, &! factor of soil water stress to transpiration on sunlit leaf + rstfacsha, &! factor of soil water stress to transpiration on shaded leaf + gssun, &! stomata conductance of sunlit leaf + gssha, &! stomata conductance of shaded leaf + rootflux(1:nl_soil) ! root water uptake from different layers + + real(r8), intent(inout) :: & + assimsun, &! sunlit leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsun, &! transpiration rate of sunlit leaf [mm/s] + assimsha, &! shaded leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsha ! transpiration rate of shaded leaf [mm/s] + + real(r8), intent(out) :: & + rst, &! stomatal resistance + assim, &! rate of assimilation + respc, &! rate of respiration + fsenl, &! sensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + dlrad, &! downward longwave radiation blow the canopy [W/m2] + ulrad, &! upward longwave radiation above the canopy [W/m2] + hprl, &! precipitation sensible heat from canopy + dheatl, &! vegetation heat change [W/m2] + + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + + real(r8), intent(inout) :: & +!Ozone stress variables + o3coefv_sun,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun,&! Ozone stress factor for stomata on shaded leaf + o3coefg_sha ! Ozone stress factor for stomata on shaded leaf +!End ozone stress variables + +!-------------------------- Local Variables ---------------------------- +! assign iteration parameters + integer, parameter :: itmax = 40 !maximum number of iteration + integer, parameter :: itmin = 6 !minimum number of iteration + real(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] + real(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] + + real(r8) dtl(0:itmax+1) !difference of tl between two iterative step + + real(r8) :: & + displa, &! displacement height [m] + hu_, &! adjusted observational height of wind [m] + ht_, &! adjusted observational height of temperature [m] + hq_, &! adjusted observational height of humidity [m] + zldis, &! reference height "minus" zero displacement height [m] + zii, &! convective boundary layer height [m] + z0mv, &! roughness length, momentum [m] + z0hv, &! roughness length, sensible heat [m] + z0qv, &! roughness length, latent heat [m] + zeta, &! dimensionless height used in Monin-Obukhov theory + beta, &! coefficient of convective velocity [-] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + dth, &! diff of virtual temp. between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + obu, &! monin-obukhov length (m) + um, &! wind speed including the stability effect [m/s] + ur, &! wind speed at reference height [m/s] + uaf, &! velocity of air within foliage [m/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + taf, &! air temperature within canopy space [K] + qaf, &! humidity of canopy air [kg/kg] + eah, &! canopy air vapor pressure (pa) + pco2g, &! co2 pressure (pa) at ground surface (pa) + pco2a, &! canopy air co2 pressure (pa) + + fdry, &! fraction of foliage that is green and dry [-] + fwet, &! fraction of foliage covered by water [-] + cf, &! heat transfer coefficient from leaves [-] + rb, &! leaf boundary layer resistance [s/m] + rbsun, &! Sunlit leaf boundary layer resistance [s/m] + rbsha, &! Shaded leaf boundary layer resistance [s/m] + rd, &! aerodynamical resistance between ground and canopy air + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + clai, &! canopy heat capacity [Jm-2K-1] + cah, &! heat conductance for air [m/s] + cgh, &! heat conductance for ground [m/s] + cfh, &! heat conductance for leaf [m/s] + caw, &! latent heat conductance for air [m/s] + cgw, &! latent heat conductance for ground [m/s] + cfw, &! latent heat conductance for leaf [m/s] + wtshi, &! sensible heat resistance for air, grd and leaf [-] + wtsqi, &! latent heat resistance for air, grd and leaf [-] + wta0, &! normalized heat conductance for air [-] + wtg0, &! normalized heat conductance for ground [-] + wtl0, &! normalized heat conductance for air and leaf [-] + wtaq0, &! normalized latent heat conductance for air [-] + wtgq0, &! normalized heat conductance for ground [-] + wtlq0, &! normalized latent heat cond. for air and leaf [-] + + ei, &! vapor pressure on leaf surface [pa] + deidT, &! derivative of "ei" on "tl" [pa/K] + qsatl, &! leaf specific humidity [kg/kg] + qsatldT, &! derivative of "qsatl" on "tlef" + + del, &! absolute change in leaf temp in current iteration [K] + del2, &! change in leaf temperature in previous iteration [K] + dele, &! change in heat fluxes from leaf [W/m2] + dele2, &! change in heat fluxes from leaf in previous iteration [W/m2] + det, &! maximum leaf temp. change in two consecutive iter [K] + dee, &! maximum leaf heat fluxes change in two consecutive iter [W/m2] + + obuold, &! monin-obukhov length from previous iteration + tlbef, &! leaf temperature from previous iteration [K] + ecidif, &! excess energies [W/m2] + err, &! balance error + + rssun, &! sunlit leaf stomatal resistance [s/m] + rssha, &! shaded leaf stomatal resistance [s/m] + fsha, &! shaded fraction of canopy + laisun, &! sunlit leaf area index, one-sided + laisha, &! shaded leaf area index, one-sided + respcsun, &! sunlit leaf respiration rate [umol co2 /m**2/ s] [+] + respcsha, &! shaded leaf respiration rate [umol co2 /m**2/ s] [+] + rsoil, &! soil respiration + gah2o, &! conductance between canopy and atmosphere + gdh2o, &! conductance between canopy and ground + tprcor ! tf*psur*100./1.013e5 + + integer it, nmozsgn + + real(r8) delta, fac + real(r8) evplwet, evplwet_dtl, etr_dtl, elwmax, elwdif, etr0, sumrootr + real(r8) irab, dirab_dtl, fsenl_dtl, fevpl_dtl + real(r8) w, csoilcn, z0mg, cintsun(3), cintsha(3) + real(r8) fevpl_bef, fevpl_noadj, dtl_noadj, htvpl, erre + real(r8) qevpl, qdewl, qsubl, qfrol, qmelt, qfrz + + real(r8) lt, egvf + + real(r8) :: sqrtdragc !sqrt(drag coefficient) + real(r8) :: fai !canopy frontal area index + real(r8) :: a_k71 !exponential extinction factor for u/k decline within canopy (Kondo 1971) + real(r8) :: fqt, fht, fmtop + real(r8) :: utop, ueff, ktop + real(r8) :: phih, z0qg, z0hg + real(r8) :: hsink, displasink + real(r8) gb_mol + real(r8),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance + real(r8),dimension(nl_soil) :: k_ax_root ! axial root conductance + + integer, parameter :: zd_opt = 3 ! z0 and d with vertical profile consideration + integer, parameter :: rb_opt = 3 ! rb with vertical profile consideration + integer, parameter :: rd_opt = 3 ! rd with vertical profile consideration + +!----------------------------------------------------------------------- + +! initialization of errors and iteration parameters + it = 1 !counter for leaf temperature iteration + del = 0.0 !change in leaf temperature from previous iteration + dele = 0.0 !latent head flux from leaf for previous iteration + + dtl(0) = 0. + fevpl_bef = 0. + + fht = 0. !integral of profile function for heat + fqt = 0. !integral of profile function for moisture + +!----------------------------------------------------------------------- +! scaling-up coefficients from leaf to canopy +!----------------------------------------------------------------------- + + fsha = 1. -fsun + laisun = lai*fsun + laisha = lai*fsha + +! scaling-up coefficients from leaf to canopy + cintsun(1) = (1.-exp(-(0.110+extkb)*lai))/(0.110+extkb) + cintsun(2) = (1.-exp(-(extkb+extkd)*lai))/(extkb+extkd) + cintsun(3) = (1.-exp(-extkb*lai))/extkb + + cintsha(1) = (1.-exp(-0.110*lai))/0.110 - cintsun(1) + cintsha(2) = (1.-exp(-extkd*lai))/extkd - cintsun(2) + cintsha(3) = lai - cintsun(3) + +!----------------------------------------------------------------------- +! get fraction of wet and dry canopy surface (fwet & fdry) +! initial saturated vapor pressure and humidity and their derivation +!----------------------------------------------------------------------- + + !clai = 4.2 * 1000. * 0.2 + clai = 0.0 + + ! 0.2mm*LSAI, account for leaf (plus dew) heat capacity + IF ( DEF_VEG_SNOW ) THEN + clai = 0.2*(lai+sai)*cpliq + ldew_rain*cpliq + ldew_snow*cpice + ENDIF + + CALL dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) + + CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) + +!----------------------------------------------------------------------- +! initial for fluxes profile +!----------------------------------------------------------------------- + + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) + z0mg = (1.-fsno)*zlnd + fsno*zsno + z0hg = z0mg + z0qg = z0mg + + z0m = htop * z0mr(patchclass(ipatch)) + displa = htop * displar(patchclass(ipatch)) + + z0mv = z0m; z0hv = z0m; z0qv = z0m + + ! Modify aerodynamic parameters for sparse/dense canopy (X. Zeng) + lt = min(lai+sai, 2.) + egvf = (1._r8 - exp(-lt)) / (1._r8 - exp(-2.)) + displa = egvf * displa + z0mv = exp(egvf * log(z0mv) + (1._r8 - egvf) * log(z0mg)) + + z0hv = z0mv + z0qv = z0mv + +! 10/17/2017, yuan: z0m and displa with vertical profile solution + IF (zd_opt == 3) THEN + + CALL cal_z0_displa(lai+sai, htop, 1., z0mv, displa) + + ! NOTE: adjusted for small displa + displasink = max(htop/2., displa) + hsink = z0mv + displasink + + z0hv = z0mv + z0qv = z0mv + + ENDIF + + fai = 1. - exp(-0.5*(lai+sai)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + + a_k71 = htop/(htop-displa)/(vonkar/sqrtdragc) + + taf = 0.5 * (tg + thm) + qaf = 0.5 * (qm + qg) + + pco2a = pco2m + tprcor = 44.6*273.16*psrf/1.013e5 + rsoil = 0. !respiration (mol m-2 s-1) +! rsoil = 1.22e-6*exp(308.56*(1./56.02-1./(tg-227.13))) +! rsoil = rstfac * 0.23 * 15. * 2.**((tg-273.16-10.)/10.) * 1.e-6 +! rsoil = 5.22 * 1.e-6 + rsoil = 0.22 * 1.e-6 + + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf + dqh = qm - qaf + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + + hu_ = hu; ht_ = ht; hq_ = hq; + + IF (forc_height_mode == 'absolute') THEN + + IF (hu <= htop+1) THEN + hu_ = htop + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of u less than htop+1, set it to htop+1.' + ENDIF + + IF (ht <= htop+1) THEN + ht_ = htop + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of t less than htop+1, set it to htop+1.' + ENDIF + + IF (hq <= htop+1) THEN + hq_ = htop + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of q less than htop+1, set it to htop+1.' + ENDIF + + ELSE ! relative height + hu_ = htop + hu + ht_ = htop + ht + hq_ = htop + hq + ENDIF + + zldis = hu_ - displa + + IF(zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL CoLM_stop() + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mv,um,obu) + +! ====================================================================== +! BEGIN stability iteration +! ====================================================================== + + DO WHILE (it .le. itmax) + + tlbef = tl + + del2 = del + dele2 = dele + + IF (tl > tfrz) THEN + htvpl = hvap + ELSE + htvpl = hsub + ENDIF + +!----------------------------------------------------------------------- +! Aerodynamical resistances +!----------------------------------------------------------------------- +! Evaluate stability-dependent variables using moz from prior iteration + IF (rd_opt == 3) THEN + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobukm_leddy(hu_,ht_,hq_,displa,z0mv,z0hv,z0qv,obu,um, & + displasink,z0mv,hpbl,ustar,fh2m,fq2m, & + htop,fmtop,fm,fh,fq,fht,fqt,phih) + ELSE + CALL moninobukm(hu_,ht_,hq_,displa,z0mv,z0hv,z0qv,obu,um, & + displasink,z0mv,ustar,fh2m,fq2m, & + htop,fmtop,fm,fh,fq,fht,fqt,phih) + ENDIF + ! Aerodynamic resistance + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobuk_leddy(hu_,ht_,hq_,displa,z0mv,z0hv,z0qv,obu,um,hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ELSE + CALL moninobuk(hu_,ht_,hq_,displa,z0mv,z0hv,z0qv,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + ENDIF + ! Aerodynamic resistance + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + ENDIF + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + +! Bulk boundary layer resistance of leaves + uaf = ustar + cf = 0.01*sqrtdi/sqrt(uaf) + rb = 1/(cf*uaf) + +! 11/17/2017, yuan: 3D rb calculation (with vertical profile consideration) +! 03/13/2020, yuan: added analytical solution + IF (rb_opt == 3) THEN + utop = ustar/vonkar * fmtop + ueff = ueffect(utop, htop, z0mg, z0mg, a_k71, 1._r8, 1._r8) + cf = 0.01*sqrtdi*sqrt(ueff) + rb = 1./cf + ENDIF + +! rd = 1./(csoilc*uaf) ! BATS legacy +! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : +! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over +! rd = 1./(csoilc*uaf) ! bare ground fraction + +! modified by Xubin Zeng's suggestion at 08-07-2002 + w = exp(-(lai+sai)) + csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) + rd = 1./(csoilcn*uaf) + +! 11/17/2017, yuan: 3D rd calculation with vertical profile solution +! 03/13/2020, yuan: added analytical solution + IF (rd_opt == 3) THEN + ktop = vonkar * (htop-displa) * ustar / phih + rd = frd(ktop, htop, z0qg, hsink, z0qg, displa/htop, & + z0qg, obug, ustar, z0mg, a_k71, 1._r8, 1._r8) + ENDIF + +!----------------------------------------------------------------------- +! stomatal resistances +!----------------------------------------------------------------------- + + IF(lai .gt. 0.001) THEN + + eah = qaf * psrf / ( 0.622 + 0.378 * qaf ) !pa + + ! If use PHS, calculate maximum stomata conductance (minimum stomata resistance) + ! by setting rstfac = 1. (no water stress). When use PHS, stomata only calculate + ! non-stress stomata conductance, assimilation rate and leaf respiration + IF (DEF_USE_PLANTHYDRAULICS) THEN + rstfacsun = 1. + rstfacsha = 1. + ENDIF + + ! leaf to canopy level + rbsun = rb / laisun + rbsha = rb / laisha + + ! Sunlit leaves + CALL stomata (vmax25 ,effcon ,c3c4 ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei ,tl ,parsun ,& + !Ozone stress variables + o3coefv_sun ,o3coefg_sun ,& + !End ozone stress variables + !Ozone WUE stomata model parameter + lambda ,& + !End WUE stomata model parameter + rbsun ,raw ,rstfacsun,cintsun ,& + assimsun ,respcsun ,rssun ) + + ! Shaded leaves + CALL stomata (vmax25 ,effcon ,c3c4 ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei ,tl ,parsha ,& + ! Ozone stress variables + o3coefv_sha ,o3coefg_sha ,& + ! End ozone stress variables + ! Ozone WUE stomata model parameter + lambda ,& + ! End WUE stomata model parameter + rbsha ,raw ,rstfacsha,cintsha ,& + assimsha ,respcsha ,rssha ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + + gs0sun = min( 1.e6, 1./(rssun*tl/tprcor) )/ laisun * 1.e6 * o3coefg_sun + gs0sha = min( 1.e6, 1./(rssha*tl/tprcor) )/ laisha * 1.e6 * o3coefg_sha + + sai = amax1(sai,0.1) + ! PHS update actual stomata conductance (resistance), assimilation rate + ! and leaf respiration. above stomatal resistances are for the canopy, + ! the stomatal resistances and the "rb" in the following calculations are + ! the average for single leaf. thus, + CALL PlantHydraulicStress_twoleaf ( nl_soil ,nvegwcs ,& + z_soi ,dz_soi ,rootfr ,psrf ,qsatl ,& + qaf ,tl ,rb ,rss ,raw ,& + rd ,rstfacsun ,rstfacsha ,cintsun ,cintsha ,& + laisun ,laisha ,rhoair ,fwet ,sai ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,& + psi50_sha ,psi50_xyl ,psi50_root ,htop ,ck ,& + smp ,hk ,hksati ,vegwp ,etrsun ,& + etrsha ,rootflux ,qg ,qm ,gs0sun ,& + gs0sha ,k_soil_root,k_ax_root ,gssun ,gssha ) + + etr = etrsun + etrsha + gssun = gssun * laisun + gssha = gssha * laisha + + CALL update_photosyn(tl, po2m, pco2m, pco2a, parsun, psrf, rstfacsun, rb, gssun, & + effcon, vmax25, c3c4, gradm, trop, slti, hlti, shti, hhti, trda, & + trdm, cintsun, assimsun, respcsun) + + CALL update_photosyn(tl, po2m, pco2m, pco2a, parsha, psrf, rstfacsha, rb, gssha, & + effcon, vmax25, c3c4, gradm, trop, slti, hlti, shti, hhti, trda, & + trdm, cintsha, assimsha, respcsha) + + rssun = tprcor/tl * 1.e6 / gssun + rssha = tprcor/tl * 1.e6 / gssha + ENDIF + + ELSE + rssun = 2.e20; assimsun = 0.; respcsun = 0. + rssha = 2.e20; assimsha = 0.; respcsha = 0. + gssun = 0._r8 + gssha = 0._r8 + + ! 07/2023, yuan: a bug for imbalanced water, rootflux only change + ! in DEF_USE_PLANTHYDRAULICS case in this routine. + IF (DEF_USE_PLANTHYDRAULICS) THEN + etr = 0. + etrsun = 0._r8 + etrsha = 0._r8 + rootflux = 0. + ENDIF + ENDIF + +! above stomatal resistances are for the canopy, the stomatal resistances +! and the "rb" in the following calculations are the average for single leaf. thus, + rssun = rssun * laisun + rssha = rssha * laisha + +!----------------------------------------------------------------------- +! dimensional and non-dimensional sensible and latent heat conductances +! for canopy and soil flux calculations. +!----------------------------------------------------------------------- + + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + cah = 1. / rah + cgh = 1. / rd + cfh = (lai + sai) / rb + + caw = 1. / raw + IF (qg < qaf) THEN + cgw = 1. / rd !dew case. no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cfw = (1.-delta*(1.-fwet))*(lai+sai)/rb + (1.-fwet)*delta* & + ( laisun/(rb+rssun) + laisha/(rb+rssha) ) + + wtshi = 1. / ( cah + cgh + cfh ) + wtsqi = 1. / ( caw + cgw + cfw ) + + wta0 = cah * wtshi + wtg0 = cgh * wtshi + wtl0 = cfh * wtshi + + wtaq0 = caw * wtsqi + wtgq0 = cgw * wtsqi + wtlq0 = cfw * wtsqi + +!----------------------------------------------------------------------- +! IR radiation, sensible and latent heat fluxes and their derivatives +!----------------------------------------------------------------------- +! the partial derivatives of areodynamical resistance are ignored +! which cannot be determined analytically + fac = 1. - thermk + +! longwave absorption and their derivatives + ! 10/16/2017, yuan: added reflected longwave by the ground + +IF (.not.DEF_SPLIT_SOILSNOW) THEN + irab = (frl - 2. * stefnc * tl**4 + emg*stefnc*tg**4 ) * fac & + + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 +ELSE + irab = (frl - 2. * stefnc * tl**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 & + + fsno*emg*stefnc*t_snow**4 ) * fac & + + (1-emg)*thermk*fac*frl + (1-emg)*(1-thermk)*fac*stefnc*tl**4 +ENDIF + dirab_dtl = - 8. * stefnc * tl**3 * fac & + + 4.*(1-emg)*(1-thermk)*fac*stefnc*tl**3 + +! sensible heat fluxes and their derivatives + fsenl = rhoair * cpair * cfh * ( (wta0 + wtg0)*tl - wta0*thm - wtg0*tg ) + fsenl_dtl = rhoair * cpair * cfh * (wta0 + wtg0) + +! latent heat fluxes and their derivatives + + etr = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + + etrsun = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + etrsha = rhoair * (1.-fwet) * delta & + * ( laisha/(rb+rssha) ) * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + + etr_dtl = rhoair * (1.-fwet) * delta & + * ( laisun/(rb+rssun) + laisha/(rb+rssha) ) & + * (wtaq0 + wtgq0)*qsatlDT + + IF (.not. DEF_USE_PLANTHYDRAULICS) THEN + IF(etr.ge.etrc)THEN + etr = etrc + etr_dtl = 0. + ENDIF + ELSE + IF(rstfacsun .lt. 1.e-2 .or. etrsun .le. 0.)etrsun = 0._r8 + IF(rstfacsha .lt. 1.e-2 .or. etrsha .le. 0.)etrsha = 0._r8 + etr = etrsun + etrsha + IF(abs(etr - sum(rootflux)) .gt. 1.e-7)THEN + write(6,*) 'Warning: water balance violation in vegetation PHS', & + ipatch,mpas_rank, etr, sum(rootflux), abs(etr-sum(rootflux)) + CALL CoLM_stop() + ENDIF + ENDIF + + evplwet = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * (lai+sai) / rb & + * (wtaq0 + wtgq0)*qsatlDT + + IF(evplwet.ge.ldew/deltim)THEN + evplwet = ldew/deltim + evplwet_dtl = 0. + ENDIF + + fevpl = etr + evplwet + fevpl_dtl = etr_dtl + evplwet_dtl + + ! 07/09/2014, yuan: added for energy balance + erre = 0. + fevpl_noadj = fevpl + IF ( fevpl*fevpl_bef < 0. ) THEN + erre = -0.9*fevpl + fevpl = 0.1*fevpl + ENDIF + +!----------------------------------------------------------------------- +! difference of temperatures by quasi-newton-raphson method for the non-linear system equations +! MARK#dtl +!----------------------------------------------------------------------- + + dtl(it) = (sabv + irab - fsenl - hvap*fevpl & + + cpliq*qintr_rain*(t_precip-tl) + cpice*qintr_snow*(t_precip-tl)) & + / (clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & + + cpliq*qintr_rain + cpice*qintr_snow) + + dtl_noadj = dtl(it) + + ! check magnitude of change in leaf temperature limit to maximum allowed value + + ! 06/12/2014, yuan: .lt. -> .le. + IF(it .le. itmax) THEN + + ! put brakes on large temperature excursions + IF(abs(dtl(it)).gt.delmax)THEN + dtl(it) = delmax*dtl(it)/abs(dtl(it)) + ENDIF + + ! 06/12/2014, yuan: .lt. -> .le. + ! NOTE: could be a bug IF dtl*dtl==0, changed from lt->le + IF((it.ge.2) .and. (dtl(it-1)*dtl(it).le.0.))THEN + dtl(it) = 0.5*(dtl(it-1) + dtl(it)) + ENDIF + + ENDIF + + tl = tlbef + dtl(it) + +!----------------------------------------------------------------------- +! square roots differences of temperatures and fluxes for use as the condition of convergences +!----------------------------------------------------------------------- + + del = sqrt( dtl(it)*dtl(it) ) + dele = dtl(it) * dtl(it) * ( dirab_dtl**2 + fsenl_dtl**2 + (hvap*fevpl_dtl)**2 ) + dele = sqrt(dele) + +!----------------------------------------------------------------------- +! saturated vapor pressures and canopy air temperature, canopy air humidity +!----------------------------------------------------------------------- +! Recalculate leaf saturated vapor pressure (ei_)for updated leaf temperature +! and adjust specific humidity (qsatl_) proportionately + CALL qsadv(tl,psrf,ei,deiDT,qsatl,qsatlDT) + +! update vegetation/ground surface temperature, canopy air temperature, +! canopy air humidity + taf = wta0*thm + wtg0*tg + wtl0*tl + qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl + +! update co2 partial pressure within canopy air + gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 + IF (DEF_RSS_SCHEME .eq. 4) THEN + gdh2o = rss/rd * tprcor/thm !mol m-2 s-1 + ELSE + gdh2o = 1.0/(rd+rss) * tprcor/thm !mol m-2 s-1 + ENDIF + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + (assimsun + assimsha - respcsun -respcsha - rsoil) + +!----------------------------------------------------------------------- +! Update monin-obukhov length and wind speed including the stability effect +!----------------------------------------------------------------------- + + dth = thm - taf + dqh = qm - qaf + + tstar = vonkar/(fh-fht)*dth + qstar = vonkar/(fq-fqt)*dqh + + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF(zeta .ge. 0.)THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF(zeta .ge. 0.)THEN + um = max(ur,.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu_,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF(obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF(nmozsgn .ge. 4) obu = zldis/(-0.01) + obuold = obu + +!----------------------------------------------------------------------- +! Test for convergence +!----------------------------------------------------------------------- + + it = it+1 + + IF(it .gt. itmin) THEN + fevpl_bef = fevpl + det = max(del,del2) + ! 10/03/2017, yuan: possible bugs here, solution: + ! define dee, change del => dee + dee = max(dele,dele2) + IF(det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF + + ENDDO + + IF(DEF_USE_OZONESTRESS)THEN + CALL CalcOzoneStress(o3coefv_sun,o3coefg_sun,forc_ozone,psrf,th,ram,& + rssun,rb,lai,lai_old,ivt,o3uptakesun,sabv,deltim) + CALL CalcOzoneStress(o3coefv_sha,o3coefg_sha,forc_ozone,psrf,th,ram,& + rssha,rb,lai,lai_old,ivt,o3uptakesha,sabv,deltim) + lai_old = lai + assimsun = assimsun * o3coefv_sun + assimsha = assimsha * o3coefv_sha +! rssun = rssun / o3coefg_sun +! rssha = rssha / o3coefg_sha + ELSE + o3coefv_sun = 1.0_r8 + o3coefg_sun = 1.0_r8 + o3coefv_sha = 1.0_r8 + o3coefg_sha = 1.0_r8 + ENDIF + +! ====================================================================== +! END stability iteration +! ====================================================================== + + z0m = z0mv + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! canopy fluxes and total assimilation amd respiration + + IF(lai .gt. 0.001) THEN + rst = 1./(laisun/rssun + laisha/rssha) + ELSE + rssun = 2.0e4 ; rssha = 2.0e4 + assimsun = 0. ; assimsha = 0. + respcsun = 0. ; respcsha = 0. + rst = 2.0e4 + ENDIF + assim = assimsun + assimsha + respc = respcsun + respcsha! + rsoil + +! canopy fluxes and total assimilation amd respiration + fsenl = fsenl + fsenl_dtl*dtl(it-1) & + ! yuan: add the imbalanced energy below due to T adjustment to sensible heat + + (dtl_noadj-dtl(it-1)) * (clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl & + + cpliq * qintr_rain + cpice * qintr_snow) & + ! yuan: add the imbalanced energy below due to q adjustment to sensible heat + + hvap*erre + + etr0 = etr + etr = etr + etr_dtl*dtl(it-1) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + !TODO@yuan: rootflux may not be consistent with etr, + ! water imbalance could happen. + IF (abs(etr0) .ge. 1.e-15) THEN + rootflux = rootflux * etr / etr0 + ELSE + rootflux = rootflux + dz_soi / sum(dz_soi) * etr_dtl* dtl(it-1) + ENDIF + +! !NOTE: temporal solution to make etr and rootflux consistent. +! !TODO: need double check +! sumrootr = sum(rootr(:), rootr(:)>0.) +! IF (abs(sumrootr) > 0.) THEN +! rootr(:) = max(rootr(:),0.) * (etr/sumrootr) +! ELSE +! rootr(:) = etr*rootfr(:) +! ENDIF + ENDIF + + evplwet = evplwet + evplwet_dtl*dtl(it-1) + fevpl = fevpl_noadj + fevpl = fevpl + fevpl_dtl*dtl(it-1) + + elwmax = ldew/deltim + elwdif = max(0., evplwet-elwmax) + evplwet = min(evplwet, elwmax) + + fevpl = fevpl - elwdif + fsenl = fsenl + hvap*elwdif + + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram + +!----------------------------------------------------------------------- +! fluxes from ground to canopy space +!----------------------------------------------------------------------- + + fseng = cpair*rhoair*cgh*(tg-taf) +! 03/07/2020, yuan: calculate fseng_soil/snow + !NOTE: taf = wta0*thm + wtg0*tg + wtl0*tl + fseng_soil = cpair*rhoair*cgh*((1.-wtg0)*t_soil - wta0*thm - wtl0*tl) + fseng_snow = cpair*rhoair*cgh*((1.-wtg0)*t_snow - wta0*thm - wtl0*tl) + +! 03/07/2020, yuan: calculate fevpg_soil/snow + !NOTE: qaf = wtaq0*qm + wtgq0*qg + wtlq0*qsatl + fevpg = rhoair*cgw*(qg-qaf) + fevpg_soil = rhoair*cgw*((1.-wtgq0)*q_soil - wtaq0*qm - wtlq0*qsatl) + fevpg_snow = rhoair*cgw*((1.-wtgq0)*q_snow - wtaq0*qm - wtlq0*qsatl) + +!----------------------------------------------------------------------- +! downward (upward) longwave radiation below (above) the canopy and prec. sensible heat +!----------------------------------------------------------------------- + + ! 10/16/2017, yuan: added reflected longwave by the ground + dlrad = thermk * frl & + + stefnc * fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) + +IF (.not.DEF_SPLIT_SOILSNOW) THEN + ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & + + thermk*emg*tg**4 ) & + + (1-emg)*thermk*thermk*frl & + + (1-emg)*thermk*fac*stefnc*tlbef**4 & + + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) +ELSE + ulrad = stefnc * ( fac * tlbef**3 * (tlbef + 4.*dtl(it-1)) & + + (1.-fsno)*thermk*emg*t_soil**4 & + + fsno*thermk*emg*t_snow**4 ) & + + (1-emg)*thermk*thermk*frl & + + (1-emg)*thermk*fac*stefnc*tlbef**4 & + + 4.*(1-emg)*thermk*fac*stefnc*tlbef**3*dtl(it-1) +ENDIF + ! precipitation sensible heat from canopy + hprl = cpliq * qintr_rain*(t_precip-tl) + cpice * qintr_snow*(t_precip-tl) + + ! vegetation heat change + dheatl = clai/deltim*dtl(it-1) + +!----------------------------------------------------------------------- +! Derivative of soil energy flux with respect to soil temperature (cgrnd) +!----------------------------------------------------------------------- + + cgrnds = cpair*rhoair*cgh*(1.-wtg0) + cgrndl = rhoair*cgw*(1.-wtgq0)*dqgdT + cgrnd = cgrnds + cgrndl*htvp + +!----------------------------------------------------------------------- +! balance check +! (the computational error was created by the assumed 'dtl' in MARK#dtl) +!----------------------------------------------------------------------- + + err = sabv + irab + dirab_dtl*dtl(it-1) - fsenl - hvap*fevpl + hprl & + ! account for vegetation heat change + - dheatl + +#if (defined CoLMDEBUG) + IF(abs(err) .gt. .2) & + write(6,*) 'energy imbalance in LeafTemperature.F90',it-1,& + err,sabv,irab,fsenl,hvap*fevpl,hprl,dheatl +#endif + +!----------------------------------------------------------------------- +! Update dew accumulation (kg/m2) +!----------------------------------------------------------------------- + IF (DEF_Interception_scheme .eq. 1) THEN + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 2) THEN !CLM4.5 + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 7) THEN !JULES + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 8) THEN !CoLM202X + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + ELSE + CALL CoLM_stop() + ENDIF + + ! Bug fix: When DEF_VEG_SNOW is false, only ldew is updated above + ! (via ldew = max(0., ldew - evplwet*deltim)), but ldew_rain/ldew_snow + ! remain unchanged. Downstream interception routines (schemes 1, 3-8) + ! resync ldew = ldew_rain + ldew_snow at entry, which would silently + ! revert the evaporation adjustment. Fix by scaling components proportionally. + IF (.not. DEF_VEG_SNOW) THEN + IF (ldew_rain + ldew_snow > 1.e-10) THEN + ldew_rain = ldew * (ldew_rain / (ldew_rain + ldew_snow)) + ldew_snow = ldew - ldew_rain + ELSEIF (ldew > 0.) THEN + ! Components were zero but ldew > 0 (condensation case) + IF (tl > tfrz) THEN + ldew_rain = ldew + ldew_snow = 0. + ELSE + ldew_rain = 0. + ldew_snow = ldew + ENDIF + ELSE + ldew_rain = 0. + ldew_snow = 0. + ENDIF + ENDIF + + IF ( DEF_VEG_SNOW ) THEN + ! update fwet_snow + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((10./(48.*(lai+sai)))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + ! phase change + + qmelt = 0. + qfrz = 0. + + !TODO: double check below + IF (ldew_snow.gt.1.e-6 .and. tl.gt.tfrz) THEN + qmelt = min(ldew_snow/deltim,(tl-tfrz)*cpice*ldew_snow/(deltim*hfus)) + ldew_snow = max(0.,ldew_snow - qmelt*deltim) + ldew_rain = max(0.,ldew_rain + qmelt*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl = fwet_snow*tfrz + (1.-fwet_snow)*tl !Niu et al., 2004 + ENDIF + + IF (ldew_rain.gt.1.e-6 .and. tl.lt.tfrz) THEN + qfrz = min(ldew_rain/deltim,(tfrz-tl)*cpliq*ldew_rain/(deltim*hfus)) + ldew_rain = max(0.,ldew_rain - qfrz*deltim) + ldew_snow = max(0.,ldew_snow + qfrz*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl = fwet_snow*tfrz + (1.-fwet_snow)*tl !Niu et al., 2004 + ENDIF + ENDIF + +!----------------------------------------------------------------------- +! 2 m height air temperature +!----------------------------------------------------------------------- + tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) + + END SUBROUTINE LeafTemperature +!---------------------------------------------------------------------- + + SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) + !DESCRIPTION + !=========== + ! determine fraction of foliage covered by water and + ! fraction of foliage that is dry and transpiring + + !Original Author: + !------------------- + !---Yongjiu Dai + + !References: + !------------------- + !---Dai, Y., Zeng, X., Dickinson, R.E., Baker, I., Bonan, G.B., BosiloVICh, M.G., Denning, + ! A.S., Dirmeyer, P.A., Houser, P.R., Niu, G. and Oleson, K.W., 2003. The common land + ! model. Bulletin of the American Meteorological Society, 84(8), pp.1013-1024. + + !ANCILLARY FUNCTIONS AND SUBROUTINES + !------------------- + + !REVISION HISTORY + !---------------- + !---2024.04.16 Hua Yuan: add option to account for vegetation snow process + !---2021.12.08 Zhongwang Wei @ SYSU + !---2018.06 Hua Yuan: remove sigf, to compatible with PFT + !---1999.09.15 Yongjiu Dai + !======================================================================= + + USE MOD_Precision + + IMPLICIT NONE + + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: dewmx !maximum allowed dew [0.1 mm] + real(r8), intent(in) :: ldew !depth of water on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_rain !depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet !fraction of foliage covered by water&snow [-] + real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] + + real(r8) :: lsai !lai + sai + real(r8) :: dewmxi !inverse of maximum allowed dew [1/mm] + real(r8) :: vegt !sigf*lsai, NOTE: remove sigf + real(r8) :: satcap_rain !saturation capacity of foliage for rain [kg/m2] + real(r8) :: satcap_snow !saturation capacity of foliage for snow [kg/m2] + real(r8) :: fwet_rain !fraction of foliage covered by water [-] + real(r8) :: fwet_snow !fraction of foliage covered by snow [-] + + !----------------------------------------------------------------------- + ! Fwet is the fraction of all vegetation surfaces which are wet + ! including stem area which contribute to evaporation + lsai = lai + sai ! effective leaf area index + dewmxi = 1.0/dewmx + ! 06/2018, yuan: remove sigf, to compatible with PFT + vegt = lsai + + fwet = 0 + IF (ldew > 0.) THEN + fwet = ((dewmxi/vegt)*ldew)**.666666666666 + ! Check for maximum limit of fwet + fwet = min(fwet,1.0) + ENDIF + + ! account for vegetation snow + ! calculate fwet_rain, fwet_snow, fwet + IF ( DEF_VEG_SNOW ) THEN + + fwet_rain = 0 + IF(ldew_rain > 0.) THEN + fwet_rain = ((dewmxi/vegt)*ldew_rain)**.666666666666 + ! Check for maximum limit of fwet_rain + fwet_rain = min(fwet_rain,1.0) + ENDIF + + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((dewmxi/(48.*vegt))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + fwet = fwet_rain + fwet_snow - fwet_rain*fwet_snow + fwet = min(fwet,1.0) + ENDIF + + ! fdry is the fraction of lai which is dry because only leaves can + ! transpire. Adjusted for stem area which does not transpire + fdry = (1.-fwet)*lai/lsai + + END SUBROUTINE dewfraction + +END MODULE MOD_LeafTemperature diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 new file mode 100644 index 0000000000..1150338e53 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90 @@ -0,0 +1,2146 @@ +#include + +MODULE MOD_LeafTemperaturePC + +!----------------------------------------------------------------------- +! +! --- Leaf Temperature and Turbulence Modeling --- +! for Plant Community (PC) Simulation +! +! o Reference hight +! | +! | +! _____ tree | _____ --- Layer3 +! ||||||| | ||||||| +! |||||||||--\/\/\/o ||||||||| +! \|||||/ | \|||||/ +! | | | --- Layer2 +! | | | shrub /xx\ +! | grass -/\/-o--------|---\/\/\--\xx/ +! ____________|_____\\//____________|___________||__ --- Layer1 +! ///////////////////////////////////////////////////////////////////// +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_MPAS_MPI, only: CoLM_stop + USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_RSS_SCHEME, DEF_Interception_scheme, DEF_SPLIT_SOILSNOW, & + DEF_VEG_SNOW + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: LeafTemperaturePC + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: dewfraction + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE LeafTemperaturePC ( & + ipatch ,ps ,pe ,deltim ,csoilc ,dewmx ,& + htvp ,pftclass ,fcover ,htop ,hbot ,lai ,& + sai ,extkb ,extkd ,hu ,ht ,hq ,& + us ,vs ,forc_t ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,parsun ,parsha ,fsun ,& + sabv ,frl ,thermk ,fshade ,rstfacsun ,rstfacsha ,& + gssun ,gssha ,po2m ,pco2m ,z0h_g ,obug ,& + ustarg ,zlnd ,zsno ,fsno ,sigf ,etrc ,& + tg ,qg ,rss ,dqgdT ,emg ,t_soil ,& + t_snow ,q_soil ,q_snow ,z0mpc ,tl ,ldew ,& + ldew_rain ,ldew_snow ,fwet_snow ,taux ,tauy ,fseng ,& + fseng_soil ,fseng_snow ,fevpg ,fevpg_soil ,fevpg_snow ,cgrnd ,& + cgrndl ,cgrnds ,tref ,qref ,rst ,assim ,& + respc ,fsenl ,fevpl ,etr ,dlrad ,ulrad ,& + z0m ,zol ,rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,vegwp ,gs0sun ,gs0sha ,& + assimsun ,etrsun ,assimsha ,etrsha ,& +!Ozone stress variables + o3coefv_sun,o3coefv_sha,o3coefg_sun,o3coefg_sha,& + lai_old ,o3uptakesun,o3uptakesha,forc_ozone ,& +!End ozone stress variables + hpbl, & + qintr_rain ,qintr_snow ,t_precip ,hprl ,& + dheatl ,smp ,hk ,hksati ,& + rootflux ) + +!======================================================================= +! +! !DESCRIPTION: +! Leaf temperature resolved for Plant Community (3D) case Foliage +! energy conservation for each PFT is given by foliage energy budget +! equation: +! Rnet - Hf - LEf = 0 +! The equation is solved by Newton-Raphson iteration, in which this +! iteration includes the calculation of the photosynthesis and stomatal +! resistance, and the integration of turbulent flux profiles. The +! sensible and latent heat transfer between foliage and atmosphere and +! ground is linked by the equations: +! Ha = Hf + Hg and Ea = Ef + Eg +! +! Original author: Hua Yuan and Yongjiu Dai, September, 2017 +! +! +! !REFERENCES: +! 1) Dai, Y., Yuan, H., Xin, Q., Wang, D., Shangguan, W., Zhang, S., et +! al. (2019). Different representations of canopy structure—A large +! source of uncertainty in global land surface modeling. Agricultural +! and Forest Meteorology, 269-270, 119-135. +! https://doi.org/10.1016/j.agrformet.2019.02.006 +! +! !REVISIONS: +! +! 01/2021, Xingjie Lu and Nan Wei: added plant hydraulic process +! interface. +! +! 01/2021, Nan Wei: added interaction btw prec and canopy. +! +! 05/2023, Shaofeng Liu: add option to call moninobuk_leddy, the +! LargeEddy surface turbulence scheme (LZD2022); make a proper +! update of um. +! +! 04/2024, Hua Yuan: add option to account for vegetation snow process. +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: vonkar, grav, hvap, hsub, cpair, stefnc, & + cpliq, cpice, hfus, tfrz, denice, denh2o + USE MOD_Const_PFT + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_TurbulenceLEddy + USE MOD_Qsadv + USE MOD_AssimStomataConductance + USE MOD_PlantHydraulic, only: PlantHydraulicStress_twoleaf + USE MOD_Ozone, only: CalcOzoneStress + USE MOD_Vars_1DForcing, only: forc_height_mode + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: ipatch + integer, intent(in) :: & + ps, &! start PFT index in a patch + pe ! end PFT index in a patch + + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + csoilc, &! drag coefficient for soil under canopy [-] + dewmx, &! maximum dew + htvp ! latent heat of evaporation (/sublimation) [J/kg] + +! vegetation parameters + integer, dimension(ps:pe), intent(in) :: & + pftclass ! PFT class + + real(r8), dimension(ps:pe), intent(in) :: & + fcover, &! PFT fractional coverage [-] + htop, &! PFT crown top height [m] + hbot, &! PFT crown bottom height [m] + lai, &! adjusted leaf area index for seasonal variation [-] + sai ! stem area index [-] + + real(r8), intent(inout) :: & + vegwp(1:nvegwcs,ps:pe), &! vegetation water potential + gs0sun(ps:pe), &! maximum stomata conductance of sunlit leaf + gs0sha(ps:pe) ! maximum stomata conductance of shaded leaf + +! input variables + real(r8), intent(in) :: & + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + forc_t, &! temperature at agcm reference height [kelvin] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + qm, &! specific humidity at reference height [kg/kg] + psrf, &! pressure at reference height [pa] + rhoair, &! density air [kg/m**3] + + parsun(ps:pe), &! par absorbed per unit sunlit lai [w/m**2] + parsha(ps:pe), &! par absorbed per unit shaded lai [w/m**2] + fsun (ps:pe), &! sunlit fraction of canopy + sabv (ps:pe), &! solar radiation absorbed by vegetation [W/m2] + frl, &! atmospheric infrared (longwave) radiation [W/m2] + + extkb (ps:pe), &! (k, g(mu)/mu) direct solar extinction coefficient + extkd (ps:pe), &! diffuse and scattered diffuse PAR extinction coefficient + thermk(ps:pe), &! canopy gap fraction for tir radiation + fshade(ps:pe), &! shadow for each PFT + + po2m, &! atmospheric partial pressure o2 (pa) + pco2m, &! atmospheric partial pressure co2 (pa) + + z0h_g, &! bare soil roughness length, sensible heat [m] + obug, &! bare soil obu + ustarg, &! bare soil ustar + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno, &! fraction of snow cover on ground + + sigf (ps:pe), &! fraction of veg cover, excluding snow-covered veg [-] + etrc (ps:pe), &! maximum possible transpiration rate (mm/s) + tg, &! ground surface temperature [K] + t_soil, &! ground surface soil temperature [K] + t_snow, &! ground surface snow temperature [K] + qg, &! specific humidity at ground surface [kg/kg] + q_soil, &! specific humidity at ground surface soil [kg/kg] + q_snow, &! specific humidity at ground surface snow [kg/kg] + dqgdT, &! temperature derivative of "qg" + rss, &! soil surface resistance [s/m] + emg ! vegetation emissivity + + real(r8), intent(in) :: & + t_precip, &! snowfall/rainfall temperature [kelvin] + qintr_rain(ps:pe), &! rainfall interception (mm h2o/s) + qintr_snow(ps:pe), &! snowfall interception (mm h2o/s) + smp (1:nl_soil), &! precipitation sensible heat from canopy + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + hk (1:nl_soil) ! soil hydraulic conductance + + real(r8), intent(in) :: & + hpbl ! atmospheric boundary layer height [m] + + real(r8), dimension(ps:pe), intent(inout) :: & + tl, &! leaf temperature [K] + ldew, &! depth of water on foliage [mm] + ldew_rain, &! depth of rain on foliage [mm] + ldew_snow, &! depth of snow on foliage [mm] + fwet_snow, &! vegetation snow fractional cover [-] +!Ozone stress variables + lai_old , &! lai in last time step + o3uptakesun, &! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha, &! Ozone does, shaded leaf (mmol O3/m^2) + o3coefv_sun, &! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha, &! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun, &! Ozone stress factor for stomata on shaded leaf + o3coefg_sha, &! Ozone stress factor for stomata on shaded leaf +!End ozone stress variables + rstfacsun, &! factor of soil water stress to transpiration on sunlit leaf + rstfacsha, &! factor of soil water stress to transpiration on shaded leaf + gssun, &! stomata conductance of sunlit leaf + gssha ! stomata conductance of shaded leaf + + real(r8), dimension(ps:pe), intent(inout) :: & + assimsun, &! sunlit leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsun, &! transpiration rate of sunlit leaf [mm/s] + assimsha, &! shaded leaf assimilation rate [umol co2 /m**2/ s] [+] + etrsha ! transpiration rate of shaded leaf [mm/s] + +!Ozone stress variables + real(r8), intent(inout) :: forc_ozone +!End ozone stress variables + + real(r8), intent(inout) :: & + dlrad, &! downward longwave radiation blow the canopy [W/m2] + ulrad, &! upward longwave radiation above the canopy [W/m2] + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fseng, &! sensible heat flux from ground [W/m2] + fseng_soil, &! sensible heat flux from ground soil [W/m2] + fseng_snow, &! sensible heat flux from ground snow [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + fevpg_soil, &! evaporation heat flux from ground soil [mm/s] + fevpg_snow, &! evaporation heat flux from ground snow [mm/s] + tref, &! 2 m height air temperature (kelvin) + qref, &! 2 m height air specific humidity + rootflux(nl_soil,ps:pe) ! root water uptake from different layers + + real(r8), dimension(ps:pe), intent(out) :: & + z0mpc, &! z0m for individual PFT + rst, &! stomatal resistance + assim, &! rate of assimilation + respc, &! rate of respiration + fsenl, &! sensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + hprl, &! precipitation sensible heat from canopy + dheatl ! vegetation heat change [W/m2] + + real(r8), intent(inout) :: & + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + + real(r8), intent(inout) :: & + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil latent heat flux wrt soil temp [w/m2/k] + cgrnds ! deriv of soil sensible heat flux wrt soil temp [w/m**2/k] + +!-------------------------- Local Variables ---------------------------- +! assign iteration parameters + integer, parameter :: itmax = 40 !maximum number of iteration + integer, parameter :: itmin = 6 !minimum number of iteration + real(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] + real(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] + + real(r8) dtl(0:itmax+1,ps:pe) !difference of tl between two iterative step + + !TODO: read from mod_const_pft.F90 + real(r8), dimension(ps:pe) :: & + canlay, &! PFT canopy layer number + sqrtdi ! inverse sqrt of leaf dimension [m**-0.5] + + !TODO: read from mod_const_pft.F90 file + real(r8), dimension(ps:pe) :: & + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + shti, &! slope of high temperature inhibition function (s1) + hhti, &! 1/2 point of high temperature inhibition function (s2) + slti, &! slope of low temperature inhibition function (s3) + hlti, &! 1/2 point of low temperature inhibition function (s4) + trda, &! temperature coefficient in gs-a model (s5) + trdm, &! temperature coefficient in gs-a model (s6) + trop, &! temperature coefficient in gs-a model (273+25) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + lambda, &! marginal water cost of carbon gain + extkn ! coefficient of leaf nitrogen allocation + + integer, dimension(ps:pe) :: & + c3c4 ! C3/C4 plant type + + real(r8), dimension(ps:pe) :: & + kmax_sun, &! Plant Hydraulics Parameters + kmax_sha, &! Plant Hydraulics Parameters + kmax_xyl, &! Plant Hydraulics Parameters + kmax_root, &! Plant Hydraulics Parameters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck ! shape-fitting parameter for vulnerability curve (-) + + real(r8) :: & + rootfr(nl_soil,ps:pe) ! root fraction + + real(r8) :: & + hu_, &! adjusted observational height of wind [m] + ht_, &! adjusted observational height of temperature [m] + hq_, &! adjusted observational height of humidity [m] + zldis, &! reference height "minus" zero displacement height [m] + zii, &! convective boundary layer height [m] + z0mv, &! roughness length, momentum [m] + z0hv, &! roughness length, sensible heat [m] + z0qv, &! roughness length, latent heat [m] + zeta, &! dimensionless height used in Monin-Obukhov theory + beta, &! coefficient of convective velocity [-] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + dth, &! diff of virtual temp. between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + obu, &! monin-obukhov length (m) + um, &! wind speed including the stability effect [m/s] + ur, &! wind speed at reference height [m/s] + uaf, &! velocity of air within foliage [m/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + eah, &! canopy air vapor pressure (pa) + pco2g, &! co2 pressure (pa) at ground surface (pa) + pco2a, &! canopy air co2 pressure (pa) + + cf, &! heat transfer coefficient from leaves [-] + rbsun, &! bulk boundary layer resistance of sunlit fraction of canopy + rbsha, &! bulk boundary layer resistance of shaded fraction of canopy + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + + det, &! maximum leaf temp. change in two consecutive iter [K] + dee, &! maximum leaf heat fluxes change in two consecutive iter [W/m2] + obuold, &! monin-obukhov length from previous iteration + err, &! balance error + + rsoil, &! soil respiration + gah2o, &! conductance between canopy and atmosphere + gdh2o, &! conductance between canopy and ground + tprcor, &! tf*psur*100./1.013e5 + + fht, &! integral of profile function for heat at the top layer + fqt, &! integral of profile function for moisture at the top layer + phih, &! phi(h), similarity function for sensible heat + + clai (ps:pe), &! canopy heat capacity [Jm-2K-1] + fdry (ps:pe), &! fraction of foliage that is green and dry [-] + fwet (ps:pe), &! fraction of foliage covered by water [-] + rb (ps:pe), &! leaf boundary layer resistance [s/m] + cfh (ps:pe), &! heat conductance for leaf [m/s] + cfw (ps:pe), &! latent heat conductance for leaf [m/s] + wlh (ps:pe), &! normalized heat conductance for air and leaf [-] + wlq (ps:pe), &! normalized latent heat cond. for air and leaf [-] + + ei (ps:pe), &! vapor pressure on leaf surface [pa] + deidT (ps:pe), &! derivative of "ei" on "tl" [pa/K] + qsatl (ps:pe), &! leaf specific humidity [kg/kg] + qsatldT (ps:pe), &! derivative of "qsatl" on "tlef" + + del (ps:pe), &! absolute change in leaf temp in current iteration [K] + del2 (ps:pe), &! change in leaf temperature in previous iteration [K] + dele (ps:pe), &! change in heat fluxes from leaf [W/m2] + dele2 (ps:pe), &! change in heat fluxes from leaf in previous iteration [W/m2] + + tlbef (ps:pe), &! leaf temperature from previous iteration [K] + fsha (ps:pe), &! shaded fraction of canopy + laisun (ps:pe), &! sunlit leaf area index, one-sided + laisha (ps:pe), &! shaded leaf area index, one-sided + rssun (ps:pe), &! sunlit leaf stomatal resistance [s/m] + rssha (ps:pe), &! shaded leaf stomatal resistance [s/m] + respcsun (ps:pe), &! sunlit leaf respiration rate [umol co2 /m**2/ s] [+] + respcsha (ps:pe) ! shaded leaf respiration rate [umol co2 /m**2/ s] [+] + + integer it, nmozsgn + + real(r8) w, csoilcn, z0mg, z0hg, z0qg, elwmax, elwdif, sumrootflux + real(r8) cintsun(3, ps:pe), cintsha(3, ps:pe) + real(r8),dimension(ps:pe) :: delta, fac, etr0 + real(r8),dimension(ps:pe) :: irab, dirab_dtl, fsenl_dtl, fevpl_dtl + real(r8),dimension(ps:pe) :: evplwet, evplwet_dtl, etr_dtl + real(r8),dimension(ps:pe) :: fevpl_bef, fevpl_noadj, dtl_noadj, htvpl, erre + real(r8),dimension(ps:pe) :: qevpl, qdewl, qsubl, qfrol, qmelt, qfrz + real(r8),dimension(ps:pe) :: gb_mol_sun,gb_mol_sha + real(r8),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance + real(r8),dimension(nl_soil) :: k_ax_root ! axial root conductance + + ! ................................................................. + ! definition for 3d run + ! ................................................................. + + integer , parameter :: nlay = 3 + + real(r8), parameter :: & + c1 = 0.320, &! parameter to calculate drag coefficients of Massman's method + c2 = 0.264, &! parameter to calculate drag coefficients of Massman's method + c3 = 15.1, &! parameter to calculate drag coefficients of Massman's method + iw = 0.5, &! parameter to calculate alpha of Goudriaa's method + Cd = 0.2, &! leaf drag coefficient + cd1 = 7.5, &! a free parameter for d/h calculation, Raupach 1992, 1994 + psih = 0.193 ! psih = ln(cw) - 1 + cw^-1, cw = 2, Raupach 1994 + + real(r8) :: sqrtdragc! sqrt(drag coefficient) + real(r8) :: lm ! mix length within canopy + real(r8) :: fai ! canopy frontal area index + + real(r8), dimension(0:nlay) :: & + z0m_lays, &! roughness length for momentum for the layer and below + z0h_lays, &! roughness length for SH for the layer and below + z0q_lays, &! roughness length for LH for the layer and below + displa_lays, &! displacement height for the layer and below + fcover_lays ! vegetation fractional cover for this layer and above + + real(r8), dimension(ps:pe) :: & + lsai ! lai + sai + + real(r8), dimension(nlay) :: & + htop_lay, &! canopy crown top for each layer + hbot_lay, &! canopy crown bottom for each layer + fcover_lay, &! vegetation fractional coverage for each layer + lsai_lay, &! (lai+sai) for each layer + a_lay, &! exp. extinction factor for u/k decline within canopy + a_lay_i63, &! exp. extinction factor for u/k decline within canopy (Inoue 1963) + a_lay_k71, &! exp. extinction factor for u/k decline within canopy (Kondo 1971) + a_lay_g77, &! exp. extinction factor for u/k decline within canopy (Groudrian 1977) + a_lay_m97, &! exp extinction factor for u/k decline within canopy (Massman 1997) + utop_lay, &! wind speed at layer top [m/s] + ubot_lay, &! wind speed at layer bottom [m/s] + ueff_lay, &! effective wind speed within canopy layer [m/s] + ueff_lay_, &! effective wind speed within canopy layer [m/s] + ueff_lay_norm, &! normalized effective wind speed within canopy layer [m/s] + ktop_lay, &! eddy coefficient at layer top + kbot_lay, &! eddy coefficient at layer bottom + z0m_lay, &! roughness length for the vegetation covered area + displa_lay, &! displacement height for the vegetation covered area + taf, &! air temperature within canopy space [K] + qaf, &! humidity of canopy air [kg/kg] + rd, &! aerodynamic resistance between layers [s/m] + cah, &! heat conductance for air [m/s] + cgh, &! heat conductance for ground [m/s] + caw, &! latent heat conductance for air [m/s] + cgw, &! latent heat conductance for ground [m/s] + wtshi, &! sensible heat resistance for air, grd and leaf [-] + wtsqi, &! latent heat resistance for air, grd and leaf [-] + wah, &! normalized heat conductance for air [-] + wgh, &! normalized heat conductance for ground [-] + waq, &! normalized latent heat conductance for air [-] + wgq, &! normalized heat conductance for ground [-] + wlhl, &! sum of normalized heat conductance for air and leaf + wlql ! sum of normalized heat conductance for air and leaf + + real(r8) :: ktop, utop, fmtop, bee, tmpw1, tmpw2, fact, facq + + logical is_vegetated_patch + integer i, p, clev + integer toplay, botlay, upplay, numlay + integer d_opt, rb_opt, rd_opt + + real(r8) :: displa, ttaf, tqaf + + ! variables for longwave transfer calculation + ! ................................................................. + real(r8) :: tdn(0:4,0:4) !downward transfer coefficient matrix for LW + real(r8) :: tup(0:4,0:4) !upward transfer coefficient matrix for LW + real(r8) :: thermk_lay(nlay) !transmittance of longwave radiation for each layer + real(r8) :: fshade_lay(nlay) !shadow of each layer + real(r8) :: L(nlay) !longwave radiation emitted by canopy layer + real(r8) :: Ltd(nlay) !transmitted downward longwave radiation from canopy layer + real(r8) :: Ltu(nlay) !transmitted upward longwave radiation from canopy layer + real(r8) :: Lin(0:4) !incoming longwave radiation for each layer + real(r8) :: Ld(0:4) !total downward longwave radiation for each layer + real(r8) :: Lu(0:4) !total upward longwave radiation for each layer + real(r8) :: Lg !emitted longwave radiation from ground + real(r8) :: Lv(ps:pe) !absorbed longwave radiation for each pft + real(r8) :: dLv(ps:pe) !LW change due to temperature change + real(r8) :: dLvpar(nlay) !temporal variable for calculating dLv + +!----------------------------------------------------------------------- + +! only process with vegetated patches + + lsai(:) = lai(:) + sai(:) + is_vegetated_patch = .false. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + is_vegetated_patch = .true. + ELSE + tl(i) = forc_t + ENDIF + ENDDO + + ! When there is no vegetation in this Plant Community Patch, RETURN + IF (.not. is_vegetated_patch) THEN + RETURN + ENDIF + +! initialization of errors and iteration parameters + it = 1 !counter for leaf temperature iteration + del(:) = 0.0 !change in leaf temperature from previous iteration + dele(:) = 0.0 !latent head flux from leaf for previous iteration + + dtl(:,:) = 0. + fevpl_bef(:) = 0. + + d_opt = 2 + rd_opt = 3 + rb_opt = 3 + +! initial values for z0hg, z0qg + z0mg = (1.-fsno)*zlnd + fsno*zsno + z0hg = z0mg + z0qg = z0mg + +! initialization of PFT constants + DO i = ps, pe + p = pftclass(i) + + canlay (i) = canlay_p (p) + sqrtdi (i) = sqrtdi_p (p) + + effcon (i) = effcon_p (p) + vmax25 (i) = vmax25_p (p) + c3c4 (i) = c3c4_p (p) + shti (i) = shti_p (p) + hhti (i) = hhti_p (p) + slti (i) = slti_p (p) + hlti (i) = hlti_p (p) + trda (i) = trda_p (p) + trdm (i) = trdm_p (p) + trop (i) = trop_p (p) + g1 (i) = g1_p (p) + g0 (i) = g0_p (p) + gradm (i) = gradm_p (p) + binter (i) = binter_p (p) + lambda (i) = lambda_p (p) + extkn (i) = extkn_p (p) + + kmax_sun (i) = kmax_sun_p (p) + kmax_sha (i) = kmax_sha_p (p) + kmax_xyl (i) = kmax_xyl_p (p) + kmax_root (i) = kmax_root_p (p) + psi50_sun (i) = psi50_sun_p (p) + psi50_sha (i) = psi50_sha_p (p) + psi50_xyl (i) = psi50_xyl_p (p) + psi50_root (i) = psi50_root_p (p) + ck (i) = ck_p (p) + + rootfr (:,i) = rootfr_p (:,p) + ENDDO + +!----------------------------------------------------------------------- +! scaling-up coefficients from leaf to canopy +!----------------------------------------------------------------------- + +! note: need to separate to sunlit/shaded pars +!----------------------------------------------------------------------- + +! partition visible canopy absorption to sunlit and shaded fractions +! to get average absorbed par for sunlit and shaded leaves + fsha(:) = 1. - fsun(:) + laisun(:) = lai(:)*fsun(:) + laisha(:) = lai(:)*fsha(:) + + cintsun(1,:) = (1.-exp(-(0.110+extkb)*lai))/(0.110+extkb) + cintsun(2,:) = (1.-exp(-(extkb+extkd)*lai))/(extkb+extkd) + cintsun(3,:) = (1.-exp(-extkb*lai))/extkb + + cintsha(1,:) = (1.-exp(-0.110*lai))/0.110 - cintsun(1,:) + cintsha(2,:) = (1.-exp(-extkd*lai))/extkd - cintsun(2,:) + cintsha(3,:) = lai(:) - cintsun(3,:) + +!----------------------------------------------------------------------- +! get fraction of wet and dry canopy surface (fwet & fdry) +! initial saturated vapor pressure and humidity and their derivation +!----------------------------------------------------------------------- + + DO i = ps, pe + + clai(i) = 0.0 + + ! 0.2mm*LSAI, account for leaf (plus dew) heat capacity + IF ( DEF_VEG_SNOW ) THEN + clai(i) = 0.2*lsai(i)*cpliq + ldew_rain(i)*cpliq + ldew_snow(i)*cpice + ENDIF + + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + CALL dewfraction (sigf(i),lai(i),sai(i),dewmx,& + ldew(i),ldew_rain(i),ldew_snow(i),fwet(i),fdry(i)) + CALL qsadv(tl(i),psrf,ei(i),deiDT(i),qsatl(i),qsatlDT(i)) + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! initial for fluxes profile +!----------------------------------------------------------------------- + + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) + +!----------------------------------------------------------------------- +! calculate layer average properties: height (htop_lay, hbot_lay), lsai_lay, ... +! !!NOTE: adjustment may needed for htop_lay/hbot_lay +!----------------------------------------------------------------------- + htop_lay(:) = 0 + hbot_lay(:) = 0 + lsai_lay(:) = 0 + fcover_lay(:) = 0 + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + htop_lay(clev) = htop_lay(clev) + htop(i) * fcover(i) + hbot_lay(clev) = hbot_lay(clev) + hbot(i) * fcover(i) + lsai_lay(clev) = lsai_lay(clev) + lsai(i) * fcover(i) + fcover_lay(clev) = fcover_lay(clev) + fcover(i) + ENDIF + ENDDO + + DO i = 1, nlay + IF (fcover_lay(i) > 0) THEN + htop_lay(i) = htop_lay(i) / fcover_lay(i) + hbot_lay(i) = hbot_lay(i) / fcover_lay(i) + lsai_lay(i) = lsai_lay(i) / fcover_lay(i) + ENDIF + ENDDO + + ! calculate fcover_lays +! 03/16/2020, yuan: determine to set fc=0 or fcover above for +! gaps between layers, 0 maybe more consistent + fcover_lays(0) = sum(fcover_lay(:)) + fcover_lays(1) = sum(fcover_lay(1:3)) + fcover_lays(2) = sum(fcover_lay(2:3)) + fcover_lays(3) = sum(fcover_lay(3:3)) + fcover_lays(:) = 0. + +!----------------------------------------------------------------------- +! scaling factor bee +!----------------------------------------------------------------------- +! 09/26/2017, yuan: NOTE! bee value, the default is 1 + bee = 1. + +!----------------------------------------------------------------------- +! calculate z0m and displa for PFTs +!----------------------------------------------------------------------- + DO i = ps, pe + IF (lsai(i) > 1.e-6) THEN + CALL cal_z0_displa(lsai(i), htop(i), 1., z0mpc(i), displa) + ELSE + z0mpc(i) = z0mg + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! calculate z0m and displa for layers +!----------------------------------------------------------------------- + + displa_lay (:) = 0. + displa_lays(:) = 0. + z0m_lay (:) = 0. + z0m_lays (:) = 0. + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + CALL cal_z0_displa(lsai_lay(i), htop_lay(i), 1., z0m_lay(i), displa_lay(i)) + CALL cal_z0_displa(lsai_lay(i), htop_lay(i), fcover_lay(i), z0m_lays(i), displa_lays(i)) + ENDIF + ENDDO + + ! ground + z0m_lays (0) = z0mg + displa_lays(0) = 0. + + ! 10/05/2017: robust check + WHERE (z0m_lays(:) < z0mg) z0m_lays(:) = z0mg + WHERE (z0m_lay (:) < z0mg) z0m_lay (:) = z0mg + + ! maximum assumption + z0m_lays(1) = maxval(z0m_lays(0:1)) + z0m_lays(2) = maxval(z0m_lays(0:2)) + z0m_lays(3) = maxval(z0m_lays(0:3)) + + displa_lays(1) = maxval(displa_lays(0:1)) + displa_lays(2) = maxval(displa_lays(0:2)) + displa_lays(3) = maxval(displa_lays(0:3)) + + ! roughness length and displacement height for sensible + ! and latent heat transfer + z0h_lays(:) = z0m_lays(:) + z0q_lays(:) = z0m_lays(:) + +!----------------------------------------------------------------------- +! calculate layer a_lay +!----------------------------------------------------------------------- + ! initialization + a_lay (:) = 0. + a_lay_i63(:) = 0. + a_lay_k71(:) = 0. + a_lay_g77(:) = 0. + a_lay_m97(:) = 0. + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + + ! mixing length and sqrt(drag coefficient) + lm = vonkar*(htop_lay(i) - displa_lay(i)) + + ! Raupach, 1992 + fai = 1. - exp(-0.5*lsai_lay(i)) + sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + + ! Inoue, 1963 + a_lay_i63(i) = htop_lay(i) * & + (Cd*lsai_lay(i)/(2.*htop_lay(i)*lm**2))**(1./3.) + + ! Kondo, 1971 + a_lay_k71(i) = htop_lay(i)/(htop_lay(i)-displa_lay(i))/ & + (vonkar/sqrtdragc) + + ! Goudriaan, 1977 + a_lay_g77(i) = (Cd*lsai_lay(i)*htop_lay(i)/lm)**0.5 + + ! Massman, 1997 + a_lay_m97(i) = Cd*lsai_lay(i) / (2.*sqrtdragc**2) + + a_lay(i) = a_lay_k71(i) + + displa_lay(i) = max(htop_lay(i)/2., displa_lay(i)) + + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! calculate layer info +! how may layers, top layer and bottom layer number +!----------------------------------------------------------------------- + + toplay = 0 + botlay = 0 + numlay = 0 + + DO i = nlay, 1, -1 + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + + ! to count the layer number + numlay = numlay + 1 + IF (toplay .eq. 0) THEN + ! set the top layer to current layer + toplay = i + ENDIF + + ! set this layer to be the bottom layer + botlay = i + + displa_lay(i) = max(displa_lay(i), hbot_lay(i)) + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! calculate transmittance of longwave radiation for each layer +! diffuse case +!----------------------------------------------------------------------- + + thermk_lay(:) = 0. + fshade_lay(:) = 0. + + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) + thermk_lay(clev) = thermk_lay(clev) + fshade(i) * thermk(i) + fshade_lay(clev) = fshade_lay(clev) + fshade(i) + ENDIF + ENDDO + + DO i = 1, nlay + IF (fshade_lay(i) > 0) THEN + thermk_lay(i) = thermk_lay(i) / fshade_lay(i) + ELSE + thermk_lay(i) = 1. + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! calculate the transfer matrix for long-wave radiation transfer +! direct case +! NOTE: don't need to calculate at each step +!----------------------------------------------------------------------- + + tdn(:,:) = 0. + tup(:,:) = 0. + + tdn(1,0) = 1. + tdn(2,0) = 1 - fshade_lay(1) + tdn(3,0) = 1 - fshade_lay(1) - fshade_lay(2) + fshade_lay(1)*fshade_lay(2) + tdn(4,0) = 1 - fshade_lay(1) - fshade_lay(2) - fshade_lay(3) & + + fshade_lay(1)*fshade_lay(2) & + + fshade_lay(1)*fshade_lay(3) & + + fshade_lay(2)*fshade_lay(3) & + - fshade_lay(1)*fshade_lay(2)*fshade_lay(3) + + tdn(2,1) = fshade_lay(1) + tdn(3,1) = (1 - fshade_lay(2))*fshade_lay(1) + tdn(4,1) = (1 - fshade_lay(2) - fshade_lay(3) + fshade_lay(2)*fshade_lay(3))*fshade_lay(1) + + tdn(3,2) = fshade_lay(2) + tdn(4,2) = (1 - fshade_lay(3))*fshade_lay(2) + tdn(4,3) = fshade_lay(3) + + tup(0,1) = fshade_lay(1) + tup(0,2) = (1 - fshade_lay(1))*fshade_lay(2) + tup(1,2) = fshade_lay(2) + + tup(0,3) = (1 - fshade_lay(1) - fshade_lay(2) + fshade_lay(1)*fshade_lay(2))*fshade_lay(3) + tup(1,3) = (1 - fshade_lay(2))*fshade_lay(3) + tup(2,3) = fshade_lay(3) + + tup(0,4) = tdn(4,0) + tup(1,4) = 1 - fshade_lay(2) - fshade_lay(3) + fshade_lay(2)*fshade_lay(3) + tup(2,4) = 1 - fshade_lay(3) + tup(3,4) = 1. + +!----------------------------------------------------------------------- +! calculate parameters for delta(Lv) for LW radiation transfer +!----------------------------------------------------------------------- + dLvpar(1) = 1. + dLvpar(2) = ( (1-fshade_lay(1)) + thermk_lay(1)*fshade_lay(1) )**2 + dLvpar(3) = ( tdn(3,0) & + + thermk_lay(2)*fshade_lay(2)*(1-fshade_lay(1)+thermk_lay(1)*fshade_lay(1)) & + + (1-fshade_lay(2))*thermk_lay(1)*fshade_lay(1) )**2 + +!----------------------------------------------------------------------- +! first guess for taf and qaf for each layer +! a large difference from previous schemes +!----------------------------------------------------------------------- + taf(:) = 0. + qaf(:) = 0. + + ! 05/02/2016: set taf/qaf according to layer number + IF (numlay .eq. 1) THEN + taf(toplay) = 0.5 * (tg + thm) + qaf(toplay) = 0.5 * (qm + qg ) + ENDIF + + IF (numlay .eq. 2) THEN + taf(botlay) = (2.*tg + thm)/3. + qaf(botlay) = (2.*qg + qm )/3. + taf(toplay) = (tg + 2.*thm)/3. + qaf(toplay) = (qg + 2.*qm )/3. + ENDIF + + IF (numlay .eq. 3) THEN + taf(1) = (3.*tg + thm)/4. + qaf(1) = (3.*qg + qm )/4. + taf(2) = (tg + thm )/2. + qaf(2) = (qg + qm )/2. + taf(3) = (tg + 3.*thm)/4. + qaf(3) = (qg + 3.*qm )/4. + ENDIF + +!----------------------------------------------------------------------- +! some environment variables +! how to calculate rsoil and what is its usage? +!----------------------------------------------------------------------- + pco2a = pco2m + tprcor = 44.6*273.16*psrf/1.013e5 + rsoil = 0. !respiration (mol m-2 s-1) +! rsoil = 1.22e-6*exp(308.56*(1./56.02-1./(tg-227.13))) +! rsoil = rstfac * 0.23 * 15. * 2.**((tg-273.16-10.)/10.) * 1.e-6 +! rsoil = 5.22 * 1.e-6 + rsoil = 0.22 * 1.e-6 + +! initialization and input values for Monin-Obukhov + ! have been set before + z0mv = z0m_lays(3); z0hv = z0m_lays(3); z0qv = z0m_lays(3) + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(toplay) + dqh = qm - qaf(toplay) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + + hu_ = hu; ht_ = ht; hq_ = hq; + + IF (forc_height_mode == 'absolute') THEN + + IF (hu <= htop_lay(toplay)+1) THEN + hu_ = htop_lay(toplay) + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of u less than htop+1, set it to htop+1.' + ENDIF + + IF (ht <= htop_lay(toplay)+1) THEN + ht_ = htop_lay(toplay) + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of t less than htop+1, set it to htop+1.' + ENDIF + + IF (hq <= htop_lay(toplay)+1) THEN + hq_ = htop_lay(toplay) + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of q less than htop+1, set it to htop+1.' + ENDIF + + ELSE ! relative height + hu_ = htop_lay(toplay) + hu + ht_ = htop_lay(toplay) + ht + hq_ = htop_lay(toplay) + hq + ENDIF + + zldis = hu_ - displa_lays(3) + + IF(zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL CoLM_stop() + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mv,um,obu) + +! ====================================================================== +! BEGIN stability iteration +! ====================================================================== + + DO WHILE (it .le. itmax) + + tlbef = tl + + del2 = del + dele2 = dele + + DO i = ps, pe + IF (tl(i) > tfrz) THEN + htvpl(i) = hvap + ELSE + htvpl(i) = hsub + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! Aerodynamical resistances +!----------------------------------------------------------------------- +! Evaluate stability-dependent variables using moz from prior iteration + + IF (DEF_USE_CBL_HEIGHT) THEN + CALL moninobukm_leddy(hu_,ht_,hq_,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & + displa_lay(toplay),z0m_lay(toplay),hpbl,ustar,fh2m,fq2m, & + htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) + ELSE + CALL moninobukm(hu_,ht_,hq_,displa_lays(toplay),z0mv,z0hv,z0qv,obu,um, & + displa_lay(toplay),z0m_lay(toplay),ustar,fh2m,fq2m, & + htop_lay(toplay),fmtop,fm,fh,fq,fht,fqt,phih) + ENDIF + +! Aerodynamic resistance + ! 09/16/2017: + ! note that for ram, it is the resistance from Href to z0mv+displa + ! however, for rah and raw is only from Href to canopy effective + ! exchange height. + ! so rah/raw is not comparable with that of 1D case + ram = 1./(ustar*ustar/um) + + ! 05/02/2016: calculate resistance from the top layer (effective exchange + ! height) to reference height + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + +! update roughness length for sensible/latent heat + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + z0h_lays(0) = z0hg + z0q_lays(0) = z0qg + + z0h_lays(1) = maxval(z0h_lays(0:1)) + z0h_lays(2) = maxval(z0h_lays(0:2)) + z0h_lays(3) = maxval(z0h_lays(0:3)) + + z0q_lays(:) = z0h_lays(:) + z0hv = z0h_lays(3) + z0qv = z0q_lays(3) + +! ...................................................................... +! new method to calculate rd and ueffect +! the kernel part of 3d model +! ...................................................................... + + ! initialization + rd(:) = 0. + upplay = 0 + + ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) + ! need to update each time as obu changed after each iteration + utop = ustar/vonkar * fmtop + ktop = vonkar * (htop_lay(toplay)-displa_lays(toplay)) * ustar / phih + + ! start layer loop + DO i = toplay, 1, -1 + + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + + IF (i .eq. toplay) THEN + utop_lay(i) = utop + ktop_lay(i) = ktop + ELSE + ! calculate utop of this layer + utop_lay(i) = uprofile(ubot_lay(upplay), fcover_lays(upplay), bee, 0., & + z0mg, hbot_lay(upplay), htop_lay(i), htop_lay(i)) + + ! calculate ktop of this layer + ktop_lay(i) = kprofile(kbot_lay(upplay), fcover_lays(upplay), bee, 0., & + displa_lays(toplay)/htop_lay(toplay), & + hbot_lay(upplay), htop_lay(i), obug, ustarg, htop_lay(i)) + + ! areodynamic resistance between this layer top and above layer bottom + ! 03/15/2020, yuan: vertical gaps between layers + ! fc = fcover_lays(upplay) or just 0? + rd(upplay) = rd(upplay) + frd(kbot_lay(upplay), hbot_lay(upplay), htop_lay(i), & + hbot_lay(upplay), htop_lay(i), & + displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(upplay)) + + ENDIF + + ! for robust check + hbot_lay(i) = max(hbot_lay(i), displa_lays(i-1)+z0m_lays(i-1)) + + ! wind speed at layer bottom + ubot_lay(i) = uprofile(utop_lay(i), fcover_lay(i), bee, a_lay(i), & + z0mg, htop_lay(i), hbot_lay(i), hbot_lay(i)) + + IF (it == 1) THEN + ueff_lay_norm(i) = ueffect(1., htop_lay(i), hbot_lay(i), & + z0mg, a_lay(i), bee, fcover_lay(i)) + ENDIF + ueff_lay(i) = utop_lay(i)*ueff_lay_norm(i) + + ! normalized eddy coefficient (K) at layer bottom + kbot_lay(i) = kprofile(ktop_lay(i), fcover_lay(i), bee, a_lay(i), & + displa_lays(toplay)/htop_lay(toplay), & + htop_lay(i), hbot_lay(i), obug, ustarg, hbot_lay(i)) + + ! areodynamic resistance from effective fluxes exchange height of + ! of this layer to the top of this layer + IF (upplay > 0) THEN + rd(upplay) = rd(upplay) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & + htop_lay(i), displa_lay(i)+z0m_lay(i), & + displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, a_lay(i), bee, fcover_lay(i)) + ENDIF + + rd(i) = rd(i) + frd(ktop_lay(i), htop_lay(i), hbot_lay(i), & + displa_lay(i)+z0m_lay(i), max(z0qg,hbot_lay(i)), & + displa_lays(toplay)/htop_lay(toplay), z0h_g, obug, ustarg, & + z0mg, a_lay(i), bee, fcover_lay(i)) + + upplay = i + + ENDIF + ENDDO + +! ...................................................................... +! areodynamic resistance between ground and the upper layer bottom +! ...................................................................... + + ! uncomment the below when the upper codes change to hbot_lay + !rd(botlay) = rd(botlay) + kintegral(kbot_lay(botlay), fcover_lays(botlay), bee, 0., & + ! z0mg, displa_lays(toplay)/htop_lay(toplay), & + ! hbot_lay(botlay), z0qg, obug, ustarg, hbot_lay(botlay), z0qg ) + + rd(botlay) = rd(botlay) + frd(kbot_lay(botlay), hbot_lay(botlay), z0qg, & + hbot_lay(botlay), z0qg, displa_lays(toplay)/htop_lay(toplay), & + z0h_g, obug, ustarg, z0mg, 0., bee, fcover_lays(botlay)) + +! ...................................................................... +! Bulk boundary layer resistance of leaves +! ...................................................................... + rb(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + cf = 0.01*sqrtdi(i)*sqrt(ueff_lay(clev)) + rb(i) = 1./cf + ENDIF + ENDDO + + ! 10/01/2017, back to 1D case + IF (rb_opt == 1) THEN + uaf = ustar + cf = 0.01*sqrtdi(2)/sqrt(uaf) + rb(:) = 1/(cf*uaf) + ENDIF + +! rd = 1./(csoilc*uaf) ! BATS legacy +! w = exp(-0.5*(lai+sai)) ! Dickinson's modification : +! csoilc = ( 1.-w + w*um/uaf)/rah ! "rah" here is the resistance over +! rd = 1./(csoilc*uaf) ! bare ground fraction + + ! 10/01/2017, back to 1D case + IF (rd_opt == 1 ) THEN +! modified by Xubin Zeng's suggestion at 08-07-2002 + uaf = ustar + w = exp(-(lai(2)+sai(2))) + csoilcn = (vonkar/(0.13*(z0mg*uaf/1.5e-5)**0.45))*w + csoilc*(1.-w) + rd(:) = 1./(csoilcn*uaf) + ENDIF + +!----------------------------------------------------------------------- +! stomatal resistances +!----------------------------------------------------------------------- + + DO i = ps, pe + p = pftclass(i) + IF(fcover(i)>0 .and. lai(i)>0.001) THEN + + rbsun = rb(i) / laisun(i) + rbsha = rb(i) / laisha(i) + + clev = canlay(i) + eah = qaf(clev) * psrf / ( 0.622 + 0.378 * qaf(clev) ) !pa + + IF (DEF_USE_PLANTHYDRAULICS) THEN + rstfacsun(i) = 1. + rstfacsha(i) = 1. + ENDIF + +! note: calculate resistance for sunlit/shaded leaves +!----------------------------------------------------------------------- + CALL stomata ( vmax25(i) ,effcon(i) ,c3c4(i) ,slti(i) ,hlti(i) ,& + shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& + g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(i) ,tl(i) ,parsun(i) ,& +!Ozone stress variables + o3coefv_sun(i), o3coefg_sun(i),& +!End ozone stress variables + lambda(i), & + rbsun ,raw ,rstfacsun(i),cintsun(:,i),& + assimsun(i),respcsun(i),rssun(i) ) + + CALL stomata ( vmax25(i) ,effcon(i) ,c3c4(i) ,slti(i) ,hlti(i) ,& + shti(i) ,hhti(i) ,trda(i) ,trdm(i) ,trop(i) ,& + g1(i) ,g0(i) ,gradm(i) ,binter(i) ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(i) ,tl(i) ,parsha(i) ,& +!Ozone stress variables + o3coefv_sha(i), o3coefg_sha(i),& +!End ozone stress variables +!WUE stomata model parameter + lambda(i) ,& +!WUE stomata model parameter + rbsha ,raw ,rstfacsha(i),cintsha(:,i),& + assimsha(i),respcsha(i),rssha(i) ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + + gs0sun(i) = min( 1.e6, 1./(rssun(i)*tl(i)/tprcor) )/ laisun(i) * 1.e6 * o3coefg_sun(i) + gs0sha(i) = min( 1.e6, 1./(rssha(i)*tl(i)/tprcor) )/ laisha(i) * 1.e6 * o3coefg_sha(i) + + CALL PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& + dz_soi ,rootfr(:,i) ,psrf ,qsatl(i) ,qaf(clev) ,& + tl(i) ,rbsun ,rss ,raw ,sum(rd(1:clev)),& + rstfacsun(i) ,rstfacsha(i) ,cintsun(:,i) ,cintsha(:,i) ,laisun(i) ,& + laisha(i) ,rhoair ,fwet(i) ,sai(i) ,kmax_sun(i) ,& + kmax_sha(i) ,kmax_xyl(i) ,kmax_root(i) ,psi50_sun(i) ,psi50_sha(i) ,& + psi50_xyl(i) ,psi50_root(i),htop(i) ,ck(i) ,smp ,& + hk ,hksati ,vegwp(:,i) ,etrsun(i) ,etrsha(i) ,& + rootflux(:,i),qg ,qm ,gs0sun(i) ,gs0sha(i) ,& + k_soil_root ,k_ax_root ,gssun(i) ,gssha(i) ) + + etr(i) = etrsun(i) + etrsha(i) + gssun(i) = gssun(i) * laisun(i) * 1.e-6 + gssha(i) = gssha(i) * laisha(i) * 1.e-6 + + CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsun(i), psrf, rstfacsun(i), & + rb(i), gssun(i), effcon(i), vmax25(i), c3c4(i), gradm(i), trop(i), slti(i), hlti(i), & + shti(i), hhti(i), trda(i), trdm(i), cintsun(:,i), assimsun(i), respcsun(i)) + + CALL update_photosyn(tl(i), po2m, pco2m, pco2a, parsha(i), psrf, rstfacsha(i), & + rb(i), gssha(i), effcon(i), vmax25(i), c3c4(i), gradm(i), trop(i), slti(i), hlti(i), & + shti(i), hhti(i), trda(i), trdm(i), cintsha(:,i), assimsha(i), respcsha(i)) + + ! leaf scale stomata resistance + rssun(i) = tprcor / tl(i) / gssun(i) + rssha(i) = tprcor / tl(i) / gssha(i) + + ENDIF + + ELSE + rssun(i) = 2.e4; assimsun(i) = 0.; respcsun(i) = 0. + rssha(i) = 2.e4; assimsha(i) = 0.; respcsha(i) = 0. + IF (DEF_USE_PLANTHYDRAULICS) THEN + etr(i) = 0. + rootflux(:,i) = 0. + ENDIF + ENDIF + ENDDO + +! above stomatal resistances are for the canopy, the stomatal resistances +! and the "rb" in the following calculations are the average for single leaf. thus, + rssun = rssun * laisun + rssha = rssha * laisha + +!----------------------------------------------------------------------- +! dimensional and non-dimensional sensible and latent heat conductances +! for canopy and soil flux calculations. +!----------------------------------------------------------------------- + + cfh(:) = 0. + cfw(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + + clev = canlay(i) + delta(i) = 0.0 + IF(qsatl(i)-qaf(clev) .gt. 0.) delta(i) = 1.0 + + cfh(i) = lsai(i) / rb(i) + +! note: combine sunlit and shaded leaves +!----------------------------------------------------------------------- + cfw(i) = (1.-delta(i)*(1.-fwet(i)))*lsai(i)/rb(i) + & + (1.-fwet(i))*delta(i)* & + ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) + ENDIF + ENDDO + + ! initialization + cah(:) = 0. + caw(:) = 0. + cgh(:) = 0. + cgw(:) = 0. + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + IF (i == toplay) THEN + cah(i) = 1. / rah + caw(i) = 1. / raw + ELSE + cah(i) = 1. / rd(i+1) + caw(i) = 1. / rd(i+1) + ENDIF + + cgh(i) = 1. / rd(i) + IF (i == botlay) THEN + IF (qg < qaf(botlay)) THEN + cgw(i) = 1. / rd(i) !dew case. no soil resistance + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw(i) = rss/ rd(i) + ELSE + cgw(i) = 1. / (rd(i) + rss) + ENDIF + ENDIF + ELSE + cgw(i) = 1. / rd(i) + ENDIF + ENDIF + ENDDO + + ! calculate wtshi, wtsqi + wtshi(:) = cah(:) + cgh(:) + wtsqi(:) = caw(:) + cgw(:) + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + wtshi(clev) = wtshi(clev) + fcover(i)*cfh(i) + wtsqi(clev) = wtsqi(clev) + fcover(i)*cfw(i) + ENDIF + ENDDO + + DO i = 1, nlay + IF (fcover_lay(i)>0 .and. lsai_lay(i)>0) THEN + wtshi(i) = 1./wtshi(i) + wtsqi(i) = 1./wtsqi(i) + ENDIF + ENDDO + + wah(:) = cah(:) * wtshi(:) + wgh(:) = cgh(:) * wtshi(:) + + waq(:) = caw(:) * wtsqi(:) + wgq(:) = cgw(:) * wtsqi(:) + + ! calculate wlh, wlhl, wlq, wlql + wlhl(:) = 0. + wlql(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + + wlh(i) = cfh(i) * wtshi(clev) * fcover(i) + wlhl(clev) = wlhl(clev) + wlh(i)*tl(i) + + wlq(i) = cfw(i) * wtsqi(clev) * fcover(i) + wlql(clev) = wlql(clev) + wlq(i)*qsatl(i) + ENDIF + ENDDO + + ! to solve taf(:) and qaf(:) + IF (numlay .eq. 1) THEN + + taf(toplay) = wah(toplay)*thm + wgh(toplay)*tg + wlhl(toplay) + qaf(toplay) = waq(toplay)*qm + wgq(toplay)*qg + wlql(toplay) + fact = 1. + facq = 1. + + ENDIF + + IF (numlay .eq. 2) THEN + + tmpw1 = wgh(botlay)*tg + wlhl(botlay) + fact = 1. - wgh(toplay)*wah(botlay) + taf(toplay) = ( wah(toplay)*thm + wgh(toplay)*tmpw1 + wlhl(toplay) ) / fact + + tmpw1 = wgq(botlay)*qg + wlql(botlay) + facq = 1. - wgq(toplay)*waq(botlay) + qaf(toplay) = ( waq(toplay)*qm + wgq(toplay)*tmpw1 + wlql(toplay) ) / facq + + taf(botlay) = wah(botlay)*taf(toplay) + wgh(botlay)*tg + wlhl(botlay) + qaf(botlay) = waq(botlay)*qaf(toplay) + wgq(botlay)*qg + wlql(botlay) + + ENDIF + + IF (numlay .eq. 3) THEN + + tmpw1 = wah(3)*thm + wlhl(3) + tmpw2 = wgh(1)*tg + wlhl(1) + fact = 1. - wah(2)*wgh(3) - wgh(2)*wah(1) + taf(2) = ( wah(2)*tmpw1 + wgh(2)*tmpw2 + wlhl(2) ) / fact + + tmpw1 = waq(3)*qm + wlql(3) + tmpw2 = wgq(1)*qg + wlql(1) + facq = 1. - waq(2)*wgq(3) - wgq(2)*waq(1) + qaf(2) = ( waq(2)*tmpw1 + wgq(2)*tmpw2 + wlql(2) ) / facq + + taf(1) = wah(1)*taf(2) + wgh(1)*tg + wlhl(1) + qaf(1) = waq(1)*qaf(2) + wgq(1)*qg + wlql(1) + + taf(3) = wah(3)*thm + wgh(3)*taf(2) + wlhl(3) + qaf(3) = waq(3)*qm + wgq(3)*qaf(2) + wlql(3) + + ENDIF + +!----------------------------------------------------------------------- +! IR radiation, sensible and latent heat fluxes and their derivatives +!----------------------------------------------------------------------- +! the partial derivatives of areodynamical resistance are ignored +! which cannot be determined analytically + +! calculate L for each canopy layer + L(:) = 0. + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + ! according to absorption = emissivity, fcover -> fshade + L(clev) = L(clev) + fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 + ENDIF + ENDDO + +! calculate Ltd + Ltd(:) = 0. + Ltd(3) = thermk_lay(3) * tdn(4,3) * frl + Ltd(2) = thermk_lay(2) * ( tdn(4,2)*frl + tdn(3,2)*(Ltd(3) + L(3)) ) + Ltd(1) = thermk_lay(1) * ( tdn(4,1)*frl + tdn(3,1)*(Ltd(3) + L(3)) + & + tdn(2,1)*(Ltd(2) + L(2)) ) + +! calculate Ld = Ltd + L + Ld(0) = 0. + Ld(4) = frl + Ld(1:3) = Ltd + L + +! calculate Lin = Ld * tdn + Lin(:) = matmul(Ld(:), tdn(:,:)) + +! calculate Lg = (1-emg)*dlrad + emg*stefnc*tg**4 +! dlrad = Lin(0) +IF (.not.DEF_SPLIT_SOILSNOW) THEN + Lg = (1 - emg)*Lin(0) + emg*stefnc*tg**4 +ELSE + Lg = (1 - emg)*Lin(0) & + + (1.-fsno)*emg*stefnc*t_soil**4 & + + fsno*emg*stefnc*t_snow**4 +ENDIF + +! calculate Ltu + Ltu(1) = thermk_lay(1) * tup(0,1) * Lg + Ltu(2) = thermk_lay(2) * ( tup(0,2)*Lg + tup(1,2)*(Ltu(1) + L(1)) ) + Ltu(3) = thermk_lay(3) * ( tup(0,3)*Lg + tup(1,3)*(Ltu(1) + L(1)) + & + tup(2,3)*(Ltu(2) + L(2)) ) + +! calculate Lu = Ltu + L + Lu(0) = Lg + Lu(4) = 0. + Lu(1:3) = Ltu + L + +! calculate Lin = Lin + Lu*tup + Lin(:) = Lin(:) + matmul(Lu(:), tup(:,:)) + +! calculate Lv + Lv(:) = 0. + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) + Lv(i) = fshade(i)/fshade_lay(clev) * (1-thermk(i)) * Lin(clev) / fcover(i) & + - 2. * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**4 / fcover(i) + ENDIF + ENDDO + +! calculate delta(Lv) + dLv(:) = 0. + DO i = ps, pe + IF (fshade(i)>0 .and. canlay(i)>0) THEN + clev = canlay(i) + dLv(i) = (4.*dLvpar(clev)*(1-emg)*fshade(i)*(1-thermk(i)) - 8.) & + * fshade(i) * (1-thermk(i)) * stefnc * tl(i)**3 / fcover(i) + ENDIF + ENDDO + +!----------------------------------------------------------------------- + + irab(:) = Lv(:) + dirab_dtl(:) = dLv(:) + + DO i = ps, pe + + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + + clev = canlay(i) + fac(i) = 1. - thermk(i) + +! sensible heat fluxes and their derivatives + fsenl(i) = rhoair * cpair * cfh(i) * (tl(i) - taf(clev)) + + ! 09/25/2017: re-written, check it carefully + ! When numlay<3, no matter how to calculate, /fact is consistent + IF (numlay < 3 .or. clev == 2) THEN + fsenl_dtl(i) = rhoair * cpair * cfh(i) * (1. - wlh(i)/fact) + ELSE + IF (clev == 1) THEN + fsenl_dtl(i) = rhoair * cpair * cfh(i) & + !* (1. - (1.-wah(2)*wgh(3))*wlh(i)/fact) or + * (1. - wah(1)*wgh(2)*wlh(i)/fact - wlh(i)) + ENDIF + IF (clev == 3) THEN + fsenl_dtl(i) = rhoair * cpair * cfh(i) & + !* (1. - (1.-wgh(2)*wah(1))*wlh(i)/fact) or + * (1. - wgh(3)*wah(2)*wlh(i)/fact - wlh(i)) + ENDIF + ENDIF + +! latent heat fluxes and their derivatives + + etr(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + * ( qsatl(i) - qaf(clev) ) + + ! 09/25/2017: re-written + IF (numlay < 3 .or. clev == 2) THEN + etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + * (1. - wlq(i)/facq)*qsatlDT(i) + ELSE + IF (clev == 1) THEN + etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + !* (1. - (1.-waq(2)*wgq(3))*wlq(i)/facq)*qsatlDT(i) or + * (1. - waq(1)*wgq(2)*wlq(i)/facq - wlq(i))*qsatlDT(i) + ENDIF + IF (clev == 3) THEN + etr_dtl(i) = rhoair * (1.-fwet(i)) * delta(i) & + * ( laisun(i)/(rb(i)+rssun(i)) + laisha(i)/(rb(i)+rssha(i)) ) & + !* (1. - (1.-wgq(2)*waq(1))*wlq(i)/facq)*qsatlDT(i) or + * (1. - wgq(3)*waq(2)*wlq(i)/facq - wlq(i))*qsatlDT(i) + ENDIF + ENDIF + + IF (.not. DEF_USE_PLANTHYDRAULICS) THEN + IF(etr(i).ge.etrc(i))THEN + etr(i) = etrc(i) + etr_dtl(i) = 0. + ENDIF + ENDIF + + evplwet(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + * ( qsatl(i) - qaf(clev) ) + + ! 09/25/2017: re-written + IF (numlay < 3 .or. clev == 2) THEN + evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + * (1. - wlq(i)/facq)*qsatlDT(i) + ELSE + IF (clev == 1) THEN + evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + !* (1. - (1-waq(2)*wgq(3))*wlq(i)/facq)*qsatlDT(i) or + * (1. - waq(1)*wgq(2)*wlq(i)/facq - wlq(i))*qsatlDT(i) + ENDIF + IF (clev == 3) THEN + evplwet_dtl(i) = rhoair * (1.-delta(i)*(1.-fwet(i))) * lsai(i)/rb(i) & + !* (1. - (1.-wgq(2)*waq(1))*wlq(i)/facq)*qsatlDT(i) or + * (1. - wgq(3)*waq(2)*wlq(i)/facq - wlq(i))*qsatlDT(i) + ENDIF + ENDIF + + ! 03/02/2018: convert evplwet from fc to whole area + ! because ldew right now is for the whole area + ! 09/05/2019: back to fc area + IF(evplwet(i).ge.ldew(i)/deltim)THEN + evplwet(i) = ldew(i)/deltim + evplwet_dtl(i) = 0. + ENDIF + + fevpl(i) = etr(i) + evplwet(i) + fevpl_dtl(i) = etr_dtl(i) + evplwet_dtl(i) + + erre(i) = 0. + fevpl_noadj(i) = fevpl(i) + IF ( fevpl(i)*fevpl_bef(i) < 0. ) THEN + erre(i) = -0.9*fevpl(i) + fevpl(i) = 0.1*fevpl(i) + ENDIF + +!----------------------------------------------------------------------- +! difference of temperatures by quasi-newton-raphson method for the non-linear system equations +! MARK#dtl +!----------------------------------------------------------------------- + + dtl(it,i) = (sabv(i) + irab(i) - fsenl(i) - hvap*fevpl(i) & + + cpliq*qintr_rain(i)*(t_precip-tl(i)) & + + cpice*qintr_snow(i)*(t_precip-tl(i))) & + / (clai(i)/deltim - dirab_dtl(i) + fsenl_dtl(i) + hvap*fevpl_dtl(i) & + + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) + + dtl_noadj(i) = dtl(it,i) + + ! check magnitude of change in leaf temperature limit to maximum allowed value + + IF (it .le. itmax) THEN + + ! put brakes on large temperature excursions + IF(abs(dtl(it,i)).gt.delmax)THEN + dtl(it,i) = delmax*dtl(it,i)/abs(dtl(it,i)) + ENDIF + + ! NOTE: could be a bug if dtl*dtl==0, changed from lt->le + IF((it.ge.2) .and. (dtl(it-1,i)*dtl(it,i).le.0.))THEN + dtl(it,i) = 0.5*(dtl(it-1,i) + dtl(it,i)) + ENDIF + + ENDIF + + tl(i) = tlbef(i) + dtl(it,i) + +!----------------------------------------------------------------------- +! square roots differences of temperatures and fluxes for USE as the condition of convergences +!----------------------------------------------------------------------- + + del(i) = sqrt( dtl(it,i)*dtl(it,i) ) + dele(i) = dtl(it,i) * dtl(it,i) * & + ( dirab_dtl(i)**2 + fsenl_dtl(i)**2 + (hvap*fevpl_dtl(i))**2 ) + dele(i) = sqrt(dele(i)) + +!----------------------------------------------------------------------- +! saturated vapor pressures and canopy air temperature, canopy air humidity +!----------------------------------------------------------------------- +! Recalculate leaf saturated vapor pressure (ei_)for updated leaf temperature +! and adjust specific humidity (qsatl_) proportionately + CALL qsadv(tl(i),psrf,ei(i),deiDT(i),qsatl(i),qsatlDT(i)) + + ENDIF + ENDDO !END pft loop + +! update vegetation/ground surface temperature, canopy air temperature, +! canopy air humidity + + ! calculate wlhl, wlql + wlhl(:) = 0. + wlql(:) = 0. + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + clev = canlay(i) + wlhl(clev) = wlhl(clev) + wlh(i)*tl(i) + wlql(clev) = wlql(clev) + wlq(i)*qsatl(i) + ENDIF + ENDDO + + IF (numlay .eq. 1) THEN + + taf(toplay) = wah(toplay)*thm + wgh(toplay)*tg + wlhl(toplay) + qaf(toplay) = waq(toplay)*qm + wgq(toplay)*qg + wlql(toplay) + fact = 1. + facq = 1. + + ENDIF + + IF (numlay .eq. 2) THEN + + tmpw1 = wgh(botlay)*tg + wlhl(botlay) + fact = 1. - wgh(toplay)*wah(botlay) + taf(toplay) = (wah(toplay)*thm + wgh(toplay)*tmpw1 + wlhl(toplay)) / fact + + tmpw1 = wgq(botlay)*qg + wlql(botlay) + facq = 1. - wgq(toplay)*waq(botlay) + qaf(toplay) = (waq(toplay)*qm + wgq(toplay)*tmpw1 + wlql(toplay)) / facq + + taf(botlay) = wah(botlay)*taf(toplay) + wgh(botlay)*tg + wlhl(botlay) + qaf(botlay) = waq(botlay)*qaf(toplay) + wgq(botlay)*qg + wlql(botlay) + + ENDIF + + IF (numlay .eq. 3) THEN + + tmpw1 = wah(3)*thm + wlhl(3) + tmpw2 = wgh(1)*tg + wlhl(1) + fact = 1. - wah(2)*wgh(3) - wgh(2)*wah(1) + taf(2) = (wah(2)*tmpw1 + wgh(2)*tmpw2 + wlhl(2)) / fact + + tmpw1 = waq(3)*qm + wlql(3) + tmpw2 = wgq(1)*qg + wlql(1) + facq = 1. - waq(2)*wgq(3) - wgq(2)*waq(1) + qaf(2) = (waq(2)*tmpw1 + wgq(2)*tmpw2 + wlql(2)) / facq + + taf(1) = wah(1)*taf(2) + wgh(1)*tg + wlhl(1) + qaf(1) = waq(1)*qaf(2) + wgq(1)*qg + wlql(1) + + taf(3) = wah(3)*thm + wgh(3)*taf(2) + wlhl(3) + qaf(3) = waq(3)*qm + wgq(3)*qaf(2) + wlql(3) + + ENDIF + +! update co2 partial pressure within canopy air + ! 05/02/2016: may have some problem with gdh2o, however, + ! this variable seems never used here. Different height + ! level vegetation should have different gdh2o, i.e., + ! different rd(layer) values. + gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 + + IF (DEF_RSS_SCHEME .eq. 4) THEN + gdh2o = rss/rd(botlay) * tprcor/thm !mol m-2 s-1 + ELSE + gdh2o = 1.0/(rd(botlay)+rss) * tprcor/thm !mol m-2 s-1 + ENDIF + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + sum(fcover*(assimsun + assimsha - respcsun - respcsha - rsoil)) + +!----------------------------------------------------------------------- +! Update monin-obukhov length and wind speed including the stability effect +!----------------------------------------------------------------------- + + dth = thm - taf(toplay) + dqh = qm - qaf(toplay) + + tstar = vonkar/(fh-fht)*dth + qstar = vonkar/(fq-fqt)*dqh + + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF(zeta .ge. 0.)THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF(zeta .ge. 0.)THEN + um = max(ur,.1) + ELSE + IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18 + zii = max(5.*hu_,hpbl) + ENDIF !//TODO: Shaofeng, 2023.05.18 + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF(obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF(nmozsgn .ge. 4) obu = zldis/(-0.01) + obuold = obu + +!----------------------------------------------------------------------- +! Test for convergence +!----------------------------------------------------------------------- + + it = it+1 + + IF(it .gt. itmin) THEN + fevpl_bef = fevpl + det = maxval(max(del,del2)) + ! 10/03/2017, yuan: possible bugs here, solution: + ! define dee, change del => dee + dee = maxval(max(dele,dele2)) + IF(det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF + + ENDDO + +! ====================================================================== +! END stability iteration +! ====================================================================== + + IF(DEF_USE_OZONESTRESS)THEN + DO i = ps, pe + p = pftclass(i) + CALL CalcOzoneStress(o3coefv_sun(i),o3coefg_sun(i),forc_ozone,psrf,th,ram,& + rssun(i),rb(i),lai(i),lai_old(i),p,o3uptakesun(i),sabv(i),deltim) + CALL CalcOzoneStress(o3coefv_sha(i),o3coefg_sha(i),forc_ozone,psrf,th,ram,& + rssha(i),rb(i),lai(i),lai_old(i),p,o3uptakesha(i),sabv(i),deltim) + lai_old(i) = lai(i) + assimsun(i) = assimsun(i) * o3coefv_sun(i) + assimsha(i) = assimsha(i) * o3coefv_sha(i) +! rssun (i) = rssun (i) / o3coefg_sun(i) +! rssha (i) = rssha (i) / o3coefg_sha(i) + ENDDO + ELSE + DO i = ps, pe + o3coefv_sun(i) = 1.0_r8 + o3coefg_sun(i) = 1.0_r8 + o3coefv_sha(i) = 1.0_r8 + o3coefg_sha(i) = 1.0_r8 + ENDDO + ENDIF + + z0m = z0mv + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! canopy fluxes and total assimilation and respiration + + DO i = ps, pe + IF (fcover(i)>0 .and. lsai(i)>1.e-6) THEN + + IF(lai(i) .gt. 0.001) THEN + rst(i) = 1./(laisun(i)/rssun(i) + laisha(i)/rssha(i)) + ELSE + rssun(i) = 2.0e4 ; rssha(i) = 2.0e4 + assimsun(i) = 0. ; assimsha(i) = 0. + respcsun(i) = 0. ; respcsha(i) = 0. + rst(i) = 2.0e4 + ENDIF + assim(i) = assimsun(i) + assimsha(i) + respc(i) = respcsun(i) + respcsha(i) + rsoil + +! canopy fluxes and total assimilation and respiration + fsenl(i) = fsenl(i) + fsenl_dtl(i)*dtl(it-1,i) & + ! add the imbalanced energy below due to T adjustment to sensible heat + + (dtl_noadj(i)-dtl(it-1,i)) * (clai(i)/deltim - dirab_dtl(i) & + + fsenl_dtl(i) + hvap*fevpl_dtl(i) & + + cpliq*qintr_rain(i) + cpice*qintr_snow(i)) & + ! add the imbalanced energy below due to q adjustment to sensible heat + + hvap*erre(i) + + etr0(i) = etr(i) + etr (i) = etr(i) + etr_dtl(i)*dtl(it-1,i) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + !TODO@yuan: rootflux may not be consistent with etr, + ! water imbalance could happen. + IF(abs(etr0(i)) .ge. 1.e-15)THEN + rootflux(:,i) = rootflux(:,i) * etr(i) / etr0(i) + ELSE + rootflux(:,i) = rootflux(:,i) + dz_soi / sum(dz_soi) * etr_dtl(i)* dtl(it-1,i) + ENDIF + + !NOTE: temporal solution to make etr and rootflux consistent. + !TODO: need double check + sumrootflux = sum(rootflux(:,i), rootflux(:,i)>0.) + IF (abs(sumrootflux) > 0.) THEN + rootflux(:,i) = max(rootflux(:,i),0.) * (etr(i)/sumrootflux) + ELSE + rootflux(:,i) = etr(i)*rootfr(:,i) + ENDIF + ENDIF + + evplwet(i) = evplwet(i) + evplwet_dtl(i)*dtl(it-1,i) + fevpl (i) = fevpl_noadj(i) + fevpl (i) = fevpl(i) + fevpl_dtl(i)*dtl(it-1,i) + + elwmax = ldew(i)/deltim + + ! 03/02/2018, yuan: convert fc to whole area + ! because ldew now is for the whole area + ! may need to change to canopy covered area + ! 09/14/2019, yuan: change back to canopy area + elwdif = max(0., evplwet(i)-elwmax) + evplwet(i) = min(evplwet(i), elwmax) + + fevpl(i) = fevpl(i) - elwdif + fsenl(i) = fsenl(i) + hvap*elwdif + + ! precipitation sensible heat from canopy + hprl (i) = cpliq*qintr_rain(i)*(t_precip-tl(i)) + cpice*qintr_snow(i)*(t_precip-tl(i)) + + ! vegetation heat change + dheatl(i) = clai(i)/deltim*dtl(it-1,i) + +!----------------------------------------------------------------------- +! Update dew accumulation (kg/m2) +!----------------------------------------------------------------------- + IF (DEF_Interception_scheme .eq. 1) THEN !colm2014 + + ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl(i) > tfrz) THEN + qevpl(i) = max (evplwet(i), 0.) + qdewl(i) = abs (min (evplwet(i), 0.) ) + qsubl(i) = 0. + qfrol(i) = 0. + + IF (qevpl(i) > ldew_rain(i)/deltim) THEN + qsubl(i) = qevpl(i) - ldew_rain(i)/deltim + qevpl(i) = ldew_rain(i)/deltim + ENDIF + ELSE + qevpl(i) = 0. + qdewl(i) = 0. + qsubl(i) = max (evplwet(i), 0.) + qfrol(i) = abs (min (evplwet(i), 0.) ) + + IF (qsubl(i) > ldew_snow(i)/deltim) THEN + qevpl(i) = qsubl(i) - ldew_snow(i)/deltim + qsubl(i) = ldew_snow(i)/deltim + ENDIF + ENDIF + + ldew_rain(i) = ldew_rain(i) + (qdewl(i)-qevpl(i))*deltim + ldew_snow(i) = ldew_snow(i) + (qfrol(i)-qsubl(i))*deltim + + ldew(i) = ldew_rain(i) + ldew_snow(i) + ENDIF + + ELSEIF (DEF_Interception_scheme .eq. 2) THEN!CLM4.5 + ldew(i) = max(0., ldew(i)-evplwet(i)*deltim) + ELSEIF (DEF_Interception_scheme .eq. 3) THEN !CLM5 + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 4) THEN !Noah-MP + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 5) THEN !MATSIRO + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 6) THEN !VIC + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 7) THEN !JULES + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSEIF (DEF_Interception_scheme .eq. 8) THEN !CoLM202x + IF (ldew_rain(i) .gt. evplwet(i)*deltim) THEN + ldew_rain(i) = ldew_rain(i)-evplwet(i)*deltim + ldew_snow(i) = ldew_snow(i) + ldew(i)=ldew_rain(i)+ldew_snow(i) + ELSE + ldew_rain(i) = 0.0 + ldew_snow(i) = max(0., ldew(i)-evplwet(i)*deltim) + ldew (i) = ldew_snow(i) + ENDIF + ELSE + CALL CoLM_stop() + ENDIF + + IF ( DEF_VEG_SNOW ) THEN + ! update fwet_snow + fwet_snow(i) = 0 + IF(ldew_snow(i) > 0.) THEN + fwet_snow(i) = ((10./(48.*lsai(i)))*ldew_snow(i))**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow(i) = min(fwet_snow(i),1.0) + ENDIF + + ! phase change + + qmelt(i) = 0. + qfrz(i) = 0. + + IF (ldew_snow(i).gt.1.e-6 .and. tl(i).gt.tfrz) THEN + qmelt(i) = min(ldew_snow(i)/deltim,(tl(i)-tfrz)*cpice*ldew_snow(i)/(deltim*hfus)) + ldew_snow(i) = max(0.,ldew_snow(i) - qmelt(i)*deltim) + ldew_rain(i) = max(0.,ldew_rain(i) + qmelt(i)*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl(i) = fwet_snow(i)*tfrz + (1.-fwet_snow(i))*tl(i) !Niu et al., 2004 + ENDIF + + IF (ldew_rain(i).gt.1.e-6 .and. tl(i).lt.tfrz) THEN + qfrz(i) = min(ldew_rain(i)/deltim,(tfrz-tl(i))*cpliq*ldew_rain(i)/(deltim*hfus)) + ldew_rain(i) = max(0.,ldew_rain(i) - qfrz(i)*deltim) + ldew_snow(i) = max(0.,ldew_snow(i) + qfrz(i)*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl(i) = fwet_snow(i)*tfrz + (1.-fwet_snow(i))*tl(i) !Niu et al., 2004 + ENDIF + ENDIF + +!----------------------------------------------------------------------- +! balance check +! (the computational error was created by the assumed 'dtl' in MARK#dtl) +!----------------------------------------------------------------------- + + err = sabv(i) + irab(i) + dirab_dtl(i)*dtl(it-1,i) & + - fsenl(i) - hvap*fevpl(i) + hprl(i) & + ! account for vegetation heat change + - dheatl(i) + +#if (defined CoLMDEBUG) + IF(abs(err) .gt. .2) & + write(6,*) 'energy imbalance in LeafTemperaturePC.F90', & + i,it-1,err,sabv(i),irab(i),fsenl(i),hvap*fevpl(i),hprl(i),dheatl(i) +#endif + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! downward (upward) longwave radiation below (above) the canopy +!----------------------------------------------------------------------- + dlrad = Lin(0) & + + sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) + + ulrad = Lin(4) - sum( fcover * dLv * dtl(it-1,:) ) & + - emg * sum( 4.* fshade * (1-thermk) * stefnc * tlbef**3 * dtl(it-1,:) ) + +!----------------------------------------------------------------------- +! wind stresses +!----------------------------------------------------------------------- + + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram + +!----------------------------------------------------------------------- +! fluxes from ground to canopy space +!----------------------------------------------------------------------- + +! 03/07/2020, yuan: TODO-done, calculate fseng_soil/snow, fevpg_soil/snow + IF (numlay .eq. 1) THEN + ttaf = thm + tqaf = qm + ENDIF + + IF (numlay .eq. 2) THEN + ttaf = taf(toplay) + tqaf = qaf(toplay) + ENDIF + + IF (numlay .eq. 3) THEN + ttaf = taf(2) + tqaf = qaf(2) + ENDIF + + !NOTE: the below EQs for check purpose only + ! taf = wah*thm + wgh*tg + wlh*tl + ! taf(1) = wah(1)*taf(2) + wgh(1)*tg + wlhl(1) + ! qaf(1) = waq(1)*qaf(2) + wgq(1)*qg + wlql(1) + ! taf(botlay) = wah(botlay)*taf(toplay) + wgh(botlay)*tg + wlhl(botlay) + ! qaf(botlay) = waq(botlay)*qaf(toplay) + wgq(botlay)*qg + wlql(botlay) + ! taf(toplay) = wah(toplay)*thm + wgh(toplay)*tg + wlhl(toplay) + ! qaf(toplay) = waq(toplay)*qm + wgq(toplay)*qg + wlql(toplay) + + fseng = cpair*rhoair*cgh(botlay)*(tg-taf(botlay)) + fseng_soil = cpair*rhoair*cgh(botlay)*((1.-wgh(botlay))*t_soil-wah(botlay)*ttaf-wlhl(botlay)) + fseng_snow = cpair*rhoair*cgh(botlay)*((1.-wgh(botlay))*t_snow-wah(botlay)*ttaf-wlhl(botlay)) + + fevpg = rhoair*cgw(botlay)*(qg-qaf(botlay)) + fevpg_soil = rhoair*cgw(botlay)*((1.-wgq(botlay))*q_soil-waq(botlay)*tqaf-wlql(botlay)) + fevpg_snow = rhoair*cgw(botlay)*((1.-wgq(botlay))*q_snow-waq(botlay)*tqaf-wlql(botlay)) + +!----------------------------------------------------------------------- +! Derivative of soil energy flux with respect to soil temperature (cgrnd) +!----------------------------------------------------------------------- + + !NOTE: When numlay<3, no matter how to get the solution, /fact is consistent + IF (numlay < 3) THEN + cgrnds = cpair*rhoair*cgh(botlay)*(1.-wgh(botlay)/fact) + cgrndl = rhoair*cgw(botlay)*(1.-wgq(botlay)/facq)*dqgdT + ELSE + cgrnds = cpair*rhoair*cgh(botlay)*(1.-wah(1)*wgh(2)*wgh(1)/fact-wgh(1)) + cgrndl = rhoair*cgw(botlay)*(1.-waq(1)*wgq(2)*wgq(1)/facq-wgq(1))*dqgdT + ENDIF + + cgrnd = cgrnds + cgrndl*htvp + +!----------------------------------------------------------------------- +! 2 m height air temperature +!----------------------------------------------------------------------- + + tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) + + END SUBROUTINE LeafTemperaturePC +!---------------------------------------------------------------------- + + + SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! determine fraction of foliage covered by water and +! fraction of foliage that is dry and transpiring +! +! !REVISIONS: +! 2024.04.16, Hua Yuan: add option to account for vegetation snow process +! 2018.06 , Hua Yuan: remove sigf, to compatible with PFT +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: dewmx !maximum allowed dew [0.1 mm] + real(r8), intent(in) :: ldew !depth of water on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_rain !depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet !fraction of foliage covered by water&snow [-] + real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] + + real(r8) :: lsai !lai + sai + real(r8) :: dewmxi !inverse of maximum allowed dew [1/mm] + real(r8) :: vegt !sigf*lsai, NOTE: remove sigf + real(r8) :: fwet_rain !fraction of foliage covered by water [-] + real(r8) :: fwet_snow !fraction of foliage covered by snow [-] + +!----------------------------------------------------------------------- +! Fwet is the fraction of all vegetation surfaces which are wet +! including stem area which contribute to evaporation + lsai = lai + sai + dewmxi = 1.0/dewmx + ! 06/2018, yuan: remove sigf, to compatible with PFT + vegt = lsai + + fwet = 0 + IF (ldew > 0.) THEN + fwet = ((dewmxi/vegt)*ldew)**.666666666666 + ! Check for maximum limit of fwet + fwet = min(fwet,1.0) + ENDIF + + ! account for vegetation snow + ! calculate fwet_rain, fwet_snow, fwet + IF ( DEF_VEG_SNOW ) THEN + + fwet_rain = 0 + IF(ldew_rain > 0.) THEN + fwet_rain = ((dewmxi/vegt)*ldew_rain)**.666666666666 + ! Check for maximum limit of fwet_rain + fwet_rain = min(fwet_rain,1.0) + ENDIF + + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((dewmxi/(48.*vegt))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + fwet = fwet_rain + fwet_snow - fwet_rain*fwet_snow + fwet = min(fwet,1.0) + ENDIF + + ! fdry is the fraction of lai which is dry because only leaves can + ! transpire. Adjusted for stem area which does not transpire + fdry = (1.-fwet)*lai/lsai + + END SUBROUTINE dewfraction + +END MODULE MOD_LeafTemperaturePC diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 new file mode 100644 index 0000000000..7137498b28 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LightningData.F90 @@ -0,0 +1,116 @@ +#include + +#ifdef BGC +MODULE MOD_LightningData +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module read in lightning data for fire subroutine +! +! !ORIGINAL: +! Zhang Shupeng, 2022, prepare the original version of the lightning data module. +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_BGC_Vars_TimeVariables, only: lnfm + IMPLICIT NONE + + character(len=256) :: file_lightning + type(grid_type) :: grid_lightning + + type(block_data_real8_2d) :: f_lnfm + + type (spatial_mapping_type) :: mg2p_lnfm + +CONTAINS + + SUBROUTINE init_lightning_data (idate) + +!----------------------------------------------------------------------- +! !DESCTIPTION: +! open lightning netcdf file from DEF_dir_rawdata, read latitude and longitude info. +! Initialize lightning data read in. +!----------------------------------------------------------------------- + + USE MOD_MPAS_MPI + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: idate(3) + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + integer :: itime + + file_lightning = trim(DEF_dir_runtime) // & + '/fire/clmforc.Li_2012_climo1995-2011.T62.lnfm_Total_c140423.nc' + + CALL ncio_read_bcast_serial (file_lightning, 'lat', lat) + CALL ncio_read_bcast_serial (file_lightning, 'lon', lon) + + CALL grid_lightning%define_by_center (lat, lon) + + CALL allocate_block_data (grid_lightning, f_lnfm) + + CALL mg2p_lnfm%build_arealweighted (grid_lightning, landpatch) + + itime = (idate(2)-1)*8 + min(idate(3)/10800+1,8) + IF (itime .gt. 2920)itime = itime - 8 ! for the leap year + + CALL ncio_read_block_time (file_lightning, 'lnfm', grid_lightning, itime, f_lnfm) +#ifdef RangeCheck + CALL check_block_data ('lightning', f_lnfm) +#endif + + END SUBROUTINE init_lightning_data + + + SUBROUTINE update_lightning_data (time, deltim) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! read lightning data during simulation +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_NetCDFBlock + USE MOD_RangeCheck + IMPLICIT NONE + + type(timestamp), intent(in) :: time + real(r8), intent(in) :: deltim + + ! Local Variables + type(timestamp) :: time_next + integer :: itime, itime_next + + itime = (time%day-1)*8 + min(time%sec/10800+1,8) + IF (mod(time%sec,10800) == 0) itime = itime - 1 + + time_next = time + int(deltim) + itime_next = (time_next%day-1)*8 + max(0,time_next%sec-1)/10800+1 + + IF (itime_next /= itime) THEN + itime_next = min(itime_next,2920) + CALL ncio_read_block_time (file_lightning, 'lnfm', grid_lightning, itime_next, f_lnfm) +#ifdef RangeCheck + CALL check_block_data ('lightning', f_lnfm) +#endif + + CALL mg2p_lnfm%grid2pset (f_lnfm, lnfm) +#ifdef RangeCheck + CALL check_vector_data ('lightning', lnfm) +#endif + ENDIF + + END SUBROUTINE update_lightning_data + +END MODULE MOD_LightningData +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_MonthlyinSituCO2MaunaLoa.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_MonthlyinSituCO2MaunaLoa.F90 new file mode 100644 index 0000000000..22899d863e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_MonthlyinSituCO2MaunaLoa.F90 @@ -0,0 +1,746 @@ +#include + +!"-------------------------------------------------------------------------------------------" +!" Atmospheric CO2 concentrations (ppm) derived from in situ air measurements " +!" at Mauna Loa, Observatory, Hawaii: Latitude 19.5°N Longitude 155.6°W Elevation 3397m " +!" " +!" Source: R. F. Keeling, S. J. Walker, S. C. Piper and A. F. Bollenbacher " +!" Scripps CO2 Program ( http://scrippsco2.ucsd.edu ) " +!" Scripps Institution of Oceanography (SIO) " +!" University of California " +!" La Jolla, California USA 92093-0244 " +!" " +!" Status of data and correspondence: " +!" " +!" These data are subject to revision based on recalibration of standard gases. Questions " +!" about the data should be directed to Dr. Ralph Keeling (rkeeling@ucsd.edu), Stephen Walker" +!" (sjwalker@ucsd.edu) and Stephen Piper (scpiper@ucsd.edu), Scripps CO2 Program. " +!" " +!" Baseline data in this file through 03-May-2022 from archive dated 04-May-2022 09:22:14 " +!" " +!"-------------------------------------------------------------------------------------------" +!" " +!" Please cite as: " +!" " +!" C. D. Keeling, S. C. Piper, R. B. Bacastow, M. Wahlen, T. P. Whorf, M. Heimann, and " +!" H. A. Meijer, Exchanges of atmospheric CO2 and 13CO2 with the terrestrial biosphere and " +!" oceans from 1978 to 2000. I. Global aspects, SIO Reference Series, No. 01-06, Scripps " +!" Institution of Oceanography, San Diego, 88 pages, 2001. " +!" " +!" If it is necessary to cite a peer-reviewed article, please cite as: " +!" " +!" C. D. Keeling, S. C. Piper, R. B. Bacastow, M. Wahlen, T. P. Whorf, M. Heimann, and " +!" H. A. Meijer, Atmospheric CO2 and 13CO2 exchange with the terrestrial biosphere and " +!" oceans from 1978 to 2000: observations and carbon cycle implications, pages 83-113, " +!" in "A History of Atmospheric CO2 and its effects on Plants, Animals, and Ecosystems", " +!" editors, Ehleringer, J.R., T. E. Cerling, M. D. Dearing, Springer Verlag, " +!" New York, 2005. " +!" " +!"-------------------------------------------------------------------------------------------" + +MODULE MOD_MonthlyinSituCO2MaunaLoa +! ------------------------------- +! +! !DESCRIPTION: +! Monthly atmospheric CO2 concentrations (ppm) for model input derived from +! in situ air measurements at Mauna Loa, Observatory, Hawaii +! +! Created by Hua Yuan, 05/2022 +! +! !REVISIONS: +! !---2023.02.23 Zhongwang Wei @ SYSU: Added CO2 data (TODO:details?@zhongwang) +! in init_monthly_co2_mlo() +! !---2022.12.12 Zhongwang Wei @ SYSU: Added history and SSP CO2 data in init_monthly_co2_mlo() +! ------------------------------- + + USE MOD_Precision + USE MOD_Namelist, only: DEF_SSP + IMPLICIT NONE + SAVE + + ! define the CO2 data time range + integer, parameter :: syear = 1849 + integer, parameter :: eyear = 2100 + integer, parameter :: smonth = 1 + integer, parameter :: emonth = 12 + + real(r8), dimension(syear:eyear, 12) :: co2mlo + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: init_monthly_co2_mlo + PUBLIC :: get_monthly_co2_mlo + +CONTAINS + + SUBROUTINE init_monthly_co2_mlo + !DESCRIPTION + !=========== + !---This MODULE is used for initialize the CO2 concentration. + + !ANCILLARY FUNCTIONS AND SUBROUTINES + !------------------- + + !Original Author: + !------------------- + !Hua Yuan @ SYSU 2021.05.05 + + !References: + !------------------- + !---1850-1957 obtained from + ! https://data.isimip.org/datasets/0497b2a7-fd37-4fe0-8d05-ea3057272731/ Matthias Büchner, + ! Christopher Reyer (2022): ISIMIP3b atmospheric composition input data (v1.1). ISIMIP + ! Repository. https://doi.org/10.48364/ISIMIP.482153.1 + !---1958-2022 obtained from https://www.esrl.noaa.gov/gmd/ccgg/trends/data.html + !---!May 2022 ~ Dec 2022 data obtained from + ! https://gml.noaa.gov/webdata/ccgg/trends/co2/co2_mm_mlo.txt (Mauna Loa, Hawaii) + !---Due to the eruption of the Mauna Loa Volcano, measurements from Mauna Loa Observatory were + ! suspended as of Nov. 29. 2022 New Observations starting in December 2022 are from a site + ! at the Maunakea Observatories, approximately 21 miles north of the Mauna Loa Observatory. + !---CMIP6 co2 data is obtainted from : + ! Matthias Büchner, Christopher Reyer (2022): ISIMIP3b atmospheric composition input data + ! (v1.1). ISIMIP Repository. https://doi.org/10.48364/ISIMIP.482153.1 + + !REVISION HISTORY + !---------------- + !---2023.02.23 Zhongwang Wei @ SYSU + !---2022.12.12 Zhongwang Wei @ SYSU + !---2021.05.05 Hua Yuan @ SYSU + + IMPLICIT NONE + + ! fillvalue + co2mlo(:,:) = -99.99 !monthly mean CO2 concentration in ppm + !1850-1957 obtained from + !https://data.isimip.org/datasets/0497b2a7-fd37-4fe0-8d05-ea3057272731/ Matthias Büchner, + !Christopher Reyer (2022): ISIMIP3b atmospheric composition input data (v1.1). ISIMIP + !Repository. https://doi.org/10.48364/ISIMIP.482153.1 + !added by Zhongwang Wei @ SYSU 2022.12.12 + co2mlo( 1849 ,:) = (/ 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 /) + co2mlo( 1850 ,:) = (/ 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 , 284.73 /) + co2mlo( 1851 ,:) = (/ 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 , 284.88 /) + co2mlo( 1852 ,:) = (/ 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 , 285.00 /) + co2mlo( 1853 ,:) = (/ 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 , 285.13 /) + co2mlo( 1854 ,:) = (/ 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 , 285.28 /) + co2mlo( 1855 ,:) = (/ 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 , 285.43 /) + co2mlo( 1856 ,:) = (/ 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 , 285.58 /) + co2mlo( 1857 ,:) = (/ 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 , 285.73 /) + co2mlo( 1858 ,:) = (/ 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 , 285.90 /) + co2mlo( 1859 ,:) = (/ 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 , 286.08 /) + co2mlo( 1860 ,:) = (/ 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 , 286.23 /) + co2mlo( 1861 ,:) = (/ 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 , 286.38 /) + co2mlo( 1862 ,:) = (/ 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 , 286.50 /) + co2mlo( 1863 ,:) = (/ 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 , 286.63 /) + co2mlo( 1864 ,:) = (/ 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 , 286.78 /) + co2mlo( 1865 ,:) = (/ 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 , 286.90 /) + co2mlo( 1866 ,:) = (/ 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 , 287.00 /) + co2mlo( 1867 ,:) = (/ 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 , 287.10 /) + co2mlo( 1868 ,:) = (/ 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 , 287.23 /) + co2mlo( 1869 ,:) = (/ 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 , 287.38 /) + co2mlo( 1870 ,:) = (/ 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 , 287.53 /) + co2mlo( 1871 ,:) = (/ 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 , 287.70 /) + co2mlo( 1872 ,:) = (/ 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 , 287.90 /) + co2mlo( 1873 ,:) = (/ 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 , 288.13 /) + co2mlo( 1874 ,:) = (/ 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 , 288.40 /) + co2mlo( 1875 ,:) = (/ 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 , 288.70 /) + co2mlo( 1876 ,:) = (/ 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 , 289.03 /) + co2mlo( 1877 ,:) = (/ 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 , 289.40 /) + co2mlo( 1878 ,:) = (/ 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 , 289.80 /) + co2mlo( 1879 ,:) = (/ 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 , 290.23 /) + co2mlo( 1880 ,:) = (/ 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 , 290.70 /) + co2mlo( 1881 ,:) = (/ 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 , 291.20 /) + co2mlo( 1882 ,:) = (/ 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 , 291.68 /) + co2mlo( 1883 ,:) = (/ 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 , 292.13 /) + co2mlo( 1884 ,:) = (/ 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 , 292.58 /) + co2mlo( 1885 ,:) = (/ 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 , 292.98 /) + co2mlo( 1886 ,:) = (/ 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 , 293.30 /) + co2mlo( 1887 ,:) = (/ 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 , 293.58 /) + co2mlo( 1888 ,:) = (/ 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 , 293.80 /) + co2mlo( 1889 ,:) = (/ 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 , 294.00 /) + co2mlo( 1890 ,:) = (/ 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 , 294.18 /) + co2mlo( 1891 ,:) = (/ 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 , 294.33 /) + co2mlo( 1892 ,:) = (/ 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 , 294.48 /) + co2mlo( 1893 ,:) = (/ 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 , 294.60 /) + co2mlo( 1894 ,:) = (/ 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 , 294.70 /) + co2mlo( 1895 ,:) = (/ 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 , 294.80 /) + co2mlo( 1896 ,:) = (/ 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 , 294.90 /) + co2mlo( 1897 ,:) = (/ 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 , 295.03 /) + co2mlo( 1898 ,:) = (/ 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 , 295.23 /) + co2mlo( 1899 ,:) = (/ 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 , 295.50 /) + co2mlo( 1900 ,:) = (/ 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 , 295.80 /) + co2mlo( 1901 ,:) = (/ 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 , 296.13 /) + co2mlo( 1902 ,:) = (/ 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 , 296.48 /) + co2mlo( 1903 ,:) = (/ 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 , 296.83 /) + co2mlo( 1904 ,:) = (/ 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 , 297.20 /) + co2mlo( 1905 ,:) = (/ 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 , 297.63 /) + co2mlo( 1906 ,:) = (/ 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 , 298.08 /) + co2mlo( 1907 ,:) = (/ 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 , 298.50 /) + co2mlo( 1908 ,:) = (/ 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 , 298.90 /) + co2mlo( 1909 ,:) = (/ 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 , 299.30 /) + co2mlo( 1910 ,:) = (/ 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 , 299.70 /) + co2mlo( 1911 ,:) = (/ 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 , 300.08 /) + co2mlo( 1912 ,:) = (/ 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 , 300.43 /) + co2mlo( 1913 ,:) = (/ 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 , 300.78 /) + co2mlo( 1914 ,:) = (/ 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 , 301.10 /) + co2mlo( 1915 ,:) = (/ 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 , 301.40 /) + co2mlo( 1916 ,:) = (/ 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 , 301.73 /) + co2mlo( 1917 ,:) = (/ 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 , 302.08 /) + co2mlo( 1918 ,:) = (/ 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 , 302.40 /) + co2mlo( 1919 ,:) = (/ 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 , 302.70 /) + co2mlo( 1920 ,:) = (/ 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 , 303.03 /) + co2mlo( 1921 ,:) = (/ 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 , 303.40 /) + co2mlo( 1922 ,:) = (/ 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 , 303.78 /) + co2mlo( 1923 ,:) = (/ 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 , 304.13 /) + co2mlo( 1924 ,:) = (/ 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 , 304.53 /) + co2mlo( 1925 ,:) = (/ 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 , 304.98 /) + co2mlo( 1926 ,:) = (/ 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 , 305.40 /) + co2mlo( 1927 ,:) = (/ 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 , 305.83 /) + co2mlo( 1928 ,:) = (/ 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 , 306.30 /) + co2mlo( 1929 ,:) = (/ 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 , 306.78 /) + co2mlo( 1930 ,:) = (/ 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 , 307.23 /) + co2mlo( 1931 ,:) = (/ 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 , 307.70 /) + co2mlo( 1932 ,:) = (/ 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 , 308.18 /) + co2mlo( 1933 ,:) = (/ 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 , 308.60 /) + co2mlo( 1934 ,:) = (/ 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 , 309.00 /) + co2mlo( 1935 ,:) = (/ 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 , 309.40 /) + co2mlo( 1936 ,:) = (/ 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 , 309.75 /) + co2mlo( 1937 ,:) = (/ 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 , 310.00 /) + co2mlo( 1938 ,:) = (/ 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 , 310.18 /) + co2mlo( 1939 ,:) = (/ 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 /) + co2mlo( 1940 ,:) = (/ 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 /) + co2mlo( 1941 ,:) = (/ 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 , 310.38 /) + co2mlo( 1942 ,:) = (/ 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 , 310.30 /) + co2mlo( 1943 ,:) = (/ 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 /) + co2mlo( 1944 ,:) = (/ 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 /) + co2mlo( 1945 ,:) = (/ 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 , 310.10 /) + co2mlo( 1946 ,:) = (/ 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 , 310.13 /) + co2mlo( 1947 ,:) = (/ 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 , 310.20 /) + co2mlo( 1948 ,:) = (/ 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 , 310.33 /) + co2mlo( 1949 ,:) = (/ 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 , 310.50 /) + co2mlo( 1950 ,:) = (/ 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 , 310.75 /) + co2mlo( 1951 ,:) = (/ 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 , 311.10 /) + co2mlo( 1952 ,:) = (/ 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 , 311.50 /) + co2mlo( 1953 ,:) = (/ 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 , 311.93 /) + co2mlo( 1954 ,:) = (/ 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 , 312.43 /) + co2mlo( 1955 ,:) = (/ 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 , 313.00 /) + co2mlo( 1956 ,:) = (/ 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 , 313.60 /) + co2mlo( 1957 ,:) = (/ 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 , 314.23 /) + !co2mlo( 1958 ,:) = (/ 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 , 314.85 /) + !co2mlo( 1959 ,:) = (/ 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 , 315.50 /) + !co2mlo( 1960 ,:) = (/ 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 , 316.27 /) + !co2mlo( 1961 ,:) = (/ 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 , 317.08 /) + !co2mlo( 1962 ,:) = (/ 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 , 317.80 /) + !co2mlo( 1963 ,:) = (/ 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 , 318.40 /) + !co2mlo( 1964 ,:) = (/ 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 , 318.93 /) + !co2mlo( 1965 ,:) = (/ 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 , 319.65 /) + !co2mlo( 1966 ,:) = (/ 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 , 320.65 /) + !co2mlo( 1967 ,:) = (/ 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 , 321.61 /) + !co2mlo( 1968 ,:) = (/ 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 , 322.64 /) + !co2mlo( 1969 ,:) = (/ 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 , 323.90 /) + !co2mlo( 1970 ,:) = (/ 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 , 324.99 /) + !co2mlo( 1971 ,:) = (/ 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 , 325.86 /) + !co2mlo( 1972 ,:) = (/ 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 , 327.14 /) + !co2mlo( 1973 ,:) = (/ 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 , 328.68 /) + !co2mlo( 1974 ,:) = (/ 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 , 329.74 /) + !co2mlo( 1975 ,:) = (/ 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 , 330.59 /) + !co2mlo( 1976 ,:) = (/ 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 , 331.75 /) + !co2mlo( 1977 ,:) = (/ 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 , 333.27 /) + !co2mlo( 1978 ,:) = (/ 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 , 334.85 /) + !co2mlo( 1979 ,:) = (/ 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 , 336.53 /) + !co2mlo( 1980 ,:) = (/ 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 , 338.36 /) + !co2mlo( 1981 ,:) = (/ 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 , 339.73 /) + !co2mlo( 1982 ,:) = (/ 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 , 340.79 /) + !co2mlo( 1983 ,:) = (/ 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 , 342.20 /) + !co2mlo( 1984 ,:) = (/ 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 , 343.78 /) + !co2mlo( 1985 ,:) = (/ 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 , 345.28 /) + !co2mlo( 1986 ,:) = (/ 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 , 346.80 /) + !co2mlo( 1987 ,:) = (/ 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 , 348.65 /) + !co2mlo( 1988 ,:) = (/ 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 , 350.74 /) + !co2mlo( 1989 ,:) = (/ 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 , 352.49 /) + !co2mlo( 1990 ,:) = (/ 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 , 353.86 /) + !co2mlo( 1991 ,:) = (/ 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 , 355.02 /) + !co2mlo( 1992 ,:) = (/ 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 , 355.89 /) + !co2mlo( 1993 ,:) = (/ 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 , 356.78 /) + !co2mlo( 1994 ,:) = (/ 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 , 358.13 /) + !co2mlo( 1995 ,:) = (/ 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 , 359.84 /) + !co2mlo( 1996 ,:) = (/ 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 , 361.46 /) + !co2mlo( 1997 ,:) = (/ 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 , 363.16 /) + !co2mlo( 1998 ,:) = (/ 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 , 365.32 /) + !co2mlo( 1999 ,:) = (/ 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 , 367.35 /) + !co2mlo( 2000 ,:) = (/ 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 , 368.87 /) + !co2mlo( 2001 ,:) = (/ 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 , 370.47 /) + !co2mlo( 2002 ,:) = (/ 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 , 372.52 /) + !co2mlo( 2003 ,:) = (/ 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 , 374.76 /) + !co2mlo( 2004 ,:) = (/ 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 , 376.81 /) + !co2mlo( 2005 ,:) = (/ 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 , 378.81 /) + !co2mlo( 2006 ,:) = (/ 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 , 380.93 /) + !co2mlo( 2007 ,:) = (/ 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 , 382.70 /) + !co2mlo( 2008 ,:) = (/ 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 , 384.77 /) + !co2mlo( 2009 ,:) = (/ 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 , 386.28 /) + !co2mlo( 2010 ,:) = (/ 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 , 388.57 /) + !co2mlo( 2011 ,:) = (/ 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 , 390.49 /) + !co2mlo( 2012 ,:) = (/ 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 , 392.52 /) + !co2mlo( 2013 ,:) = (/ 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 , 395.31 /) + !co2mlo( 2014 ,:) = (/ 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 , 397.12 /) + + !NOTE: the below numbers can be manually updated IF new records are available [Unit: ppm] + co2mlo(1958,:) = (/ 314.85, 314.85, 315.71, 317.45, 317.51, 317.25, 315.86, 314.93, 313.21, 312.43, 313.33, 314.67 /) + co2mlo(1959,:) = (/ 315.58, 316.49, 316.65, 317.72, 318.29, 318.15, 316.54, 314.80, 313.84, 313.33, 314.81, 315.58 /) + co2mlo(1960,:) = (/ 316.43, 316.98, 317.58, 319.03, 320.03, 319.58, 318.18, 315.90, 314.17, 313.83, 315.00, 316.19 /) + co2mlo(1961,:) = (/ 316.89, 317.70, 318.54, 319.48, 320.58, 319.77, 318.56, 316.79, 314.99, 315.31, 316.10, 317.01 /) + co2mlo(1962,:) = (/ 317.94, 318.55, 319.68, 320.57, 321.02, 320.62, 319.61, 317.40, 316.24, 315.42, 316.69, 317.70 /) + co2mlo(1963,:) = (/ 318.74, 319.07, 319.86, 321.38, 322.25, 321.48, 319.74, 317.77, 316.21, 315.99, 317.07, 318.35 /) + co2mlo(1964,:) = (/ 319.57, 320.03, 320.74, 321.83, 322.25, 321.89, 320.44, 318.69, 316.71, 316.87, 317.68, 318.71 /) + co2mlo(1965,:) = (/ 319.44, 320.44, 320.89, 322.14, 322.17, 321.87, 321.21, 318.87, 317.82, 317.30, 318.87, 319.42 /) + co2mlo(1966,:) = (/ 320.62, 321.60, 322.39, 323.70, 324.08, 323.75, 322.38, 320.36, 318.64, 318.10, 319.78, 321.02 /) + co2mlo(1967,:) = (/ 322.33, 322.50, 323.03, 324.41, 325.00, 324.09, 322.54, 320.92, 319.25, 319.39, 320.73, 321.95 /) + co2mlo(1968,:) = (/ 322.57, 323.15, 323.89, 325.02, 325.57, 325.36, 324.14, 322.11, 320.33, 320.25, 321.32, 322.89 /) + co2mlo(1969,:) = (/ 324.00, 324.41, 325.63, 326.66, 327.38, 326.71, 325.88, 323.66, 322.38, 321.78, 322.85, 324.11 /) + co2mlo(1970,:) = (/ 325.06, 325.99, 326.93, 328.13, 328.08, 327.67, 326.34, 324.68, 323.10, 323.07, 324.01, 325.13 /) + co2mlo(1971,:) = (/ 326.17, 326.68, 327.18, 327.79, 328.93, 328.57, 327.36, 325.43, 323.36, 323.56, 324.80, 326.01 /) + co2mlo(1972,:) = (/ 326.77, 327.63, 327.75, 329.72, 330.07, 329.09, 328.04, 326.32, 324.84, 325.20, 326.50, 327.55 /) + co2mlo(1973,:) = (/ 328.55, 329.56, 330.30, 331.50, 332.48, 332.07, 330.87, 329.31, 327.52, 327.19, 328.17, 328.65 /) + co2mlo(1974,:) = (/ 329.36, 330.71, 331.49, 332.65, 333.10, 332.26, 331.18, 329.40, 327.44, 327.38, 328.46, 329.58 /) + co2mlo(1975,:) = (/ 330.41, 331.41, 332.04, 333.32, 333.98, 333.61, 331.91, 330.06, 328.56, 328.35, 329.50, 330.77 /) + co2mlo(1976,:) = (/ 331.76, 332.58, 333.50, 334.59, 334.89, 334.34, 333.06, 330.95, 329.31, 328.95, 330.32, 331.69 /) + co2mlo(1977,:) = (/ 332.94, 333.43, 334.71, 336.08, 336.76, 336.28, 334.93, 332.76, 331.60, 331.17, 332.41, 333.86 /) + co2mlo(1978,:) = (/ 334.98, 335.40, 336.65, 337.76, 338.02, 337.91, 336.55, 334.69, 332.77, 332.56, 333.93, 334.96 /) + co2mlo(1979,:) = (/ 336.24, 336.77, 337.97, 338.89, 339.48, 339.30, 337.74, 336.10, 333.93, 333.87, 335.30, 336.74 /) + co2mlo(1980,:) = (/ 338.03, 338.37, 340.09, 340.78, 341.48, 341.19, 339.57, 337.61, 335.90, 336.03, 337.12, 338.23 /) + co2mlo(1981,:) = (/ 339.25, 340.50, 341.40, 342.52, 342.93, 342.27, 340.50, 338.45, 336.71, 336.88, 338.38, 339.63 /) + co2mlo(1982,:) = (/ 340.77, 341.63, 342.72, 343.59, 344.16, 343.37, 342.07, 339.83, 338.00, 337.88, 339.28, 340.51 /) + co2mlo(1983,:) = (/ 341.40, 342.54, 343.12, 344.96, 345.78, 345.34, 344.00, 342.40, 339.88, 340.01, 341.16, 342.98 /) + co2mlo(1984,:) = (/ 343.82, 344.62, 345.38, 347.15, 347.52, 346.88, 345.47, 343.34, 341.13, 341.40, 343.02, 344.25 /) + co2mlo(1985,:) = (/ 344.99, 346.01, 347.43, 348.34, 348.92, 348.24, 346.54, 344.64, 343.06, 342.78, 344.21, 345.53 /) + co2mlo(1986,:) = (/ 346.28, 346.93, 347.83, 349.53, 350.19, 349.53, 347.92, 345.88, 344.83, 344.16, 345.64, 346.88 /) + co2mlo(1987,:) = (/ 348.00, 348.47, 349.40, 350.97, 351.84, 351.25, 349.50, 348.09, 346.44, 346.09, 347.54, 348.69 /) + co2mlo(1988,:) = (/ 350.16, 351.47, 351.96, 353.33, 353.97, 353.55, 352.14, 350.19, 348.50, 348.66, 349.85, 351.12 /) + co2mlo(1989,:) = (/ 352.55, 352.86, 353.48, 355.21, 355.47, 354.92, 353.70, 351.47, 349.61, 349.79, 351.10, 352.32 /) + co2mlo(1990,:) = (/ 353.46, 354.50, 355.19, 356.00, 356.96, 356.04, 354.62, 352.71, 350.77, 350.99, 352.64, 354.02 /) + co2mlo(1991,:) = (/ 354.53, 355.55, 356.96, 358.40, 359.14, 358.04, 355.98, 353.81, 351.95, 352.02, 353.55, 354.79 /) + co2mlo(1992,:) = (/ 355.79, 356.52, 357.61, 358.95, 359.46, 359.05, 356.82, 354.80, 352.81, 353.11, 353.96, 355.20 /) + co2mlo(1993,:) = (/ 356.50, 356.97, 358.18, 359.26, 360.08, 359.40, 357.38, 355.33, 353.50, 353.80, 355.15, 356.62 /) + co2mlo(1994,:) = (/ 358.19, 358.73, 359.79, 361.09, 361.52, 360.77, 359.38, 357.31, 355.68, 355.83, 357.42, 358.87 /) + co2mlo(1995,:) = (/ 359.81, 360.84, 361.48, 363.30, 363.64, 363.11, 361.75, 359.31, 357.91, 357.62, 359.42, 360.56 /) + co2mlo(1996,:) = (/ 361.91, 363.11, 363.88, 364.58, 365.29, 364.84, 363.52, 361.35, 359.32, 359.48, 360.64, 362.21 /) + co2mlo(1997,:) = (/ 363.07, 363.87, 364.44, 366.23, 366.68, 365.52, 364.36, 362.39, 360.08, 360.67, 362.32, 364.16 /) + co2mlo(1998,:) = (/ 365.22, 366.04, 367.20, 368.50, 369.19, 368.77, 367.53, 365.67, 363.80, 364.13, 365.36, 366.87 /) + co2mlo(1999,:) = (/ 368.05, 368.77, 369.49, 371.04, 370.90, 370.25, 369.17, 366.83, 364.54, 365.04, 366.58, 367.92 /) + co2mlo(2000,:) = (/ 369.05, 369.37, 370.42, 371.57, 371.74, 371.60, 370.02, 368.03, 366.53, 366.64, 368.20, 369.44 /) + co2mlo(2001,:) = (/ 370.20, 371.42, 372.04, 372.78, 373.94, 373.23, 371.54, 369.47, 367.88, 368.01, 369.60, 371.15 /) + co2mlo(2002,:) = (/ 372.36, 373.00, 373.44, 374.77, 375.48, 375.33, 373.95, 371.41, 370.63, 370.18, 372.01, 373.71 /) + co2mlo(2003,:) = (/ 374.61, 375.55, 376.04, 377.58, 378.28, 378.07, 376.54, 374.42, 372.92, 372.94, 374.29, 375.63 /) + co2mlo(2004,:) = (/ 376.73, 377.31, 378.33, 380.44, 380.56, 379.49, 377.71, 375.77, 373.99, 374.17, 375.79, 377.39 /) + co2mlo(2005,:) = (/ 378.29, 379.56, 380.06, 382.01, 382.21, 382.05, 380.63, 378.64, 376.38, 376.77, 378.27, 379.92 /) + co2mlo(2006,:) = (/ 381.33, 381.98, 382.53, 384.33, 384.89, 383.99, 382.25, 380.44, 378.77, 379.03, 380.11, 381.62 /) + co2mlo(2007,:) = (/ 382.55, 383.68, 384.31, 386.20, 386.38, 385.85, 384.42, 381.81, 380.83, 380.83, 382.32, 383.58 /) + co2mlo(2008,:) = (/ 385.04, 385.81, 385.80, 386.74, 388.49, 388.02, 386.22, 384.05, 383.05, 382.75, 383.98, 385.08 /) + co2mlo(2009,:) = (/ 386.63, 387.10, 388.50, 389.54, 390.15, 389.60, 388.05, 386.06, 384.64, 384.32, 386.05, 387.48 /) + co2mlo(2010,:) = (/ 388.55, 390.08, 391.02, 392.39, 393.24, 392.26, 390.35, 388.53, 386.85, 387.18, 388.69, 389.83 /) + co2mlo(2011,:) = (/ 391.33, 391.96, 392.49, 393.40, 394.33, 393.75, 392.64, 390.25, 389.05, 388.98, 390.30, 391.86 /) + co2mlo(2012,:) = (/ 393.13, 393.42, 394.43, 396.51, 396.96, 395.97, 394.60, 392.61, 391.20, 391.09, 393.03, 394.42 /) + co2mlo(2013,:) = (/ 395.69, 396.94, 397.35, 398.44, 400.06, 398.95, 397.45, 395.49, 393.47, 393.77, 395.27, 396.90 /) + co2mlo(2014,:) = (/ 398.01, 398.18, 399.56, 401.44, 401.98, 401.41, 399.17, 397.30, 395.49, 395.74, 397.32, 398.88 /) + co2mlo(2015,:) = (/ 399.94, 400.40, 401.60, 403.53, 404.04, 402.81, 401.54, 398.93, 397.43, 398.22, 400.17, 401.82 /) + co2mlo(2016,:) = (/ 402.58, 404.09, 404.79, 407.50, 407.59, 406.94, 404.43, 402.17, 400.95, 401.43, 403.57, 404.48 /) + co2mlo(2017,:) = (/ 406.00, 406.57, 406.99, 408.88, 409.84, 409.05, 407.13, 405.17, 403.20, 403.57, 405.10, 406.68 /) + co2mlo(2018,:) = (/ 407.98, 408.36, 409.21, 410.24, 411.23, 410.81, 408.83, 407.02, 405.52, 405.93, 408.04, 409.17 /) + co2mlo(2019,:) = (/ 410.85, 411.59, 411.91, 413.46, 414.76, 413.89, 411.78, 410.01, 408.48, 408.40, 410.16, 411.81 /) + co2mlo(2020,:) = (/ 413.30, 414.05, 414.45, 416.11, 417.15, 416.29, 414.42, 412.52, 411.18, 411.12, 412.88, 413.89 /) + co2mlo(2021,:) = (/ 415.15, 416.47, 417.16, 418.24, 418.95, 418.70, 416.65, 414.34, 412.90, 413.55, 414.82, 416.43 /) + co2mlo(2022,:) = (/ 418.01, 418.99, 418.45, 420.02, 420.99, 420.99, 418.90, 417.19, 415.95, 415.78, 417.51, 418.95 /) + !noted by Zhongwang Wei + !May 2022 ~ Dec 2022 data obtained from + !https://gml.noaa.gov/webdata/ccgg/trends/co2/co2_mm_mlo.txt (Mauna Loa, Hawaii) Due to the + !eruption of the Mauna Loa Volcano, measurements from Mauna Loa Observatory were suspended as + !of Nov. 29. 2022 New Observations starting in December 2022 are from a site at the Maunakea + !Observatories, approximately 21 miles north of the Mauna Loa Observatory. + !CMIP6 co2 data is obtainted from : + !Matthias Büchner, Christopher Reyer (2022): ISIMIP3b atmospheric composition input data + !(v1.1). ISIMIP Repository. https://doi.org/10.48364/ISIMIP.482153.1 + !added by Zhongwang Wei @ SYSU 2022.12.12 + select CASE (trim(DEF_SSP)) + CASE ('126') + !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) + !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) + !co2mlo(2017,:) = (/ 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75, 405.75 /) + !co2mlo(2018,:) = (/ 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59, 408.59 /) + !co2mlo(2019,:) = (/ 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42, 411.42 /) + !co2mlo(2020,:) = (/ 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23, 414.23 /) + !co2mlo(2021,:) = (/ 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04, 417.04 /) + !co2mlo(2022,:) = (/ 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81, 419.81 /) + co2mlo(2023,:) = (/ 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50, 422.50 /) + co2mlo(2024,:) = (/ 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12, 425.12 /) + co2mlo(2025,:) = (/ 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67, 427.67 /) + co2mlo(2026,:) = (/ 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17, 430.17 /) + co2mlo(2027,:) = (/ 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60, 432.60 /) + co2mlo(2028,:) = (/ 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97, 434.97 /) + co2mlo(2029,:) = (/ 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29, 437.29 /) + co2mlo(2030,:) = (/ 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56, 439.56 /) + co2mlo(2031,:) = (/ 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78, 441.78 /) + co2mlo(2032,:) = (/ 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93, 443.93 /) + co2mlo(2033,:) = (/ 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99, 445.99 /) + co2mlo(2034,:) = (/ 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97, 447.97 /) + co2mlo(2035,:) = (/ 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87, 449.87 /) + co2mlo(2036,:) = (/ 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68, 451.68 /) + co2mlo(2037,:) = (/ 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43 /) + co2mlo(2038,:) = (/ 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09, 455.09 /) + co2mlo(2039,:) = (/ 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68, 456.68 /) + co2mlo(2040,:) = (/ 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20, 458.20 /) + co2mlo(2041,:) = (/ 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65 /) + co2mlo(2042,:) = (/ 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02, 461.02 /) + co2mlo(2043,:) = (/ 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31, 462.31 /) + co2mlo(2044,:) = (/ 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54, 463.54 /) + co2mlo(2045,:) = (/ 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68 /) + co2mlo(2046,:) = (/ 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75, 465.75 /) + co2mlo(2047,:) = (/ 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75, 466.75 /) + co2mlo(2048,:) = (/ 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68, 467.68 /) + co2mlo(2049,:) = (/ 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53, 468.53 /) + co2mlo(2050,:) = (/ 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31, 469.31 /) + co2mlo(2051,:) = (/ 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02, 470.02 /) + co2mlo(2052,:) = (/ 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66, 470.66 /) + co2mlo(2053,:) = (/ 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25, 471.25 /) + co2mlo(2054,:) = (/ 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78, 471.78 /) + co2mlo(2055,:) = (/ 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25, 472.25 /) + co2mlo(2056,:) = (/ 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66, 472.66 /) + co2mlo(2057,:) = (/ 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02, 473.02 /) + co2mlo(2058,:) = (/ 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32, 473.32 /) + co2mlo(2059,:) = (/ 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56, 473.56 /) + co2mlo(2060,:) = (/ 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75 /) + co2mlo(2061,:) = (/ 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88, 473.88 /) + co2mlo(2062,:) = (/ 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96 /) + co2mlo(2063,:) = (/ 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00 /) + co2mlo(2064,:) = (/ 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00, 474.00 /) + co2mlo(2065,:) = (/ 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96, 473.96 /) + co2mlo(2066,:) = (/ 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87, 473.87 /) + co2mlo(2067,:) = (/ 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75, 473.75 /) + co2mlo(2068,:) = (/ 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58, 473.58 /) + co2mlo(2069,:) = (/ 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36, 473.36 /) + co2mlo(2070,:) = (/ 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11, 473.11 /) + co2mlo(2071,:) = (/ 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81, 472.81 /) + co2mlo(2072,:) = (/ 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46, 472.46 /) + co2mlo(2073,:) = (/ 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04, 472.04 /) + co2mlo(2074,:) = (/ 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56, 471.56 /) + co2mlo(2075,:) = (/ 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02, 471.02 /) + co2mlo(2076,:) = (/ 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41, 470.41 /) + co2mlo(2077,:) = (/ 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75, 469.75 /) + co2mlo(2078,:) = (/ 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02, 469.02 /) + co2mlo(2079,:) = (/ 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24, 468.24 /) + co2mlo(2080,:) = (/ 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39, 467.39 /) + co2mlo(2081,:) = (/ 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48, 466.48 /) + co2mlo(2082,:) = (/ 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54, 465.54 /) + co2mlo(2083,:) = (/ 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56, 464.56 /) + co2mlo(2084,:) = (/ 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56, 463.56 /) + co2mlo(2085,:) = (/ 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53, 462.53 /) + co2mlo(2086,:) = (/ 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47, 461.47 /) + co2mlo(2087,:) = (/ 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38, 460.38 /) + co2mlo(2088,:) = (/ 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26, 459.26 /) + co2mlo(2089,:) = (/ 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10, 458.10 /) + co2mlo(2090,:) = (/ 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92, 456.92 /) + co2mlo(2091,:) = (/ 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71, 455.71 /) + co2mlo(2092,:) = (/ 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50, 454.50 /) + co2mlo(2093,:) = (/ 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32, 453.32 /) + co2mlo(2094,:) = (/ 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16, 452.16 /) + co2mlo(2095,:) = (/ 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02, 451.02 /) + co2mlo(2096,:) = (/ 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91, 449.91 /) + co2mlo(2097,:) = (/ 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81, 448.81 /) + co2mlo(2098,:) = (/ 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73, 447.73 /) + co2mlo(2099,:) = (/ 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67, 446.67 /) + co2mlo(2100,:) = (/ 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62, 445.62 /) + !added by Zhongwang Wei @ SYSU 2022.12.12 + CASE ('245') + print *,'245' + !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) + !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) + !co2mlo(2017,:) = (/ 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.76, 405.81, 405.81 /) + !co2mlo(2018,:) = (/ 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.63, 408.83, 408.83 /) + !co2mlo(2019,:) = (/ 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.51, 411.95, 411.95 /) + !co2mlo(2020,:) = (/ 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 414.39, 415.15, 415.15 /) + !co2mlo(2021,:) = (/ 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 417.29, 418.46, 418.46 /) + !co2mlo(2022,:) = (/ 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 420.20, 421.84, 421.84 /) + co2mlo(2023,:) = (/ 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 423.12, 425.28, 425.28 /) + co2mlo(2024,:) = (/ 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 426.07, 428.78, 428.78 /) + co2mlo(2025,:) = (/ 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 429.03, 432.35, 432.35 /) + co2mlo(2026,:) = (/ 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 432.01, 435.97, 435.97 /) + co2mlo(2027,:) = (/ 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 435.01, 439.67, 439.67 /) + co2mlo(2028,:) = (/ 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 438.03, 443.43, 443.43 /) + co2mlo(2029,:) = (/ 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 441.08, 447.26, 447.26 /) + co2mlo(2030,:) = (/ 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 444.14, 451.16, 451.16 /) + co2mlo(2031,:) = (/ 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 447.23, 455.14, 455.14 /) + co2mlo(2032,:) = (/ 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 450.33, 459.17, 459.17 /) + co2mlo(2033,:) = (/ 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 453.43, 463.24, 463.24 /) + co2mlo(2034,:) = (/ 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 456.54, 467.36, 467.36 /) + co2mlo(2035,:) = (/ 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 459.65, 471.54, 471.54 /) + co2mlo(2036,:) = (/ 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 462.77, 475.76, 475.76 /) + co2mlo(2037,:) = (/ 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 465.90, 480.04, 480.04 /) + co2mlo(2038,:) = (/ 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 469.03, 484.38, 484.38 /) + co2mlo(2039,:) = (/ 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 472.18, 488.77, 488.77 /) + co2mlo(2040,:) = (/ 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 475.34, 493.22, 493.22 /) + co2mlo(2041,:) = (/ 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 478.50, 497.73, 497.73 /) + co2mlo(2042,:) = (/ 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 481.67, 502.29, 502.29 /) + co2mlo(2043,:) = (/ 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 484.84, 506.90, 506.90 /) + co2mlo(2044,:) = (/ 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 488.00, 511.56, 511.56 /) + co2mlo(2045,:) = (/ 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 491.15, 516.26, 516.26 /) + co2mlo(2046,:) = (/ 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 494.30, 521.02, 521.02 /) + co2mlo(2047,:) = (/ 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 497.45, 525.83, 525.83 /) + co2mlo(2048,:) = (/ 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 500.59, 530.69, 530.69 /) + co2mlo(2049,:) = (/ 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 503.73, 535.61, 535.61 /) + co2mlo(2050,:) = (/ 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 506.87, 540.58, 540.58 /) + co2mlo(2051,:) = (/ 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 510.01, 545.61, 545.61 /) + co2mlo(2052,:) = (/ 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 513.14, 550.69, 550.69 /) + co2mlo(2053,:) = (/ 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 516.23, 555.82, 555.82 /) + co2mlo(2054,:) = (/ 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 519.29, 561.00, 561.00 /) + co2mlo(2055,:) = (/ 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 522.33, 566.24, 566.24 /) + co2mlo(2056,:) = (/ 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 525.33, 571.53, 571.53 /) + co2mlo(2057,:) = (/ 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 528.31, 576.87, 576.87 /) + co2mlo(2058,:) = (/ 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 531.26, 582.27, 582.27 /) + co2mlo(2059,:) = (/ 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 534.19, 587.72, 587.72 /) + co2mlo(2060,:) = (/ 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 537.08, 593.23, 593.23 /) + co2mlo(2061,:) = (/ 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 539.96, 598.80, 598.80 /) + co2mlo(2062,:) = (/ 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 542.79, 604.42, 604.42 /) + co2mlo(2063,:) = (/ 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 545.59, 610.11, 610.11 /) + co2mlo(2064,:) = (/ 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 548.33, 615.85, 615.85 /) + co2mlo(2065,:) = (/ 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 551.04, 621.65, 621.65 /) + co2mlo(2066,:) = (/ 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 553.70, 627.50, 627.50 /) + co2mlo(2067,:) = (/ 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 556.32, 633.42, 633.42 /) + co2mlo(2068,:) = (/ 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 558.89, 639.40, 639.40 /) + co2mlo(2069,:) = (/ 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 561.43, 645.44, 645.44 /) + co2mlo(2070,:) = (/ 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 563.92, 651.54, 651.54 /) + co2mlo(2071,:) = (/ 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 566.38, 657.71, 657.71 /) + co2mlo(2072,:) = (/ 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 568.77, 663.93, 663.93 /) + co2mlo(2073,:) = (/ 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 571.08, 670.22, 670.22 /) + co2mlo(2074,:) = (/ 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 573.31, 676.57, 676.57 /) + co2mlo(2075,:) = (/ 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 575.47, 682.98, 682.98 /) + co2mlo(2076,:) = (/ 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 577.54, 689.46, 689.46 /) + co2mlo(2077,:) = (/ 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 579.54, 696.00, 696.00 /) + co2mlo(2078,:) = (/ 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 581.46, 702.61, 702.61 /) + co2mlo(2079,:) = (/ 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 583.30, 709.27, 709.27 /) + co2mlo(2080,:) = (/ 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 585.07, 716.01, 716.01 /) + co2mlo(2081,:) = (/ 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 586.77, 722.81, 722.81 /) + co2mlo(2082,:) = (/ 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 588.38, 729.68, 729.68 /) + co2mlo(2083,:) = (/ 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 589.89, 736.63, 736.63 /) + co2mlo(2084,:) = (/ 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 591.30, 743.66, 743.66 /) + co2mlo(2085,:) = (/ 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 592.61, 750.76, 750.76 /) + co2mlo(2086,:) = (/ 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 593.82, 757.95, 757.95 /) + co2mlo(2087,:) = (/ 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 594.94, 765.22, 765.22 /) + co2mlo(2088,:) = (/ 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 595.97, 772.56, 772.56 /) + co2mlo(2089,:) = (/ 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 596.90, 779.98, 779.98 /) + co2mlo(2090,:) = (/ 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 597.73, 787.49, 787.49 /) + co2mlo(2091,:) = (/ 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 598.48, 795.07, 795.07 /) + co2mlo(2092,:) = (/ 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 599.15, 802.74, 802.74 /) + co2mlo(2093,:) = (/ 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 599.78, 810.49, 810.49 /) + co2mlo(2094,:) = (/ 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 600.35, 818.33, 818.33 /) + co2mlo(2095,:) = (/ 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 600.89, 826.25, 826.25 /) + co2mlo(2096,:) = (/ 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 601.37, 834.27, 834.27 /) + co2mlo(2097,:) = (/ 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 601.80, 842.37, 842.37 /) + co2mlo(2098,:) = (/ 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 602.18, 850.55, 850.55 /) + co2mlo(2099,:) = (/ 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 602.51, 858.83, 858.83 /) + co2mlo(2100,:) = (/ 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 602.78, 867.19, 867.19 /) + !added by Zhongwang Wei @ SYSU 2022.12.12 + CASE ('370') + !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) + !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) + !co2mlo(2017,:) = (/ 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81, 405.81 /) + !co2mlo(2018,:) = (/ 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83, 408.83 /) + !co2mlo(2019,:) = (/ 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95, 411.95 /) + !co2mlo(2020,:) = (/ 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15, 415.15 /) + !co2mlo(2021,:) = (/ 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46, 418.46 /) + !co2mlo(2022,:) = (/ 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84, 421.84 /) + co2mlo(2023,:) = (/ 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28, 425.28 /) + co2mlo(2024,:) = (/ 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78, 428.78 /) + co2mlo(2025,:) = (/ 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35, 432.35 /) + co2mlo(2026,:) = (/ 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97, 435.97 /) + co2mlo(2027,:) = (/ 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67, 439.67 /) + co2mlo(2028,:) = (/ 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43, 443.43 /) + co2mlo(2029,:) = (/ 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26, 447.26 /) + co2mlo(2030,:) = (/ 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16, 451.16 /) + co2mlo(2031,:) = (/ 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14, 455.14 /) + co2mlo(2032,:) = (/ 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17, 459.17 /) + co2mlo(2033,:) = (/ 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24, 463.24 /) + co2mlo(2034,:) = (/ 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36, 467.36 /) + co2mlo(2035,:) = (/ 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54, 471.54 /) + co2mlo(2036,:) = (/ 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76, 475.76 /) + co2mlo(2037,:) = (/ 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04, 480.04 /) + co2mlo(2038,:) = (/ 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38, 484.38 /) + co2mlo(2039,:) = (/ 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77, 488.77 /) + co2mlo(2040,:) = (/ 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22, 493.22 /) + co2mlo(2041,:) = (/ 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73, 497.73 /) + co2mlo(2042,:) = (/ 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29, 502.29 /) + co2mlo(2043,:) = (/ 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90, 506.90 /) + co2mlo(2044,:) = (/ 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56, 511.56 /) + co2mlo(2045,:) = (/ 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26, 516.26 /) + co2mlo(2046,:) = (/ 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02, 521.02 /) + co2mlo(2047,:) = (/ 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83, 525.83 /) + co2mlo(2048,:) = (/ 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69, 530.69 /) + co2mlo(2049,:) = (/ 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61, 535.61 /) + co2mlo(2050,:) = (/ 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58, 540.58 /) + co2mlo(2051,:) = (/ 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61, 545.61 /) + co2mlo(2052,:) = (/ 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69, 550.69 /) + co2mlo(2053,:) = (/ 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82, 555.82 /) + co2mlo(2054,:) = (/ 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00, 561.00 /) + co2mlo(2055,:) = (/ 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24, 566.24 /) + co2mlo(2056,:) = (/ 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53, 571.53 /) + co2mlo(2057,:) = (/ 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87, 576.87 /) + co2mlo(2058,:) = (/ 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27, 582.27 /) + co2mlo(2059,:) = (/ 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72, 587.72 /) + co2mlo(2060,:) = (/ 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23, 593.23 /) + co2mlo(2061,:) = (/ 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80, 598.80 /) + co2mlo(2062,:) = (/ 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42, 604.42 /) + co2mlo(2063,:) = (/ 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11, 610.11 /) + co2mlo(2064,:) = (/ 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85, 615.85 /) + co2mlo(2065,:) = (/ 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65, 621.65 /) + co2mlo(2066,:) = (/ 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50, 627.50 /) + co2mlo(2067,:) = (/ 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42, 633.42 /) + co2mlo(2068,:) = (/ 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40, 639.40 /) + co2mlo(2069,:) = (/ 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44, 645.44 /) + co2mlo(2070,:) = (/ 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54, 651.54 /) + co2mlo(2071,:) = (/ 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71, 657.71 /) + co2mlo(2072,:) = (/ 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93, 663.93 /) + co2mlo(2073,:) = (/ 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22, 670.22 /) + co2mlo(2074,:) = (/ 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57, 676.57 /) + co2mlo(2075,:) = (/ 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98, 682.98 /) + co2mlo(2076,:) = (/ 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46, 689.46 /) + co2mlo(2077,:) = (/ 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00, 696.00 /) + co2mlo(2078,:) = (/ 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61, 702.61 /) + co2mlo(2079,:) = (/ 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27, 709.27 /) + co2mlo(2080,:) = (/ 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01, 716.01 /) + co2mlo(2081,:) = (/ 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81, 722.81 /) + co2mlo(2082,:) = (/ 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68, 729.68 /) + co2mlo(2083,:) = (/ 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63, 736.63 /) + co2mlo(2084,:) = (/ 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66 /) + co2mlo(2085,:) = (/ 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76, 750.76 /) + co2mlo(2086,:) = (/ 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95, 757.95 /) + co2mlo(2087,:) = (/ 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22, 765.22 /) + co2mlo(2088,:) = (/ 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56, 772.56 /) + co2mlo(2089,:) = (/ 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98, 779.98 /) + co2mlo(2090,:) = (/ 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49, 787.49 /) + co2mlo(2091,:) = (/ 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07, 795.07 /) + co2mlo(2092,:) = (/ 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74, 802.74 /) + co2mlo(2093,:) = (/ 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49, 810.49 /) + co2mlo(2094,:) = (/ 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33, 818.33 /) + co2mlo(2095,:) = (/ 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25, 826.25 /) + co2mlo(2096,:) = (/ 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27, 834.27 /) + co2mlo(2097,:) = (/ 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37, 842.37 /) + co2mlo(2098,:) = (/ 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55, 850.55 /) + co2mlo(2099,:) = (/ 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83, 858.83 /) + co2mlo(2100,:) = (/ 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19, 867.19 /) + !added by Zhongwang Wei @ SYSU 2022.12.12 + CASE ('585') + !co2mlo(2015,:) = (/ 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95, 399.95 /) + !co2mlo(2016,:) = (/ 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12, 403.12 /) + !co2mlo(2017,:) = (/ 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79, 405.79 /) + !co2mlo(2018,:) = (/ 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76, 408.76 /) + !co2mlo(2019,:) = (/ 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79, 411.79 /) + !co2mlo(2020,:) = (/ 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89, 414.89 /) + !co2mlo(2021,:) = (/ 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06, 418.06 /) + !co2mlo(2022,:) = (/ 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33, 421.33 /) + co2mlo(2023,:) = (/ 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72, 424.72 /) + co2mlo(2024,:) = (/ 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22, 428.22 /) + co2mlo(2025,:) = (/ 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83, 431.83 /) + co2mlo(2026,:) = (/ 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55, 435.55 /) + co2mlo(2027,:) = (/ 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38, 439.38 /) + co2mlo(2028,:) = (/ 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31, 443.31 /) + co2mlo(2029,:) = (/ 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36, 447.36 /) + co2mlo(2030,:) = (/ 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51, 451.51 /) + co2mlo(2031,:) = (/ 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78, 455.78 /) + co2mlo(2032,:) = (/ 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16, 460.16 /) + co2mlo(2033,:) = (/ 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68, 464.68 /) + co2mlo(2034,:) = (/ 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33, 469.33 /) + co2mlo(2035,:) = (/ 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11, 474.11 /) + co2mlo(2036,:) = (/ 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02, 479.02 /) + co2mlo(2037,:) = (/ 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07, 484.07 /) + co2mlo(2038,:) = (/ 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25, 489.25 /) + co2mlo(2039,:) = (/ 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57, 494.57 /) + co2mlo(2040,:) = (/ 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02, 500.02 /) + co2mlo(2041,:) = (/ 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61, 505.61 /) + co2mlo(2042,:) = (/ 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34, 511.34 /) + co2mlo(2043,:) = (/ 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23, 517.23 /) + co2mlo(2044,:) = (/ 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27, 523.27 /) + co2mlo(2045,:) = (/ 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46, 529.46 /) + co2mlo(2046,:) = (/ 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81, 535.81 /) + co2mlo(2047,:) = (/ 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31, 542.31 /) + co2mlo(2048,:) = (/ 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98, 548.98 /) + co2mlo(2049,:) = (/ 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80, 555.80 /) + co2mlo(2050,:) = (/ 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78, 562.78 /) + co2mlo(2051,:) = (/ 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93, 569.93 /) + co2mlo(2052,:) = (/ 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26, 577.26 /) + co2mlo(2053,:) = (/ 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78, 584.78 /) + co2mlo(2054,:) = (/ 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51, 592.51 /) + co2mlo(2055,:) = (/ 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43, 600.43 /) + co2mlo(2056,:) = (/ 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55, 608.55 /) + co2mlo(2057,:) = (/ 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87, 616.87 /) + co2mlo(2058,:) = (/ 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39, 625.39 /) + co2mlo(2059,:) = (/ 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11, 634.11 /) + co2mlo(2060,:) = (/ 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04, 643.04 /) + co2mlo(2061,:) = (/ 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17, 652.17 /) + co2mlo(2062,:) = (/ 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51, 661.51 /) + co2mlo(2063,:) = (/ 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04, 671.04 /) + co2mlo(2064,:) = (/ 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79, 680.79 /) + co2mlo(2065,:) = (/ 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74, 690.74 /) + co2mlo(2066,:) = (/ 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90, 700.90 /) + co2mlo(2067,:) = (/ 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27, 711.27 /) + co2mlo(2068,:) = (/ 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85, 721.85 /) + co2mlo(2069,:) = (/ 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65, 732.65 /) + co2mlo(2070,:) = (/ 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66, 743.66 /) + co2mlo(2071,:) = (/ 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89, 754.89 /) + co2mlo(2072,:) = (/ 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32, 766.32 /) + co2mlo(2073,:) = (/ 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93, 777.93 /) + co2mlo(2074,:) = (/ 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72, 789.72 /) + co2mlo(2075,:) = (/ 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69, 801.69 /) + co2mlo(2076,:) = (/ 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85, 813.85 /) + co2mlo(2077,:) = (/ 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19, 826.19 /) + co2mlo(2078,:) = (/ 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73, 838.73 /) + co2mlo(2079,:) = (/ 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45, 851.45 /) + co2mlo(2080,:) = (/ 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37, 864.37 /) + co2mlo(2081,:) = (/ 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48, 877.48 /) + co2mlo(2082,:) = (/ 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71, 890.71 /) + co2mlo(2083,:) = (/ 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98, 903.98 /) + co2mlo(2084,:) = (/ 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30, 917.30 /) + co2mlo(2085,:) = (/ 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67, 930.67 /) + co2mlo(2086,:) = (/ 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09, 944.09 /) + co2mlo(2087,:) = (/ 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57, 957.57 /) + co2mlo(2088,:) = (/ 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10, 971.10 /) + co2mlo(2089,:) = (/ 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68, 984.68 /) + co2mlo(2090,:) = (/ 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32, 998.32 /) + co2mlo(2091,:) = (/ 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02, 1012.02 /) + co2mlo(2092,:) = (/ 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74, 1025.74 /) + co2mlo(2093,:) = (/ 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45, 1039.45 /) + co2mlo(2094,:) = (/ 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15, 1053.15 /) + co2mlo(2095,:) = (/ 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85, 1066.85 /) + co2mlo(2096,:) = (/ 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53, 1080.53 /) + co2mlo(2097,:) = (/ 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21, 1094.21 /) + co2mlo(2098,:) = (/ 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89, 1107.89 /) + co2mlo(2099,:) = (/ 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55, 1121.55 /) + co2mlo(2100,:) = (/ 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21, 1135.21 /) + END select + + END SUBROUTINE init_monthly_co2_mlo + + real(r8) FUNCTION get_monthly_co2_mlo (year, month) + + IMPLICIT NONE + + integer, intent(in) :: year + integer, intent(in) :: month + + IF (yeareyear .or. year==eyear.and.month>4) THEN + print *, "Warning: Requested CO2 data beyond the latest record!" + print *, "Set to the latest one..." + get_monthly_co2_mlo = co2mlo(eyear, emonth) + RETURN + ENDIF + + get_monthly_co2_mlo = co2mlo(year, month) + !print *, "Set CO2 value [ppm,year,month]:",get_monthly_co2_mlo,year,month + RETURN + + END FUNCTION get_monthly_co2_mlo + +END MODULE MOD_MonthlyinSituCO2MaunaLoa +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 new file mode 100644 index 0000000000..b602d4f391 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NdepData.F90 @@ -0,0 +1,230 @@ +#include + +#ifdef BGC +MODULE MOD_NdepData +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module read in ndep data. +! +! !ORIGINAL: +! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of +! the ndep data module. +! +! !REVISIONS: +! 08/2023, Shang Fang: add year and month input for reading Nitrogen deposition +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_SpatialMapping + USE MOD_BGC_Vars_TimeVariables, only: ndep + USE MOD_BGC_Vars_1DFluxes, only: ndep_to_sminn + IMPLICIT NONE + + character(len=256) :: file_ndep + + type(grid_type) :: grid_ndep + type(spatial_mapping_type) :: mg2p_ndep + +CONTAINS + + SUBROUTINE init_ndep_data_annually (YY) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open ndep netcdf file from DEF_dir_runtime, read latitude and longitude info. +! Initialize ndep data read in. +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_LandPatch + IMPLICIT NONE + + integer, intent(in) :: YY + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + + file_ndep = trim(DEF_dir_runtime) // & + '/ndep/fndep_colm_hist_simyr1849-2006_1.9x2.5_c100428.nc' + + CALL ncio_read_bcast_serial (file_ndep, 'lat', lat) + CALL ncio_read_bcast_serial (file_ndep, 'lon', lon) + + CALL grid_ndep%define_by_center (lat, lon) + + CALL mg2p_ndep%build_arealweighted (grid_ndep, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + CALL update_ndep_data_annually (YY, iswrite = .true.) + + END SUBROUTINE init_ndep_data_annually + + SUBROUTINE init_ndep_data_monthly (YY,MM) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open ndep netcdf file from DEF_dir_runtime, read latitude and +! longitude info. Initialize ndep data read in. +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_LandPatch + IMPLICIT NONE + + integer, intent(in) :: YY,MM + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + + file_ndep = trim(DEF_dir_runtime) // '/ndep/fndep_colm_monthly.nc' + + CALL ncio_read_bcast_serial (file_ndep, 'lat', lat) + CALL ncio_read_bcast_serial (file_ndep, 'lon', lon) + + CALL grid_ndep%define_by_center (lat, lon) + + CALL mg2p_ndep%build_arealweighted (grid_ndep, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + CALL update_ndep_data_monthly (YY, MM ,iswrite = .true.) + + END SUBROUTINE init_ndep_data_monthly + + SUBROUTINE update_ndep_data_annually (YY, iswrite) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Read in the Nitrogen deposition data from CLM5. +! +! !REFERENCES: +! Galloway, J.N., et al. 2004. Nitrogen cycles: past, present, and +! future. Biogeochem. 70:153-226. +! +! !ORIGINAL: +! Created by Xingjie Lu and Shupeng Zhang, 2022 +!----------------------------------------------------------------------- + + USE MOD_MPAS_MPI + USE MOD_Namelist, only: DEF_USE_PN + USE MOD_DataType + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: YY + logical, intent(in) :: iswrite + + ! Local Variables + type(block_data_real8_2d) :: f_xy_ndep + integer :: itime, npatch, m + + itime = max(min(YY,2006),1849) - 1848 + + IF (.true.) THEN + CALL allocate_block_data (grid_ndep, f_xy_ndep) + CALL ncio_read_block_time (file_ndep, 'NDEP_year', grid_ndep, itime, f_xy_ndep) + ENDIF + + CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) + + IF (.true. .and. iswrite) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + IF(m == 0)THEN + ndep_to_sminn(npatch) = 0. + ELSE + IF(DEF_USE_PN)THEN + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. * 5 + ELSE + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. + ENDIF + ENDIF + ENDDO + + ENDIF + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('ndep', ndep) +#endif + + END SUBROUTINE update_ndep_data_annually + + SUBROUTINE update_ndep_data_monthly (YY, MM, iswrite) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Read in the Nitrogen deposition data from CLM5. +! +! !REFERENCES: +! Galloway, J.N., et al. 2004. Nitrogen cycles: past, present, and +! future. Biogeochem. 70:153-226. +! +! !ORIGINAL: +! Created by Xingjie Lu and Shupeng Zhang, 2022 +! +!----------------------------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_Namelist, only: DEF_USE_PN + USE MOD_DataType + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: YY,MM + logical, intent(in) :: iswrite + + ! Local Variables + type(block_data_real8_2d) :: f_xy_ndep + integer :: itime, npatch, m + + itime = (max(min(YY,2006),1849) - 1849)*12 + MM + + IF (.true.) THEN + CALL allocate_block_data (grid_ndep, f_xy_ndep) + CALL ncio_read_block_time (file_ndep, 'NDEP_month', grid_ndep, itime, f_xy_ndep) + ENDIF + + CALL mg2p_ndep%grid2pset (f_xy_ndep, ndep) + + IF (.true. .and. iswrite) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + IF(m == 0)THEN + ndep_to_sminn(npatch) = 0. + ELSE + IF(DEF_USE_PN)THEN + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. * 5 + ELSE + ndep_to_sminn(npatch) = ndep(npatch) / 3600. / 365. / 24. + ENDIF + ENDIF + ENDDO + + ENDIF + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('ndep', ndep) +#endif + + END SUBROUTINE update_ndep_data_monthly + +END MODULE MOD_NdepData +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar.F90 new file mode 100644 index 0000000000..68a54de178 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar.F90 @@ -0,0 +1,323 @@ +#include + +MODULE MOD_NetSolar + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: netsolar + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE netsolar (ipatch,idate,deltim,dlon,patchtype,& + forc_sols,forc_soll,forc_solsd,forc_solld,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,fsno,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + sr,solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Net solar absorbed by surface +! +! Original author: Yongjiu Dai, 09/15/1999; 09/11/2001 +! +! !REVISIONS: +! 05/2014, Hua Yuan: added for solar radiation output [vars: so*, sr*] +! +! 08/2014, Hua Yuan: added for local noon calculation +! +! 08/2020, Hua Yuan: added for PFT and PC calculation +! +! 12/2022, Hua Yuan: calculated snow layer absorption by SNICAR model +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_TimeManager, only: isgreenwich +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Vars_1DPFTFluxes +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch !patch index + integer, intent(in) :: idate(3) !model time + integer, intent(in) :: patchtype !land patch type (99-sea) + + real(r8), intent(in) :: dlon !longitude in radians + real(r8), intent(in) :: deltim !seconds in a time step [second] + + real(r8), intent(in) :: & + forc_sols, &! atm vis direct beam solar rad onto srf [W/m2] + forc_soll, &! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd, &! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ! atm nir diffuse solar rad onto srf [W/m2] + + real(r8), dimension(1:2,1:2), intent(in) :: & + alb ! averaged albedo [-] + + real(r8), dimension(1:2,1:2), intent(inout) :: & + ssun, &! sunlit canopy absorption for solar radiation + ssha, &! shaded canopy absorption for solar radiation + ssoi, &! ground soil absorption [-] + ssno ! ground snow absorption [-] + + real(r8), dimension(1:2,1:2,maxsnl+1:1), intent(inout) :: & + ssno_lyr ! snow layer absorption + + real(r8), intent(in) :: & + lai, &! leaf area index + sai, &! stem area index + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) + + real(r8), intent(in) :: & + fsno ! snow fractional cover + + real(r8), intent(out) :: & + parsun, &! PAR absorbed by sunlit vegetation [W/m2] + parsha, &! PAR absorbed by shaded vegetation [W/m2] + sabvsun, &! solar absorbed by sunlit vegetation [W/m2] + sabvsha, &! solar absorbed by shaded vegetation [W/m2] + sabg, &! solar absorbed by ground [W/m2] +! 03/06/2020, yuan: + sabg_soil, &! solar absorbed by ground soil [W/m2] + sabg_snow, &! solar absorbed by ground snow [W/m2] + sr, &! total reflected solar radiation (W/m2) + solvd, &! incident direct beam vis solar radiation (W/m2) + solvi, &! incident diffuse beam vis solar radiation (W/m2) + solnd, &! incident direct beam nir solar radiation (W/m2) + solni, &! incident diffuse beam nir solar radiation (W/m2) + srvd, &! reflected direct beam vis solar radiation (W/m2) + srvi, &! reflected diffuse beam vis solar radiation (W/m2) + srnd, &! reflected direct beam nir solar radiation (W/m2) + srni, &! reflected diffuse beam nir solar radiation (W/m2) + solvdln, &! incident direct beam vis solar radiation at local noon(W/m2) + solviln, &! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln, &! incident direct beam nir solar radiation at local noon(W/m2) + solniln, &! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln, &! reflected direct beam vis solar radiation at local noon(W/m2) + srviln, &! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln, &! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ! reflected diffuse beam nir solar radiation at local noon(W/m2) + + real(r8), intent(out) :: & + sabg_snow_lyr(maxsnl+1:1) ! solar absorbed by snow layers [W/m2] + +!-------------------------- Local Variables ---------------------------- + integer :: local_secs + real(r8) :: radpsec, sabvg, sabg_noadj + + integer ps, pe, p + +!----------------------------------------------------------------------- + + sabvsun = 0. + sabvsha = 0. + parsun = 0. + parsha = 0. + + IF (lai+sai <= 1.e-6) THEN + ssun(:,:) = 0. + ssha(:,:) = 0. + ENDIF + + sabg = 0. + sabg_soil = 0. + sabg_snow = 0. + sabg_snow_lyr(:) = 0. + + IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + sabvsun_p(ps:pe) = 0. + sabvsha_p(ps:pe) = 0. + parsun_p (ps:pe) = 0. + parsha_p (ps:pe) = 0. + + DO p = ps, pe + IF (lai_p(p)+sai_p(p) <= 1.e-6) THEN + ssun_p(:,:,p) = 0. + ssha_p(:,:,p) = 0. + ENDIF + ENDDO + + ssun(1,1) = sum( ssun_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe)*pftfrac(ps:pe) ) +#endif + ENDIF + + IF (forc_sols+forc_soll+forc_solsd+forc_solld > 0.) THEN + IF (patchtype < 4) THEN !non lake and ocean + ! Radiative fluxes onto surface + parsun = forc_sols*ssun(1,1) + forc_solsd*ssun(1,2) + parsha = forc_sols*ssha(1,1) + forc_solsd*ssha(1,2) + sabvsun = forc_sols*ssun(1,1) + forc_solsd*ssun(1,2) & + + forc_soll*ssun(2,1) + forc_solld*ssun(2,2) + sabvsha = forc_sols*ssha(1,1) + forc_solsd*ssha(1,2) & + + forc_soll*ssha(2,1) + forc_solld*ssha(2,2) + sabvg = forc_sols *(1.-alb(1,1)) + forc_solsd*(1.-alb(1,2)) & + + forc_soll *(1.-alb(2,1)) + forc_solld*(1.-alb(2,2)) + sabg = sabvg - sabvsun - sabvsha + + IF (patchtype == 0) THEN + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + + parsun_p (ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) + parsha_p (ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) + sabvsun_p(ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) & + + forc_soll*ssun_p(2,1,ps:pe) + forc_solld*ssun_p(2,2,ps:pe) + sabvsha_p(ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) & + + forc_soll*ssha_p(2,1,ps:pe) + forc_solld*ssha_p(2,2,ps:pe) +#endif + ENDIF + + ELSE !lake and ocean + sabvg = forc_sols *(1.-alb(1,1)) + forc_soll *(1.-alb(2,1)) & + + forc_solsd*(1.-alb(1,2)) + forc_solld*(1.-alb(2,2)) + sabg = sabvg + ENDIF + + ! calculate soil and snow solar absorption + sabg_soil = forc_sols*ssoi(1,1) + forc_solsd*ssoi(1,2) & + + forc_soll*ssoi(2,1) + forc_solld*ssoi(2,2) + sabg_snow = forc_sols*ssno(1,1) + forc_solsd*ssno(1,2) & + + forc_soll*ssno(2,1) + forc_solld*ssno(2,2) + + sabg_soil = sabg_soil * (1.-fsno) + sabg_snow = sabg_snow * fsno + + ! balance check and adjustment for soil and snow absorption + ! this could happen when there is adjustment to ssun,ssha + IF (abs(sabg_soil+sabg_snow-sabg)>1.e-6) THEN + IF (.not. (idate(2)==1 .and. idate(3)==int(deltim))) THEN + print *, "MOD_NetSolar.F90: NOTE imbalance in spliting soil and snow surface!", & + sabg_soil+sabg_snow-sabg + print *, "Patchtype = ", patchtype + print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow + print *, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow, "fsno:", fsno + ENDIF + + sabg_noadj = sabg_soil + sabg_snow + + IF (sabg_noadj > 0.) THEN + sabg_soil = sabg_soil * sabg/sabg_noadj + sabg_snow = sabg_snow * sabg/sabg_noadj + ssoi(:,:) = ssoi(:,:) * sabg/sabg_noadj + ssno(:,:) = ssno(:,:) * sabg/sabg_noadj + ENDIF + ENDIF + + ! snow layer absorption calculation and adjustment for SNICAR model + IF (DEF_USE_SNICAR) THEN + ! adjust snow layer absorption due to multiple reflection between ground and canopy + IF(sum(ssno_lyr(1,1,:))>0.) THEN + ssno_lyr(1,1,:) = ssno(1,1) * ssno_lyr(1,1,:)/sum(ssno_lyr(1,1,:)) + ELSE + ssno_lyr(1,1,1) = ssno(1,1) + ENDIF + + IF(sum(ssno_lyr(1,2,:))>0.) THEN + ssno_lyr(1,2,:) = ssno(1,2) * ssno_lyr(1,2,:)/sum(ssno_lyr(1,2,:)) + ELSE + ssno_lyr(1,2,1) = ssno(1,2) + ENDIF + + IF(sum(ssno_lyr(2,1,:))>0.) THEN + ssno_lyr(2,1,:) = ssno(2,1) * ssno_lyr(2,1,:)/sum(ssno_lyr(2,1,:)) + ELSE + ssno_lyr(2,1,1) = ssno(2,1) + ENDIF + + IF(sum(ssno_lyr(2,2,:))>0.) THEN + ssno_lyr(2,2,:) = ssno(2,2) * ssno_lyr(2,2,:)/sum(ssno_lyr(2,2,:)) + ELSE + ssno_lyr(2,2,1) = ssno(2,2) + ENDIF + + ! snow layer absorption + sabg_snow_lyr(:) = forc_sols*ssno_lyr(1,1,:) + forc_solsd*ssno_lyr(1,2,:) & + + forc_soll*ssno_lyr(2,1,:) + forc_solld*ssno_lyr(2,2,:) + + ! convert to the whole area multiplied by snow fractional cover + sabg_snow_lyr(:) = sabg_snow_lyr(:)*fsno + + ! attribute the first layer absorption to soil absorption + sabg_soil = sabg_soil + sabg_snow_lyr(1) + sabg_snow = sabg_snow - sabg_snow_lyr(1) + + ! make the soil absorption consistent + sabg_snow_lyr(1) = sabg_soil + ENDIF + + ENDIF + + solvd = forc_sols + solvi = forc_solsd + solnd = forc_soll + solni = forc_solld + srvd = solvd*alb(1,1) + srvi = solvi*alb(1,2) + srnd = solnd*alb(2,1) + srni = solni*alb(2,2) + sr = srvd + srvi + srnd + srni + + ! calculate the local secs + radpsec = pi/12./3600. + IF ( isgreenwich ) THEN + local_secs = idate(3) + nint((dlon/radpsec)/deltim)*deltim + local_secs = mod(local_secs,86400) + ELSE + local_secs = idate(3) + ENDIF + + IF (local_secs == 86400/2) THEN + solvdln = forc_sols + solviln = forc_solsd + solndln = forc_soll + solniln = forc_solld + srvdln = solvdln*alb(1,1) + srviln = solviln*alb(1,2) + srndln = solndln*alb(2,1) + srniln = solniln*alb(2,2) + ELSE + solvdln = spval + solviln = spval + solndln = spval + solniln = spval + srvdln = spval + srviln = spval + srndln = spval + srniln = spval + ENDIF + + END SUBROUTINE netsolar + +END MODULE MOD_NetSolar +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar_Hyper.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar_Hyper.F90 new file mode 100644 index 0000000000..7cf6d7d780 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NetSolar_Hyper.F90 @@ -0,0 +1,356 @@ +#include + +MODULE MOD_NetSolar_Hyper + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: netsolar_hyper + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE netsolar_hyper (ipatch,idate,deltim,dlon,patchtype,& + forc_sols,forc_soll,forc_solsd,forc_solld,& + alb,ssun,ssha,lai,sai,rho,tau,ssoi,ssno,ssno_lyr,fsno,& + parsun,parsha,sabvsun,sabvsha,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + sr,solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln,& + dir_frac, dif_frac, alb_hires,& + sol_dir_ln_hires,sol_dif_ln_hires,& + sr_dir_ln_hires ,sr_dif_ln_hires ) +! +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Net solar absorbed by surface +! +! Original author: Yongjiu Dai, 09/15/1999; 09/11/2001 +! +! !REVISIONS: +! 05/2014, Hua Yuan: added for solar radiation output [vars: so*, sr*] +! +! 08/2014, Hua Yuan: added for local noon calculation +! +! 08/2020, Hua Yuan: added for PFT and PC calculation +! +! 12/2022, Hua Yuan: calculated snow layer absorption by SNICAR model +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Namelist, only: DEF_USE_SNICAR + USE MOD_TimeManager, only: isgreenwich +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Vars_1DPFTFluxes +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch !patch index + integer, intent(in) :: idate(3) !model time + integer, intent(in) :: patchtype !land patch type (99-sea) + + real(r8), intent(in) :: dlon !longitude in radians + real(r8), intent(in) :: deltim !seconds in a time step [second] + + real(r8), intent(in) :: & + forc_sols, &! atm vis direct beam solar rad onto srf [W/m2] + forc_soll, &! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd, &! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ! atm nir diffuse solar rad onto srf [W/m2] + + real(r8), dimension(1:2,1:2), intent(in) :: & + alb ! averaged albedo [-] + + real(r8), dimension(1:2,1:2), intent(inout) :: & + ssun, &! sunlit canopy absorption for solar radiation + ssha, &! shaded canopy absorption for solar radiation + ssoi, &! ground soil absorption [-] + ssno ! ground snow absorption [-] + + real(r8), dimension(1:2,1:2,maxsnl+1:1), intent(inout) :: & + ssno_lyr ! snow layer absorption + + real(r8), intent(in) :: & + lai, &! leaf area index + sai, &! stem area index + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) + + real(r8), intent(in) :: & + fsno ! snow fractional cover + + real(r8), intent(out) :: & + parsun, &! PAR absorbed by sunlit vegetation [W/m2] + parsha, &! PAR absorbed by shaded vegetation [W/m2] + sabvsun, &! solar absorbed by sunlit vegetation [W/m2] + sabvsha, &! solar absorbed by shaded vegetation [W/m2] + sabg, &! solar absorbed by ground [W/m2] +! 03/06/2020, yuan: + sabg_soil, &! solar absorbed by ground soil [W/m2] + sabg_snow, &! solar absorbed by ground snow [W/m2] + sr, &! total reflected solar radiation (W/m2) + solvd, &! incident direct beam vis solar radiation (W/m2) + solvi, &! incident diffuse beam vis solar radiation (W/m2) + solnd, &! incident direct beam nir solar radiation (W/m2) + solni, &! incident diffuse beam nir solar radiation (W/m2) + srvd, &! reflected direct beam vis solar radiation (W/m2) + srvi, &! reflected diffuse beam vis solar radiation (W/m2) + srnd, &! reflected direct beam nir solar radiation (W/m2) + srni, &! reflected diffuse beam nir solar radiation (W/m2) + solvdln, &! incident direct beam vis solar radiation at local noon(W/m2) + solviln, &! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln, &! incident direct beam nir solar radiation at local noon(W/m2) + solniln, &! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln, &! reflected direct beam vis solar radiation at local noon(W/m2) + srviln, &! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln, &! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ! reflected diffuse beam nir solar radiation at local noon(W/m2) + + real(r8), intent(out) :: & + sabg_snow_lyr(maxsnl+1:1) ! solar absorbed by snow layers [W/m2] + + ! variables for high resolution + real(r8), intent(in) :: & + dir_frac (211) ,& + dif_frac (211) ,& + alb_hires(211, 2) + + real(r8), intent(out) :: & + sol_dir_ln_hires(211) ,& + sol_dif_ln_hires(211) ,& + sr_dir_ln_hires (211) ,& + sr_dif_ln_hires (211) + + +! ----------------local variables --------------------------------- + integer :: local_secs + real(r8) :: radpsec, sabvg, sabg_noadj + + integer ps, pe, p + +!----------------------------------------------------------------------- + + sabvsun = 0. + sabvsha = 0. + parsun = 0. + parsha = 0. + + IF (lai+sai <= 1.e-6) THEN + ssun(:,:) = 0. + ssha(:,:) = 0. + ENDIF + + sabg = 0. + sabg_soil = 0. + sabg_snow = 0. + sabg_snow_lyr(:) = 0. + + IF (patchtype == 0) THEN +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + sabvsun_p(ps:pe) = 0. + sabvsha_p(ps:pe) = 0. + parsun_p (ps:pe) = 0. + parsha_p (ps:pe) = 0. + + DO p = ps, pe + IF (lai_p(p)+sai_p(p) <= 1.e-6) THEN + ssun_p(:,:,p) = 0. + ssha_p(:,:,p) = 0. + ENDIF + ENDDO + + ssun(1,1) = sum( ssun_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssun(1,2) = sum( ssun_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssun(2,1) = sum( ssun_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssun(2,2) = sum( ssun_p(2,2,ps:pe)*pftfrac(ps:pe) ) + + ssha(1,1) = sum( ssha_p(1,1,ps:pe)*pftfrac(ps:pe) ) + ssha(1,2) = sum( ssha_p(1,2,ps:pe)*pftfrac(ps:pe) ) + ssha(2,1) = sum( ssha_p(2,1,ps:pe)*pftfrac(ps:pe) ) + ssha(2,2) = sum( ssha_p(2,2,ps:pe)*pftfrac(ps:pe) ) +#endif + ENDIF + + IF (forc_sols+forc_soll+forc_solsd+forc_solld > 0.) THEN + IF (patchtype < 4) THEN !non lake and ocean + ! Radiative fluxes onto surface + parsun = forc_sols*ssun(1,1) + forc_solsd*ssun(1,2) + parsha = forc_sols*ssha(1,1) + forc_solsd*ssha(1,2) + sabvsun = forc_sols*ssun(1,1) + forc_solsd*ssun(1,2) & + + forc_soll*ssun(2,1) + forc_solld*ssun(2,2) + sabvsha = forc_sols*ssha(1,1) + forc_solsd*ssha(1,2) & + + forc_soll*ssha(2,1) + forc_solld*ssha(2,2) + sabvg = forc_sols *(1.-alb(1,1)) + forc_solsd*(1.-alb(1,2)) & + + forc_soll *(1.-alb(2,1)) + forc_solld*(1.-alb(2,2)) + sabg = sabvg - sabvsun - sabvsha + + IF (patchtype == 0) THEN + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + + parsun_p (ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) + parsha_p (ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) + sabvsun_p(ps:pe) = forc_sols*ssun_p(1,1,ps:pe) + forc_solsd*ssun_p(1,2,ps:pe) & + + forc_soll*ssun_p(2,1,ps:pe) + forc_solld*ssun_p(2,2,ps:pe) + sabvsha_p(ps:pe) = forc_sols*ssha_p(1,1,ps:pe) + forc_solsd*ssha_p(1,2,ps:pe) & + + forc_soll*ssha_p(2,1,ps:pe) + forc_solld*ssha_p(2,2,ps:pe) +#endif + ENDIF + + ELSE !lake and ocean + sabvg = forc_sols *(1.-alb(1,1)) + forc_soll *(1.-alb(2,1)) & + + forc_solsd*(1.-alb(1,2)) + forc_solld*(1.-alb(2,2)) + sabg = sabvg + ENDIF + + ! calculate soil and snow solar absorption + sabg_soil = forc_sols*ssoi(1,1) + forc_solsd*ssoi(1,2) & + + forc_soll*ssoi(2,1) + forc_solld*ssoi(2,2) + sabg_snow = forc_sols*ssno(1,1) + forc_solsd*ssno(1,2) & + + forc_soll*ssno(2,1) + forc_solld*ssno(2,2) + + sabg_soil = sabg_soil * (1.-fsno) + sabg_snow = sabg_snow * fsno + + ! balance check and adjustment for soil and snow absorption + ! this could happen when there is adjustment to ssun,ssha + !NOTE: some times the imbalance may occur in URBAN patch + IF (abs(sabg_soil+sabg_snow-sabg)>1.e-6) THEN + ! IF (.not. (idate(2)==1 .and. idate(3)==int(deltim))) THEN + ! print *, "Patchtype = ", patchtype + ! print *, "MOD_NetSolar.F90: NOTE imbalance in spliting soil and snow surface!", & + ! sabg_soil+sabg_snow-sabg + ! print *, "sabg:", sabg, "sabg_soil:", sabg_soil, "sabg_snow", sabg_snow + ! print *, "sabg_soil+sabg_snow:", sabg_soil+sabg_snow, "fsno:", fsno + ! print *, "sabvg=",sabvg," sabvsun=",sabvsun," sabvsha=",sabvsha + ! print *, "alb=",alb + ! print *, "forc_sols=",forc_sols," forc_solsd=",forc_solsd + ! print *, "ssoi=",ssoi + ! ENDIF + + sabg_noadj = sabg_soil + sabg_snow + + IF (sabg_noadj > 0.) THEN + sabg_soil = sabg_soil * sabg/sabg_noadj + sabg_snow = sabg_snow * sabg/sabg_noadj + ssoi(:,:) = ssoi(:,:) * sabg/sabg_noadj + ssno(:,:) = ssno(:,:) * sabg/sabg_noadj + ENDIF + ENDIF + + ! snow layer absorption calculation and adjustment for SNICAR model + IF (DEF_USE_SNICAR) THEN + ! adjust snow layer absorption due to multiple reflection between ground and canopy + IF(sum(ssno_lyr(1,1,:))>0.) THEN + ssno_lyr(1,1,:) = ssno(1,1) * ssno_lyr(1,1,:)/sum(ssno_lyr(1,1,:)) + ELSE + ssno_lyr(1,1,1) = ssno(1,1) + ENDIF + + IF(sum(ssno_lyr(1,2,:))>0.) THEN + ssno_lyr(1,2,:) = ssno(1,2) * ssno_lyr(1,2,:)/sum(ssno_lyr(1,2,:)) + ELSE + ssno_lyr(1,2,1) = ssno(1,2) + ENDIF + + IF(sum(ssno_lyr(2,1,:))>0.) THEN + ssno_lyr(2,1,:) = ssno(2,1) * ssno_lyr(2,1,:)/sum(ssno_lyr(2,1,:)) + ELSE + ssno_lyr(2,1,1) = ssno(2,1) + ENDIF + + IF(sum(ssno_lyr(2,2,:))>0.) THEN + ssno_lyr(2,2,:) = ssno(2,2) * ssno_lyr(2,2,:)/sum(ssno_lyr(2,2,:)) + ELSE + ssno_lyr(2,2,1) = ssno(2,2) + ENDIF + + ! snow layer absorption + sabg_snow_lyr(:) = forc_sols*ssno_lyr(1,1,:) + forc_solsd*ssno_lyr(1,2,:) & + + forc_soll*ssno_lyr(2,1,:) + forc_solld*ssno_lyr(2,2,:) + + ! convert to the whole area multiplied by snow fractional cover + sabg_snow_lyr(:) = sabg_snow_lyr(:)*fsno + + ! attribute the first layer absorption to soil absorption + sabg_soil = sabg_soil + sabg_snow_lyr(1) + sabg_snow = sabg_snow - sabg_snow_lyr(1) + + ! make the soil absorption consistent + sabg_snow_lyr(1) = sabg_soil + ENDIF + + ENDIF + + solvd = forc_sols + solvi = forc_solsd + solnd = forc_soll + solni = forc_solld + srvd = solvd*alb(1,1) + srvi = solvi*alb(1,2) + srnd = solnd*alb(2,1) + srni = solni*alb(2,2) + sr = srvd + srvi + srnd + srni + + ! calculate the local secs + radpsec = pi/12./3600. + IF ( isgreenwich ) THEN + local_secs = idate(3) + nint((dlon/radpsec)/deltim)*deltim + local_secs = mod(local_secs,86400) + ELSE + local_secs = idate(3) + ENDIF + + IF (local_secs == 86400/2) THEN + solvdln = forc_sols + solviln = forc_solsd + solndln = forc_soll + solniln = forc_solld + srvdln = solvdln*alb(1,1) + srviln = solviln*alb(1,2) + srndln = solndln*alb(2,1) + srniln = solniln*alb(2,2) + + ! calculate the high resolution solar radiation, maybe not called "_ln" + sol_dir_ln_hires = (forc_sols + forc_soll ) * dir_frac(:) + sol_dif_ln_hires = (forc_solsd + forc_solld) * dif_frac(:) + sr_dir_ln_hires = sol_dir_ln_hires(:) * alb_hires(:,1) + sr_dif_ln_hires = sol_dif_ln_hires(:) * alb_hires(:,2) + + ELSE + solvdln = spval + solviln = spval + solndln = spval + solniln = spval + srvdln = spval + srviln = spval + srndln = spval + srniln = spval + + sol_dir_ln_hires = spval + sol_dif_ln_hires = spval + sr_dir_ln_hires = spval + sr_dif_ln_hires = spval + ENDIF + + END SUBROUTINE netsolar_hyper + +END MODULE MOD_NetSolar_Hyper +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NewSnow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NewSnow.F90 new file mode 100644 index 0000000000..d5bea0a205 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NewSnow.F90 @@ -0,0 +1,125 @@ +MODULE MOD_NewSnow + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: newsnow + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE newsnow (patchtype,maxsnl,deltim,t_grnd,pg_rain,pg_snow,bifall,& + t_precip,zi_soisno,z_soisno,dz_soisno,t_soisno,& + wliq_soisno,wice_soisno,fiold,snl,sag,scv,snowdp,fsno,wetwat) + +!======================================================================= +! add new snow nodes. +! Original author: Yongjiu Dai, 09/15/1999; 08/31/2002, 07/2013, 04/2014 +!======================================================================= + + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_VariablySaturatedFlow + USE MOD_Const_Physical, only: tfrz, cpliq, cpice + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: maxsnl ! maximum number of snow layers + integer, intent(in) :: patchtype ! land patch type (0=soil, 1=urban and built-up, + ! 2=wetland, 3=land ice, 4=land water bodies, 99=ocean) + real(r8), intent(in) :: deltim ! model time step [second] + real(r8), intent(in) :: t_grnd ! ground surface temperature [k] + real(r8), intent(in) :: pg_rain ! rainfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: pg_snow ! snowfall onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(in) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + real(r8), intent(in) :: t_precip ! snowfall/rainfall temperature [kelvin] + + real(r8), intent(inout) :: zi_soisno(maxsnl:0) ! interface level below a "z" level (m) + real(r8), intent(inout) :: z_soisno(maxsnl+1:0) ! layer depth (m) + real(r8), intent(inout) :: dz_soisno(maxsnl+1:0) ! layer thickness (m) + real(r8), intent(inout) :: t_soisno(maxsnl+1:0) ! soil + snow layer temperature [K] + real(r8), intent(inout) :: wliq_soisno(maxsnl+1:0) ! liquid water (kg/m2) + real(r8), intent(inout) :: wice_soisno(maxsnl+1:0) ! ice lens (kg/m2) + real(r8), intent(inout) :: fiold(maxsnl+1:0) ! fraction of ice relative to the total water + integer , intent(inout) :: snl ! number of snow layers + real(r8), intent(inout) :: sag ! non dimensional snow age [-] + real(r8), intent(inout) :: scv ! snow mass (kg/m2) + real(r8), intent(inout) :: snowdp ! snow depth (m) + real(r8), intent(inout) :: fsno ! fraction of soil covered by snow [-] + + real(r8), intent(inout), optional :: wetwat ! wetland water [mm] + +!-------------------------- Local Variables ---------------------------- + + real(r8) dz_snowf ! layer thickness rate change due to precipitation [mm/s] + integer newnode ! signification when new snow node is set, (1=yes, 0=no) + integer lb + +!----------------------------------------------------------------------- + + newnode = 0 + + dz_snowf = pg_snow/bifall + snowdp = snowdp + dz_snowf*deltim + scv = scv + pg_snow*deltim ! snow water equivalent (mm) + + IF(patchtype==2 .and. t_grnd>tfrz)THEN ! snowfall on warmer wetland + IF (present(wetwat) .and. DEF_USE_VariablySaturatedFlow) THEN + wetwat = wetwat + scv + ENDIF + scv=0.; snowdp=0.; sag=0.; fsno = 0. + ENDIF + + zi_soisno(0) = 0. + +! when the snow accumulation exceeds 10 mm, initialize a snow layer + + IF(snl==0 .and. pg_snow>0.0 .and. snowdp>=0.01)THEN + snl = -1 + newnode = 1 + dz_soisno(0) = snowdp ! meter + z_soisno (0) = -0.5*dz_soisno(0) + zi_soisno(-1) = -dz_soisno(0) + + sag = 0. ! snow age + t_soisno (0) = min(tfrz, t_precip) ! K + wice_soisno(0) = scv ! kg/m2 + wliq_soisno(0) = 0. ! kg/m2 + fiold(0) = 1. + fsno = min(1.,tanh(0.1*pg_snow*deltim)) + ENDIF + + ! -------------------------------------------------- + ! snowfall on snow pack + ! -------------------------------------------------- + ! the change of ice partial density of surface node due to precipitation + ! only ice part of snowfall is added here, the liquid part will be added latter + + IF(snl<0 .and. newnode==0)THEN + lb = snl + 1 + + wice_soisno(lb) = wice_soisno(lb)+deltim*pg_snow + dz_soisno(lb) = dz_soisno(lb)+dz_snowf*deltim + z_soisno(lb) = zi_soisno(lb) - 0.5*dz_soisno(lb) + zi_soisno(lb-1) = zi_soisno(lb) - dz_soisno(lb) + + ! update fsno by new snow event, add to previous fsno + ! shape factor for accumulation of snow = 0.1 + fsno = 1. - (1. - tanh(0.1*pg_snow*deltim))*(1. - fsno) + fsno = min(1., fsno) + + ENDIF + + END SUBROUTINE newsnow + +END MODULE MOD_NewSnow +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 new file mode 100644 index 0000000000..d2c1ce98d3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_NitrifData.F90 @@ -0,0 +1,171 @@ +#include + +#ifdef BGC +MODULE MOD_NitrifData +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module read in nitrif data. +! +! !ORIGINAL: +! Lu Xingjie and Zhang Shupeng, 2023, prepare the original version of the nitrif data module. +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_SpatialMapping + USE MOD_BGC_Vars_TimeVariables, only: tCONC_O2_UNSAT, tO2_DECOMP_DEPTH_UNSAT + IMPLICIT NONE + + type(grid_type) :: grid_nitrif + type(spatial_mapping_type) :: mg2p_nitrif + +CONTAINS + + SUBROUTINE init_nitrif_data (time) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open nitrif netcdf file from DEF_dir_runtime, read latitude and +! longitude info. Initialize nitrif data read in. +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_LandPatch + IMPLICIT NONE + + type(timestamp), intent(in) :: time + + ! Local Variables + character(len=256) :: file_nitrif + real(r8), allocatable :: lat(:), lon(:) + integer :: month, mday + + file_nitrif = trim(DEF_dir_runtime)//'/nitrif/CONC_O2_UNSAT/CONC_O2_UNSAT_l01.nc' + + CALL ncio_read_bcast_serial (file_nitrif, 'lat', lat) + CALL ncio_read_bcast_serial (file_nitrif, 'lon', lon) + + CALL grid_nitrif%define_by_center (lat, lon) + + CALL mg2p_nitrif%build_arealweighted (grid_nitrif, landpatch) + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + CALL julian2monthday (time%year, time%day, month, mday) + + CALL update_nitrif_data (month) + + END SUBROUTINE init_nitrif_data + + ! ---------- + SUBROUTINE update_nitrif_data (month) + + USE MOD_MPAS_MPI + USE MOD_Namelist + USE MOD_DataType + USE MOD_Vars_Global, only: nl_soil + USE MOD_NetCDFBlock + USE MOD_LandPatch + USE MOD_Vars_TimeInvariants + USE MOD_RangeCheck + IMPLICIT NONE + + integer, intent(in) :: month + + ! Local Variables + character(len=256) :: file_nitrif + type(block_data_real8_2d) :: f_xy_nitrif + real(r8), allocatable :: tCONC_O2_UNSAT_tmp(:) + real(r8), allocatable :: tO2_DECOMP_DEPTH_UNSAT_tmp(:) + character(len=2) :: cx + integer :: nsl, npatch, m + + IF (.true.) THEN + allocate(tCONC_O2_UNSAT_tmp (numpatch)) + allocate(tO2_DECOMP_DEPTH_UNSAT_tmp(numpatch)) + ENDIF + + IF (.true.) THEN + CALL allocate_block_data (grid_nitrif, f_xy_nitrif) + ENDIF + + DO nsl = 1, nl_soil + + write(cx,'(i2.2)') nsl + file_nitrif = trim(DEF_dir_runtime)//& + '/nitrif/CONC_O2_UNSAT/CONC_O2_UNSAT_l'//trim(cx)//'.nc' + IF (.true.) THEN + CALL ncio_read_block_time (file_nitrif, & + 'CONC_O2_UNSAT', grid_nitrif, month, f_xy_nitrif) + ENDIF + + CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tCONC_O2_UNSAT_tmp) + + IF (.true.) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + IF( m == 0 )THEN + tCONC_O2_UNSAT(nsl,npatch) = 0. + ELSE + tCONC_O2_UNSAT(nsl,npatch) = tCONC_O2_UNSAT_tmp(npatch) + ENDIF + IF (tCONC_O2_UNSAT(nsl,npatch) < 1E-10) THEN + tCONC_O2_UNSAT(nsl,npatch)=0.0 + ENDIF + ENDDO + + ENDIF + ENDIF + ENDDO + +#ifdef RangeCheck + CALL check_vector_data ('CONC_O2_UNSAT', tCONC_O2_UNSAT) +#endif + + DO nsl = 1, nl_soil + + write(cx,'(i2.2)') nsl + file_nitrif = trim(DEF_dir_runtime)//& + '/nitrif/O2_DECOMP_DEPTH_UNSAT/O2_DECOMP_DEPTH_UNSAT_l'//trim(cx)//'.nc' + IF (.true.) THEN + CALL ncio_read_block_time (file_nitrif, & + 'O2_DECOMP_DEPTH_UNSAT', grid_nitrif, month, f_xy_nitrif) + ENDIF + + CALL mg2p_nitrif%grid2pset (f_xy_nitrif, tO2_DECOMP_DEPTH_UNSAT_tmp) + + IF (.true.) THEN + IF (numpatch > 0) THEN + DO npatch = 1, numpatch + m = patchclass(npatch) + IF( m == 0 )THEN + tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) = 0. + ELSE + tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) = tO2_DECOMP_DEPTH_UNSAT_tmp(npatch) + ENDIF + IF (tO2_DECOMP_DEPTH_UNSAT(nsl,npatch) < 1E-10) THEN + tO2_DECOMP_DEPTH_UNSAT(nsl,npatch)=0.0 + ENDIF + ENDDO + + ENDIF + ENDIF + ENDDO + +#ifdef RangeCheck + CALL check_vector_data ('O2_DECOMP_DEPTH_UNSAT', tO2_DECOMP_DEPTH_UNSAT) +#endif + + IF (.true.) THEN + deallocate (tCONC_O2_UNSAT_tmp) + deallocate (tO2_DECOMP_DEPTH_UNSAT_tmp) + ENDIF + + END SUBROUTINE update_nitrif_data + +END MODULE MOD_NitrifData +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCosazi.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCosazi.F90 new file mode 100644 index 0000000000..5f8288c7d9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCosazi.F90 @@ -0,0 +1,70 @@ +#include + +MODULE MOD_OrbCosazi + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: orb_cosazi +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + FUNCTION orb_cosazi(calday, dlon, dlat, coszen) + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: calday !Julian cal day (1.xx to 365.xx) + real(r8), intent(in) :: dlat !Centered latitude (radians) + real(r8), intent(in) :: dlon !Centered longitude (radians) + real(r8), intent(in) :: coszen !cosine of sun zenith angle + real(r8) :: orb_cosazi !cosine of sun azimuth angle + +!-------------------------- Local Variables ---------------------------- + real(r8) declin !Solar declination (radians) + real(r8) eccf !Earth-sun distance factor (ie. (1/r)**2) + real(r8) lambm !Lambda m, mean long of perihelion (rad) + real(r8) lmm !Intermediate argument involving lambm + real(r8) lamb !Lambda, the earths long of perihelion + real(r8) invrho !Inverse normalized sun/earth distance + real(r8) sinl !Sine of lmm + real(r8) pi !3.14159265358979323846... + real(r8), parameter :: & + dayspy=365.0, &!days per year + ve=80.5, &!Calday of vernal equinox assumes Jan 1 = calday 1 + eccen=1.672393084E-2, &!Eccentricity + obliqr=0.409214646, &!Earths obliquity in radians + lambm0=-3.2625366E-2, &!Mean long of perihelion at the vernal equinox (radians) + mvelpp=4.92251015 !moving vernal equinox longitude of + !perihelion plus pi (radians) +!----------------------------------------------------------------------- + + pi = 4.*atan(1.) + lambm = lambm0 + (calday - ve)*2.*pi/dayspy + lmm = lambm - mvelpp + + sinl = sin(lmm) + lamb = lambm + eccen*(2.*sinl + eccen*(1.25*sin(2.*lmm) & + + eccen*((13.0/12.0)*sin(3.*lmm) - 0.25*sinl))) + invrho = (1. + eccen*cos(lamb - mvelpp)) / (1. - eccen*eccen) + + declin = asin(sin(obliqr)*sin(lamb)) + eccf = invrho*invrho + + orb_cosazi = (-1*cos(declin)*cos(calday*2.0*pi+dlon) - & + coszen*cos(dlat))/(sin(dlat)*sqrt(1-coszen*coszen)) + + IF (orb_cosazi<-1) orb_cosazi = -1 + IF (orb_cosazi>1 ) orb_cosazi = 1 + + END FUNCTION orb_cosazi + +END MODULE MOD_OrbCosazi +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCoszen.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCoszen.F90 new file mode 100644 index 0000000000..ab8ced757f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_OrbCoszen.F90 @@ -0,0 +1,84 @@ +#include + +MODULE MOD_OrbCoszen + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: orb_coszen + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + FUNCTION orb_coszen(calday,dlon,dlat) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! FUNCTION to return the cosine of the solar zenith angle. Assumes +! 365.0 days/year. Compute earth/orbit parameters using formula +! suggested by Duane Thresher. Use formulas from Berger, Andre 1978: +! Long-Term Variations of Daily Insolation and Quaternary Climatic +! Changes. J. of the Atmo. Sci. 35:2362-2367. +! +! Original version: Erik Kluzek, Oct/1997, Brian Kauffman, Jan/98 +! CCSM2.0 standard +! Yongjiu Dai (07/23/2002) +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: calday !Julian cal day (1.xx to 365.xx) + real(r8), intent(in) :: dlat !Centered latitude (radians) + real(r8), intent(in) :: dlon !Centered longitude (radians) + real(r8) :: orb_coszen + +!-------------------------- Local Variables ---------------------------- + real(r8) declin !Solar declination (radians) + real(r8) eccf !Earth-sun distance factor (ie. (1/r)**2) + real(r8) lambm !Lambda m, mean long of perihelion (rad) + real(r8) lmm !Intermediate argument involving lambm + real(r8) lamb !Lambda, the earths long of perihelion + real(r8) invrho !Inverse normalized sun/earth distance + real(r8) sinl !Sine of lmm + real(r8) pi !3.14159265358979323846... + real(r8), parameter :: & + dayspy=365.0, &!days per year + ve=80.5, &!Calday of vernal equinox assumes Jan 1 = calday 1 + eccen=1.672393084E-2, &!Eccentricity + obliqr=0.409214646, &!Earths obliquity in radians + lambm0=-3.2625366E-2, &!Mean long of perihelion at the vernal equinox (radians) + mvelpp=4.92251015 !moving vernal equinox longitude of + !perihelion plus pi (radians) +!----------------------------------------------------------------------- + + pi = 4.*atan(1.) + lambm = lambm0 + (calday - ve)*2.*pi/dayspy + lmm = lambm - mvelpp + + sinl = sin(lmm) + lamb = lambm + eccen*(2.*sinl + eccen*(1.25*sin(2.*lmm) & + + eccen*((13.0/12.0)*sin(3.*lmm) - 0.25*sinl))) + invrho = (1. + eccen*cos(lamb - mvelpp)) / (1. - eccen*eccen) + + declin = asin(sin(obliqr)*sin(lamb)) + eccf = invrho*invrho + + orb_coszen = sin(dlat)*sin(declin) & + - cos(dlat)*cos(declin)*cos(calday*2.0*pi+dlon) + + END FUNCTION orb_coszen + +END MODULE MOD_OrbCoszen +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 new file mode 100644 index 0000000000..0e871774f3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90 @@ -0,0 +1,279 @@ +#include + +Module MOD_Ozone + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This module hold the plant physiological response to the ozone, +! including vcmax response and stomata response. Ozone concentration +! can be either readin through Mod_OzoneData module or set to constant. +! +! Original: +! The Community Land Model version 5.0 (CLM5.0) +! +! !REVISIONS: +! 2022, Xingjie Lu: revised the CLM5 code to be compatible with CoLM +! code structure. +! 2024, Fang Li : used the new ozone stress parameterization scheme +! based on Li et al. (2024; GMD) +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: rgas + USE MOD_Const_PFT, only: isevg, leaf_long, woody + USE MOD_Grid + USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_Vars_1DForcing, only: forc_ozone + USE MOD_Namelist, only: DEF_USE_OZONEDATA + IMPLICIT NONE + + character(len=256) :: file_ozone + + type(grid_type) :: grid_ozone + + type(block_data_real8_2d) :: f_ozone + + type(spatial_mapping_type) :: mg2p_ozone + + SAVE + + PUBLIC :: CalcOzoneStress + PUBLIC :: init_ozone_data + PUBLIC :: update_ozone_data + +CONTAINS + + SUBROUTINE CalcOzoneStress (o3coefv,o3coefg, forc_ozone, forc_psrf, th, ram, & + rs, rb, lai, lai_old, ivt, o3uptake, sabv, deltim) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate Ozone Stress on both vcmax and stomata conductance. +! +! convert o3 from mol/mol to nmol m^-3 +!----------------------------------------------------------------------- + real(r8), intent(out) :: o3coefv + real(r8), intent(out) :: o3coefg + real(r8), intent(inout) :: forc_ozone !ozone concentration (ppbv) + real(r8), intent(in) :: forc_psrf + real(r8), intent(in) :: th + real(r8), intent(in) :: ram + real(r8), intent(in) :: rs + real(r8), intent(in) :: rb + real(r8), intent(in) :: lai + real(r8), intent(in) :: lai_old + integer , intent(in) :: ivt + real(r8), intent(inout) :: o3uptake + real(r8), intent(in) :: deltim + real(r8), intent(in) :: sabv !solar radiation absorbed by vegetation (W/m**2) + + real(r8) :: o3concnmolm3 ! o3 concentration (nmol/m^3) + real(r8) :: o3flux ! instantaneous o3 flux (nmol m^-2 s^-1) + real(r8) :: o3fluxcrit ! instantaneous o3 flux beyond threshold (nmol m^-2 s^-1) + real(r8) :: o3fluxperdt ! o3 flux per timestep (mmol m^-2) + real(r8) :: leafturn ! leaf turnover time / mortality rate (per hour) + real(r8) :: decay ! o3uptake decay rate based on leaf lifetime (mmol m^-2) + real(r8) :: lai_thresh ! LAI threshold for LAIs that asymptote and don't + real(r8) :: o3_flux_threshold !threshold below which o3flux is set to 0 (nmol m^-2 s^-1) + + real(r8), parameter :: ko3 = 1.51_r8 !F. Li + + + IF(.not. DEF_USE_OZONEDATA)THEN + forc_ozone = 100._r8 ! ozone partial pressure [ppbv] + ENDIF + + o3concnmolm3 = forc_ozone * (forc_psrf/(th * 8.314 )) + + ! calculate instantaneous flux + o3flux = o3concnmolm3/ (ko3*rs+ rb + ram) + + ! set lai_thresh + IF (isevg(ivt)) THEN + lai_thresh=0._r8 !so evergreens grow year-round + ELSE ! for deciduous vegetation + IF(ivt == 10)THEN !temperate shrub + lai_thresh=0.3_r8 + ELSE + lai_thresh=0.5_r8 + end if + end if + + + ! set o3 flux threshold + o3_flux_threshold=10._r8 + IF(ivt >= 1 .and. ivt <= 3)THEN !Needleleaf tree + o3_flux_threshold=0.8_r8 + ENDIF + IF(ivt >= 4 .and. ivt <= 8)THEN !Broadleaf tree + o3_flux_threshold=1.0_r8 + ENDIF + IF(ivt >= 9 .and. ivt <= 11)THEN !Shrub + o3_flux_threshold=6.0_r8 + ENDIF + IF(ivt >= 12 .and. ivt <= 14)THEN !Grass + o3_flux_threshold = 1.6_r8 + ENDIF + IF(ivt >= 15)THEN !Crop + o3_flux_threshold = 0.5_r8 + ENDIF + + + IF (o3flux < o3_flux_threshold) THEN + o3fluxcrit = 0._r8 + ELSE + o3fluxcrit = o3flux - o3_flux_threshold + ENDIF + + ! calculate o3 flux per timestep + IF(sabv > 0._r8)THEN !daytime + o3fluxperdt = o3fluxcrit * deltim * 0.000001_r8 + ELSE + o3fluxperdt = 0._r8 + ENDIF + + IF (lai > lai_thresh) THEN + ! o3 uptake decay + IF (isevg(ivt)) THEN + leafturn = 2._r8/(leaf_long(ivt)*365._r8*24._r8) + decay = o3uptake * leafturn * deltim/3600._r8 + ELSE + decay = o3uptake * max(0._r8,(1._r8-lai_old/lai)) + ENDIF + + !cumulative uptake (mmol m^-2) + o3uptake = min(90._r8, max(0._r8, o3uptake + o3fluxperdt - decay)) + + ELSE + o3uptake = 0._r8 + ENDIF + + IF (o3uptake == 0._r8) THEN + ! No o3 damage IF no o3 uptake + o3coefv = 1._r8 + o3coefg = 1._r8 + ELSE + ! Determine parameter values for this pft + IF(ivt >= 1 .and. ivt <= 3)THEN !Needleleaf tree + o3coefv = max(0._r8, min(1._r8, 1.005_r8 - 0.0064_r8 * o3uptake)) + o3coefg = max(0._r8, min(1._r8, 0.965_r8 * o3uptake ** (-0.041))) + ENDIF + IF(ivt >= 4 .and. ivt <= 8)THEN !Broadleaf tree + o3coefv = max(0._r8, min(1._r8, 0.943_r8 * exp(-0.0085*o3uptake))) + o3coefg = max(0._r8, min(1._r8, 0.943_r8 * exp(-0.0058*o3uptake))) + ENDIF + IF(ivt >= 9 .and. ivt <= 11)THEN !Shrub + o3coefv = max(0._r8, min(1._r8, 1.000_r8-0.074_r8 * log(o3uptake))) + o3coefg = max(0._r8, min(1._r8, 0.991_r8-0.060_r8 * log(o3uptake))) + ENDIF + IF(ivt >= 12 .and. ivt <= 14)THEN !Grass + o3coefv = max(0._r8, min(1._r8, 0.997_r8 - 0.016_r8 * o3uptake)) + o3coefg = max(0._r8, min(1._r8, 0.989_r8 - 0.045_r8 * log(o3uptake))) + ENDIF + IF(ivt >= 15)THEN !Crop + o3coefv = max(0._r8, min(1._r8, 0.909_r8 - 0.028_r8 * log(o3uptake))) + o3coefg = max(0._r8, min(1._r8, 1.005_r8 - 0.169_r8 * tanh(o3uptake))) + ENDIF + ENDIF + + END SUBROUTINE CalcOzoneStress + + + SUBROUTINE init_ozone_data (idate) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! open ozone netcdf file from DEF_dir_rawdata, read latitude and +! longitude info. Initialize Ozone data read in. +!----------------------------------------------------------------------- + + USE MOD_MPAS_MPI + USE MOD_Namelist + USE MOD_TimeManager + USE MOD_Grid + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + USE MOD_LandPatch +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + IMPLICIT NONE + + integer, intent(in) :: idate(3) + + ! Local Variables + real(r8), allocatable :: lat(:), lon(:) + integer :: itime + integer :: iyear, month, mday + character(len=8) :: syear, smonth + +! CALL julian2monthday(idate(1),idate(2),month,mday) +! iyear = idate(1) +! IF(idate(1) .lt. 2013)iyear = 2013 +! IF(idate(1) .gt. 2021)iyear = 2021 +! write(syear,"(I4.4)") iyear +! write(smonth,"(I2.2)") month + file_ozone = trim(DEF_dir_runtime) // '/Ozone//Global/OZONE-setgrid.nc' +! file_ozone = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CoLMruntime/Ozone//Global/OZONE-setgrid.nc' + + CALL ncio_read_bcast_serial (file_ozone, 'lat', lat) + CALL ncio_read_bcast_serial (file_ozone, 'lon', lon) + + CALL grid_ozone%define_by_center (lat, lon) + + CALL allocate_block_data (grid_ozone, f_ozone) + + CALL mg2p_ozone%build_arealweighted (grid_ozone, landpatch) + + itime = (idate(3) - 1800) / 10800 + (min(idate(2),365) - 1) * 8 + 1 + + CALL ncio_read_block_time (file_ozone, 'OZONE', grid_ozone, itime, f_ozone) +#ifdef RangeCheck + CALL check_block_data ('Ozone', f_ozone) +#endif + + END SUBROUTINE init_ozone_data + + SUBROUTINE update_ozone_data (time, deltim) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! read ozone data during simulation +!----------------------------------------------------------------------- + + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_NetCDFBlock +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + IMPLICIT NONE + + type(timestamp), intent(in) :: time + real(r8), intent(in) :: deltim + + ! Local Variables + type(timestamp) :: time_next + integer :: month, mday + integer :: iyear, itime + character(len=8) :: syear, smonth + + file_ozone = trim(DEF_dir_runtime) // '/Ozone/Global/OZONE-setgrid.nc' +! file_ozone = '/share/home/dq010/CoLM/data/rawdata/CROP-NITRIF/CoLMruntime/Ozone/Global/OZONE-setgrid.nc' + IF(time%sec/10800 .ne. (time%sec+int(deltim))/10800)then + itime = (time%sec - int(deltim)) / 10800 + (min(time%day,365) - 1) * 8 + 1 + CALL ncio_read_block_time (file_ozone, 'OZONE', grid_ozone, itime, f_ozone) +#ifdef RangeCheck + CALL check_block_data ('Ozone', f_ozone) +#endif + + CALL mg2p_ozone%grid2pset (f_ozone, forc_ozone) +#ifdef RangeCheck + CALL check_vector_data ('Ozone', forc_ozone) +#endif + ENDIF + + END SUBROUTINE update_ozone_data + +END MODULE MOD_Ozone +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 new file mode 100644 index 0000000000..914b3c9d0a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PhaseChange.F90 @@ -0,0 +1,823 @@ +#include + +MODULE MOD_PhaseChange + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: meltf + PUBLIC :: meltf_snicar + PUBLIC :: meltf_urban + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE meltf (patchtype,is_dry_lake,lb,nl_soil,deltim, & + fact,brr,hs,hs_soil,hs_snow,fsno,dhsdT, & + t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & + scv,snowdp,sm,xmf,porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! calculation of the phase change within snow and soil layers: +! (1) check the conditions which the phase change may take place, +! i.e., the layer temperature is great than the freezing point +! and the ice mass is not equal to zero (i.e., melting), +! or layer temperature is less than the freezing point +! and the liquid water mass is not equal to zero (i.e., freezing); +! (2) assess the rate of phase change from the energy excess (or deficit) +! after setting the layer temperature to freezing point; +! (3) re-adjust the ice and liquid mass, and the layer temperature +! +! Original author: Yongjiu Dai, /09/1999/, /03/2014/ +! +! !REVISIONS: +! 08/2020, Hua Yuan: separate soil/snow heat flux, exclude glacier (3) +! 04/2023, Nan Wei: supercooled soil water is included IF supercool is defined. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Hydro_SoilFunction + USE MOD_Const_Physical, only: tfrz, hfus, grav + USE MOD_Namelist + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + logical, intent(in) :: is_dry_lake + integer, intent(in) :: nl_soil !upper bound of array (i.e., soil layers) + integer, intent(in) :: lb !lower bound of array (i.e., snl +1) + real(r8), intent(in) :: deltim !time step [second] + real(r8), intent(in) :: t_soisno_bef(lb:nl_soil) !temperature at previous time step [K] + real(r8), intent(in) :: brr (lb:nl_soil) ! + real(r8), intent(in) :: fact(lb:nl_soil) !temporary variables + real(r8), intent(in) :: hs !net ground heat flux into the surface + real(r8), intent(in) :: hs_soil !net ground heat flux into the surface soil + real(r8), intent(in) :: hs_snow !net ground heat flux into the surface snow + real(r8), intent(in) :: fsno !snow fractional cover + real(r8), intent(in) :: dhsdT !temperature derivative of "hs" + real(r8), intent(in) :: porsl(1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw(1:nl_soil) !clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil), & + alpha_vgm(1:nl_soil), & + n_vgm (1:nl_soil), & + L_vgm (1:nl_soil), & + sc_vgm (1:nl_soil), & + fc_vgm (1:nl_soil) +#endif + real(r8), intent(in) :: dz(1:nl_soil) !soil layer thickness [m] + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) !temperature at current time step [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow mass [kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [mm/s, kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: hm(lb:nl_soil) !energy residual [W/m2] + real(r8) :: xm(lb:nl_soil) !melting or freezing within a time step [kg/m2] + real(r8) :: heatr !energy residual or loss after melting or freezing + real(r8) :: temp1 !temporary variables [kg/m2] + real(r8) :: temp2 !temporary variables [kg/m2] + real(r8) :: smp + real(r8) :: supercool(1:nl_soil) !the maximum liquid water when soil T below the tfrz [mm3/mm3] + real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 + real(r8) :: propor, tinc, we, scvold + integer j + +!----------------------------------------------------------------------- + sm = 0. + xmf = 0. + DO j = lb, nl_soil + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = wice_soisno(j) + wliq0(j) = wliq_soisno(j) + wmass0(j) = wice_soisno(j) + wliq_soisno(j) + ENDDO + + scvold=scv + we=0. + IF(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) + +! supercooling water + IF (DEF_USE_SUPERCOOL_WATER) THEN + DO j = 1, nl_soil + supercool(j) = 0.0 + IF(t_soisno(j) < tfrz .and. ((patchtype <=2) .or. is_dry_lake)) THEN + smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm + IF (porsl(j) > 0.) THEN +#ifdef Campbell_SOIL_MODEL + supercool(j) = porsl(j)*(smp/psi0(j))**(-1.0/bsw(j)) +#else + supercool(j) = soil_vliq_from_psi(smp, porsl(j), theta_r(j), -10.0, 5, & + (/alpha_vgm(j), n_vgm(j), L_vgm(j), sc_vgm(j), fc_vgm(j)/)) +#endif + ELSE + supercool(j) = 0. + ENDIF + supercool(j) = supercool(j)*dz(j)*1000. ! mm + ENDIF + ENDDO + ENDIF + + DO j = lb, nl_soil + ! Melting identification + ! IF ice exists above melt point, melt some to liquid. + IF(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)THEN + imelt(j) = 1 + t_soisno(j) = tfrz + ENDIF + + ! Freezing identification + ! IF liquid exists below melt point, freeze some to ice. + IF(j <= 0)THEN + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wliq_soisno(j) > supercool(j) .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ENDIF + ENDIF + ENDDO + +! If snow exists, but its thickness less than the critical value (0.01 m) + IF(lb == 1 .and. scv > 0.)THEN + IF(t_soisno(1) > tfrz)THEN + imelt(1) = 1 + t_soisno(1) = tfrz + ENDIF + ENDIF + +! Calculate the energy surplus and loss for melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0)THEN + tinc = t_soisno(j)-t_soisno_bef(j) + + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. ((patchtype<3) .or. is_dry_lake)) THEN + ! -> interface soil layer + ! 03/08/2020, yuan: separate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> internal layers other than the interface soil layer + hm(j) = brr(j) - tinc/fact(j) + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> snow cover + ! 03/08/2020, yuan: separate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) + ENDIF + ENDIF + + ENDIF + ENDDO + + DO j = lb, nl_soil + IF(imelt(j) == 1 .and. hm(j) < 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF +! this error was checked carefully, it results from the computed error +! of "Tridiagonal-Matrix" in SUBROUTINE "thermal". + IF(imelt(j) == 2 .and. hm(j) > 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF + ENDDO + +! The rate of melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0 .and. abs(hm(j)) > .0) THEN + xm(j) = hm(j)*deltim/hfus ! kg/m2 + + ! IF snow exists, but its thickness less than the critical value (1 cm) + ! Note: more work is need on how to tune the snow depth at this case + IF(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)THEN + temp1 = scv ! kg/m2 + scv = max(0.,temp1-xm(j)) + propor = scv/temp1 + snowdp = propor * snowdp + heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 + IF(heatr > 0.) THEN + xm(j) = heatr*deltim/hfus ! kg/m2 + hm(j) = heatr ! W/m2 + ELSE + xm(j) = 0. + hm(j) = 0. + ENDIF + sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) + xmf = hfus*sm + ENDIF + + heatr = 0. + IF(xm(j) > 0.) THEN + wice_soisno(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ELSE + IF(j <= 0) THEN ! snow + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wmass0(j) < supercool(j)) THEN + wice_soisno(j) = 0. + ELSE + wice_soisno(j) = min(wmass0(j)-supercool(j), wice0(j)-xm(j)) + ENDIF + ELSE + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ENDIF + ENDIF + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ENDIF + + wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) + + IF(abs(heatr) > 0.)THEN + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. ((patchtype<3) .or. is_dry_lake)) THEN + ! -> interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) + ELSE ! -> internal layers other than the interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ELSE ! -> snow cover + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + ENDIF + ENDIF + + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(j <= 0 .or. patchtype == 3)THEN !snow + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + ENDIF + + xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim + + IF(imelt(j) == 1 .and. j < 1) & + sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim + + ENDIF + ENDDO + + !scvold=scv + IF(lb<=0) THEN + we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we + IF(abs(we)>1.e-6) THEN + print*, 'meltf err : ', we + CALL CoLM_stop() + ENDIF + ENDIF + + END SUBROUTINE meltf + + + SUBROUTINE meltf_snicar (patchtype,is_dry_lake,lb,nl_soil,deltim, & + fact,brr,hs,hs_soil,hs_snow,fsno,sabg_snow_lyr,dhsdT, & + t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & + scv,snowdp,sm,xmf,porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! calculation of the phase change within snow and soil layers: +! (1) check the conditions which the phase change may take place, +! i.e., the layer temperature is great than the freezing point +! and the ice mass is not equal to zero (i.e., melting), +! or layer temperature is less than the freezing point +! and the liquid water mass is not equal to zero (i.e., freezing); +! (2) assess the rate of phase change from the energy excess (or deficit) +! after setting the layer temperature to freezing point; +! (3) re-adjust the ice and liquid mass, and the layer temperature +! +! Original author: Yongjiu Dai, /09/1999/, /03/2014/ +! +! !REVISIONS: +! 08/2020, Hua Yuan: separate soil/snow heat flux, exclude glacier (3) +! 01/2023, Hua Yuan: added snow layer absorption in melting calculation +! 04/2023, Nan Wei: supercooled soil water is included IF supercool is defined. +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Hydro_SoilFunction + USE MOD_Const_Physical, only: tfrz, hfus, grav + USE MOD_Namelist + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + logical, intent(in) :: is_dry_lake + integer, intent(in) :: nl_soil !upper bound of array (i.e., soil layers) + integer, intent(in) :: lb !lower bound of array (i.e., snl +1) + real(r8), intent(in) :: deltim !time step [second] + real(r8), intent(in) :: t_soisno_bef(lb:nl_soil) !temperature at previous time step [K] + real(r8), intent(in) :: brr (lb:nl_soil) ! + real(r8), intent(in) :: fact(lb:nl_soil) !temporary variables + real(r8), intent(in) :: hs !net ground heat flux into the surface + real(r8), intent(in) :: hs_soil !net ground heat flux into the surface soil + real(r8), intent(in) :: hs_snow !net ground heat flux into the surface snow + real(r8), intent(in) :: fsno !snow fractional cover + real(r8), intent(in) :: dhsdT !temperature derivative of "hs" + real(r8), intent(in) :: sabg_snow_lyr (lb:1) !snow layer absorption [W/m-2] + real(r8), intent(in) :: porsl(1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw(1:nl_soil) !clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil), & + alpha_vgm(1:nl_soil), & + n_vgm (1:nl_soil), & + L_vgm (1:nl_soil), & + sc_vgm (1:nl_soil), & + fc_vgm (1:nl_soil) +#endif + real(r8), intent(in) :: dz(1:nl_soil) !soil layer thickness [m] + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) !temperature at current time step [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow mass [kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [mm/s, kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: hm(lb:nl_soil) !energy residual [W/m2] + real(r8) :: xm(lb:nl_soil) !melting or freezing within a time step [kg/m2] + real(r8) :: heatr !energy residual or loss after melting or freezing + real(r8) :: temp1 !temporary variables [kg/m2] + real(r8) :: temp2 !temporary variables [kg/m2] + real(r8) :: smp + real(r8) :: supercool(1:nl_soil) !the maximum liquid water when soil T below the tfrz [mm3/mm3] + real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 + real(r8) :: propor, tinc, we, scvold + integer j + +!----------------------------------------------------------------------- + + sm = 0. + xmf = 0. + DO j = lb, nl_soil + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = wice_soisno(j) + wliq0(j) = wliq_soisno(j) + wmass0(j) = wice_soisno(j) + wliq_soisno(j) + ENDDO + + scvold=scv + we=0. + IF(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) + +! supercooling water + IF (DEF_USE_SUPERCOOL_WATER) THEN + DO j = 1, nl_soil + supercool(j) = 0.0 + IF(t_soisno(j) < tfrz .and. ((patchtype <= 2) .or. is_dry_lake)) THEN + smp = hfus * (t_soisno(j)-tfrz)/(grav*t_soisno(j)) * 1000. ! mm + IF (porsl(j) > 0.) THEN +#ifdef Campbell_SOIL_MODEL + supercool(j) = porsl(j)*(smp/psi0(j))**(-1.0/bsw(j)) +#else + supercool(j) = soil_vliq_from_psi(smp, porsl(j), theta_r(j), -10.0, 5, & + (/alpha_vgm(j), n_vgm(j), L_vgm(j), sc_vgm(j), fc_vgm(j)/)) +#endif + ELSE + supercool(j) = 0. + ENDIF + supercool(j) = supercool(j)*dz(j)*1000. ! mm + ENDIF + ENDDO + ENDIF + + + DO j = lb, nl_soil + ! Melting identification + ! IF ice exists above melt point, melt some to liquid. + IF(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)THEN + imelt(j) = 1 + t_soisno(j) = tfrz + ENDIF + + ! Freezing identification + ! IF liquid exists below melt point, freeze some to ice. + IF(j <= 0)THEN + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wliq_soisno(j) > supercool(j) .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ENDIF + ENDIF + ENDDO + +! If snow exists, but its thickness less than the critical value (0.01 m) + IF(lb == 1 .and. scv > 0.)THEN + IF(t_soisno(1) > tfrz)THEN + imelt(1) = 1 + t_soisno(1) = tfrz + ENDIF + ENDIF + +! Calculate the energy surplus and loss for melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0)THEN + tinc = t_soisno(j)-t_soisno_bef(j) + + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. ((patchtype<3).or.is_dry_lake)) THEN + ! -> interface soil layer + ! 03/08/2020, yuan: separate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_soil + (1.-fsno)*dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> internal layers other than the interface soil layer + IF (j<1 .or. (j==1 .and. patchtype==3)) THEN + hm(j) = brr(j) - tinc/fact(j) + sabg_snow_lyr(j) + ELSE + hm(j) = brr(j) - tinc/fact(j) + ENDIF + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ELSE ! -> snow cover + ! 03/08/2020, yuan: separate soil/snow heat flux, exclude glacier(3) + hm(j) = hs_snow + fsno*dhsdT*tinc + brr(j) - tinc/fact(j) + ENDIF + ENDIF + + ENDIF + ENDDO + + DO j = lb, nl_soil + IF(imelt(j) == 1 .and. hm(j) < 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF +! this error was checked carefully, it results from the computed error +! of "Tridiagonal-Matrix" in SUBROUTINE "thermal". + IF(imelt(j) == 2 .and. hm(j) > 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF + ENDDO + +! The rate of melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0 .and. abs(hm(j)) > .0) THEN + xm(j) = hm(j)*deltim/hfus ! kg/m2 + + ! IF snow exists, but its thickness less than the critical value (1 cm) + ! Note: more work is need on how to tune the snow depth at this case + IF(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)THEN + temp1 = scv ! kg/m2 + scv = max(0.,temp1-xm(j)) + propor = scv/temp1 + snowdp = propor * snowdp + heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 + IF(heatr > 0.) THEN + xm(j) = heatr*deltim/hfus ! kg/m2 + hm(j) = heatr ! W/m2 + ELSE + xm(j) = 0. + hm(j) = 0. + ENDIF + sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) + xmf = hfus*sm + ENDIF + + heatr = 0. + IF(xm(j) > 0.) THEN + wice_soisno(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ELSE + IF(j <= 0) THEN ! snow + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ELSE + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(wmass0(j) < supercool(j)) THEN + wice_soisno(j) = 0. + ELSE + wice_soisno(j) = min(wmass0(j)-supercool(j), wice0(j)-xm(j)) + ENDIF + ELSE + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + ENDIF + ENDIF + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ENDIF + + wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) + + IF(abs(heatr) > 0.)THEN + IF(j > lb)THEN ! => not the top layer + IF (j==1 .and. DEF_SPLIT_SOILSNOW .and. ((patchtype<3).or.is_dry_lake)) THEN + ! -> interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*(1.-fsno)*dhsdT) + ELSE ! -> internal layers other than the interface soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ENDIF + ELSE ! => top layer + IF (j==1 .or. (.not.DEF_SPLIT_SOILSNOW) .or. patchtype==3) THEN + ! -> soil layer + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ELSE ! -> snow cover + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*fsno*dhsdT) + ENDIF + ENDIF + + IF (DEF_USE_SUPERCOOL_WATER) THEN + IF(j <= 0 .or. patchtype == 3)THEN !snow + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + ELSE + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + + ENDIF + + xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim + + IF(imelt(j) == 1 .and. j < 1) & + sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim + + ENDIF + ENDDO + + !scvold=scv + IF(lb<=0) THEN + we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we + IF(abs(we)>1.e-6) THEN + print*, 'meltf err : ', we + CALL CoLM_stop() + ENDIF + ENDIF + + END SUBROUTINE meltf_snicar + + SUBROUTINE meltf_urban (lb,nl_soil,deltim, & + fact,brr,hs,dhsdT, & + t_soisno_bef,t_soisno,wliq_soisno,wice_soisno,imelt, & + scv,snowdp,sm,xmf) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! calculation of the phase change within snow and soil layers: +! +! (1) check the conditions which the phase change may take place, +! i.e., the layer temperature is great than the freezing point +! and the ice mass is not equal to zero (i.e., melting), +! or layer temperature is less than the freezing point +! and the liquid water mass is not equal to zero (i.e., freezing); +! (2) assess the rate of phase change from the energy excess (or deficit) +! after setting the layer temperature to freezing point; +! (3) re-adjust the ice and liquid mass, and the layer temperature +! +! Original author: Yongjiu Dai, /09/1999/, /03/2014/ +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Const_Physical, only: tfrz, hfus + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: nl_soil !upper bound of array (i.e., soil layers) + integer, intent(in) :: lb !lower bound of array (i.e., snl +1) + real(r8), intent(in) :: deltim !time step [second] + real(r8), intent(in) :: t_soisno_bef(lb:nl_soil) !temperature at previous time step [K] + real(r8), intent(in) :: brr (lb:nl_soil) ! + real(r8), intent(in) :: fact(lb:nl_soil) !temporary variables + real(r8), intent(in) :: hs !net ground heat flux into the surface + real(r8), intent(in) :: dhsdT !temperature derivative of "hs" + + real(r8), intent(inout) :: t_soisno (lb:nl_soil) !temperature at current time step [K] + real(r8), intent(inout) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv !snow mass [kg/m2] + real(r8), intent(inout) :: snowdp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [mm/s, kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: hm(lb:nl_soil) !energy residual [W/m2] + real(r8) :: xm(lb:nl_soil) !melting or freezing within a time step [kg/m2] + real(r8) :: heatr !energy residual or loss after melting or freezing + real(r8) :: temp1 !temporary variables [kg/m2] + real(r8) :: temp2 !temporary variables [kg/m2] + + real(r8), dimension(lb:nl_soil) :: wmass0, wice0, wliq0 + real(r8) :: propor, tinc, we, scvold + integer j + +!----------------------------------------------------------------------- + + sm = 0. + xmf = 0. + DO j = lb, nl_soil + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = wice_soisno(j) + wliq0(j) = wliq_soisno(j) + wmass0(j) = wice_soisno(j) + wliq_soisno(j) + ENDDO + + scvold=scv + we=0. + IF(lb<=0) we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0)) + + DO j = lb, nl_soil + ! Melting identification + ! IF ice exists above melt point, melt some to liquid. + IF(wice_soisno(j) > 0. .and. t_soisno(j) > tfrz)THEN + imelt(j) = 1 + t_soisno(j) = tfrz + ENDIF + + ! Freezing identification + ! IF liquid exists below melt point, freeze some to ice. + IF(wliq_soisno(j) > 0. .and. t_soisno(j) < tfrz) THEN + imelt(j) = 2 + t_soisno(j) = tfrz + ENDIF + ENDDO + +! If snow exists, but its thickness less than the critical value (0.01 m) + IF(lb == 1 .and. scv > 0.)THEN + IF(t_soisno(1) > tfrz)THEN + imelt(1) = 1 + t_soisno(1) = tfrz + ENDIF + ENDIF + +! Calculate the energy surplus and loss for melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0)THEN + tinc = t_soisno(j)-t_soisno_bef(j) + IF(j > lb)THEN + hm(j) = brr(j) - tinc/fact(j) + ELSE + hm(j) = hs + dhsdT*tinc + brr(j) - tinc/fact(j) + ENDIF + ENDIF + ENDDO + + DO j = lb, nl_soil + IF(imelt(j) == 1 .and. hm(j) < 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF +! this error was checked carefully, it results from the computed error +! of "Tridiagonal-Matrix" in SUBROUTINE "thermal". + IF(imelt(j) == 2 .and. hm(j) > 0.) THEN + hm(j) = 0. + imelt(j) = 0 + ENDIF + ENDDO + +! The rate of melting and freezing + DO j = lb, nl_soil + IF(imelt(j) > 0 .and. abs(hm(j)) > .0) THEN + xm(j) = hm(j)*deltim/hfus ! kg/m2 + + ! IF snow exists, but its thickness less than the critical value (1 cm) + ! Note: more work is need on how to tune the snow depth at this case + IF(j == 1 .and. lb == 1 .and. scv > 0. .and. xm(j) > 0.)THEN + temp1 = scv ! kg/m2 + scv = max(0.,temp1-xm(j)) + propor = scv/temp1 + snowdp = propor * snowdp + heatr = hm(j) - hfus*(temp1-scv)/deltim ! W/m2 + IF(heatr > 0.) THEN + xm(j) = heatr*deltim/hfus ! kg/m2 + hm(j) = heatr ! W/m2 + ELSE + xm(j) = 0. + hm(j) = 0. + ENDIF + sm = max(0.,(temp1-scv))/deltim ! kg/(m2 s) + xmf = hfus*sm + ENDIF + + heatr = 0. + IF(xm(j) > 0.) THEN + wice_soisno(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ELSE + wice_soisno(j) = min(wmass0(j), wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-wice_soisno(j))/deltim + ENDIF + + wliq_soisno(j) = max(0.,wmass0(j)-wice_soisno(j)) + + IF(abs(heatr) > 0.)THEN + IF(j > lb)THEN + t_soisno(j) = t_soisno(j) + fact(j)*heatr + ELSE + t_soisno(j) = t_soisno(j) + fact(j)*heatr/(1.-fact(j)*dhsdT) + ENDIF + IF(wliq_soisno(j)*wice_soisno(j) > 0.) t_soisno(j) = tfrz + ENDIF + + xmf = xmf + hfus * (wice0(j)-wice_soisno(j))/deltim + + IF(imelt(j) == 1 .and. j < 1) & + sm = sm + max(0.,(wice0(j)-wice_soisno(j)))/deltim + + ENDIF + ENDDO + + !scvold=scv + IF(lb<=0) THEN + we = sum(wice_soisno(lb:0)+wliq_soisno(lb:0))-we + IF(abs(we)>1.e-6) THEN + print*, 'meltf err : ', we + CALL CoLM_stop() + ENDIF + ENDIF + + END SUBROUTINE meltf_urban + +END MODULE MOD_PhaseChange +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 new file mode 100644 index 0000000000..e06656a824 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_PlantHydraulic.F90 @@ -0,0 +1,1096 @@ + +MODULE MOD_PlantHydraulic + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist, only: DEF_RSS_SCHEME + USE MOD_MPAS_MPI + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: PlantHydraulicStress_twoleaf + PUBLIC :: getvegwp_twoleaf + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: calcstress_twoleaf + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + + SUBROUTINE PlantHydraulicStress_twoleaf (nl_soil ,nvegwcs ,z_soi ,& + dz_soi ,rootfr ,psrf ,qsatl ,& + qaf ,tl ,rb ,rss ,& + ra ,rd ,rstfacsun ,rstfacsha ,cintsun ,& + cintsha ,laisun ,laisha ,rhoair ,fwet ,& + sai ,kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& + psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,htop ,& + ck ,smp ,hk ,hksati ,vegwp ,& + etrsun ,etrsha ,rootflux ,qg ,& + qm ,gs0sun ,gs0sha ,k_soil_root,k_ax_root ,& + gssun ,gssha) + +!======================================================================= +! +! calculation of plant hydraulic stress +! +! Author: Xingjie Lu, 16/01/2019, modified from CLM5 plant_hydraulic_stress module +! +!---------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer ,intent(in) :: nl_soil ! upper bound of array + integer ,intent(in) :: nvegwcs ! upper bound of array + real(r8),intent(in), dimension(nl_soil) :: & + z_soi, &! soil node depth (m) + dz_soi ! soil layer thicknesses (m) + real(r8),intent(inout), dimension(nvegwcs) :: & + vegwp ! vegetation water potential + real(r8),intent(inout):: & + gs0sun, & ! maximum stomata conductance of sunlit leaf + gs0sha ! maximum stomata conductance of shaded leaf + + real(r8),intent(in) :: & + rss, &! soil surface resistance [s/m] + psrf, &! surface atmospheric pressure (pa) + qg, &! specific humidity at ground surface [kg/kg] + qm ! specific humidity at reference height [kg/kg] + + real(r8),intent(in) :: & + qsatl, &! leaf specific humidity [kg/kg] + qaf, &! humidity of canopy air [kg/kg] + tl, &! leaf temperature (K) + + rb, &! boundary resistance from canopy to cas (s m-1) + rd, &! aerodynamical resistance between ground and canopy air + ra ! aerodynamic resistance from cas to reference height (s m-1) + + real(r8),intent(inout) :: & + rstfacsun, &! canopy resistance stress factors to soil moisture for sunlit leaf + rstfacsha ! canopy resistance stress factors to soil moisture for shaded leaf + + real(r8),intent(in) :: & + laisun, &! sunlit leaf area index, one-sided + laisha, &! shaded leaf area index, one-sided + sai, &! stem area index + kmax_sun, & + kmax_sha, & + kmax_xyl, & + kmax_root, & + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + htop, &! canopy top [m] + ck, &! shape-fitting parameter for vulnerability curve (-) + rhoair, &! density [kg/m**3] + fwet ! fraction of foliage that is wet [-] + + real(r8),intent(in), dimension(3) :: & + cintsun, &! scaling up from sunlit leaf to canopy + cintsha ! scaling up from shaded leaf to canopy + + real(r8),intent(in), dimension(nl_soil) :: & + smp, &! soil matrix potential + rootfr, &! root fraction + hksati, &! hydraulic conductivity at saturation [mm h2o/s] + hk ! soil hydraulic conductance [mm h2o/s] + + + real(r8),intent(out) :: &! ATTENTION : all for canopy not leaf + etrsun, &! transpiration from sunlit leaf (mm/s) + etrsha ! transpiration from shaded leaf (mm/s) + + real(r8),intent(out),dimension(nl_soil) :: & + rootflux ! root water uptake from different layers + + real(r8),intent(inout),dimension(nl_soil) :: k_soil_root ! radial root and soil conductance + real(r8),intent(inout),dimension(nl_soil) :: k_ax_root ! axial root conductance + real(r8),intent(inout) :: gssun ! sunlit leaf conductance + real(r8),intent(inout) :: gssha ! shaded leaf conductance + +!-------------------------- Local Variables ---------------------------- + + integer, parameter :: iterationtotal = 6 + + real(r8) c3, &! c3 vegetation : 1; 0 for c4 + + tprcor, &! coefficient for unit transfer + gb_mol ! one side leaf boundary layer conductance of sunlit leaf (leaf scale:umol H2O m-2 s-1) + + real(r8), dimension(nl_soil) :: & + fs !root conductance scale factor (reduction in conductance due to decreasing (more negative) root water potential) + real(r8), dimension(nl_soil) :: & + rai ! soil-root interface conductance [mm/s] + + real(r8) soilflux ! soil-root interface conductance [mm/s] + real(r8) soil_conductance ! soil conductance + real(r8) root_conductance ! root conductance + real(r8) r_soil ! root spacing [m] + real(r8) root_biomass_density ! root biomass density [g/m3] + real(r8) root_cross_sec_area ! root cross sectional area [m2] + real(r8) root_length_density ! root length density [m/m3] + real(r8) croot_average_length ! average coarse root length [m] + real(r8) rs_resis ! combined soil-root resistance [s] + real(r8) cf ! s m**2/umol -> s/m + + real(r8), parameter :: croot_lateral_length = 0.25_r8 ! specified lateral coarse root length [m] + real(r8), parameter :: c_to_b = 2.0_r8 ! (g biomass /g C) + real(r8), parameter :: rpi = 3.14159265358979_r8 + integer , parameter :: root = 4 + real(r8), parameter :: toldb = 1.e-2_r8 ! tolerance for satisfactory bsun/bsha solution + real(r8), parameter :: K_axs = 2.0e-1 + + ! temporary input + real(r8), parameter :: froot_carbon = 288.392056287006_r8 + real(r8), parameter :: root_radius = 2.9e-4_r8 + real(r8), parameter :: root_density = 310000._r8 + real(r8), parameter :: froot_leaf = 1.5_r8 + real(r8), parameter :: krmax = 3.981071705534969e-009_r8 + + real(r8),dimension(nvegwcs) :: x ! vegetation water potential + + integer j + +!----------------calculate root-soil interface conductance----------------- + DO j = 1,nl_soil + + ! calculate conversion from conductivity to conductance + root_biomass_density = c_to_b * froot_carbon * rootfr(j) / dz_soi(j) + ! ensure minimum root biomass (using 1gC/m2) + root_biomass_density = max(c_to_b*1._r8,root_biomass_density) + + ! Root length density: m root per m3 soil + root_cross_sec_area = rpi*root_radius**2 + root_length_density = root_biomass_density / (root_density * root_cross_sec_area) + + ! Root-area index (RAI) + rai(j) = (sai+laisun+laisha) * froot_leaf * rootfr(j) + + ! fix coarse root_average_length to specified length + croot_average_length = croot_lateral_length + + ! calculate r_soil using Gardner/spa equation (Bonan, GMD, 2014) + r_soil = sqrt(1./(rpi*root_length_density)) + + ! length scale approach + soil_conductance = min(hksati(j),hk(j))/(1.e3*r_soil) + + ! USE vegetation plc function to adjust root conductance + fs(j)= plc(amax1(smp(j),-1._r8),psi50_root,ck) + + ! krmax is root conductance per area per length + root_conductance = (fs(j)*rai(j)*krmax)/(croot_average_length + z_soi(j)) + soil_conductance = max(soil_conductance, 1.e-16_r8) + root_conductance = max(root_conductance, 1.e-16_r8) + + ! sum resistances in soil and root + rs_resis = 1._r8/soil_conductance + 1._r8/root_conductance + + ! conductance is inverse resistance + ! explicitly set conductance to zero for top soil layer + IF(rai(j)*rootfr(j) > 0._r8) THEN + k_soil_root(j) = 1._r8/rs_resis + ELSE + k_soil_root(j) = 0. + ENDIF + k_ax_root(j) = (rootfr(j)/(dz_soi(j)*1000))*K_axs*0.6 + ENDDO +!======================================================================= + + tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor + + ! one side leaf boundary layer conductance for water vapor [=1/(2*rb)] + ! ATTENTION: rb in CLM is for one side leaf, but for SiB2 rb for + ! 2-side leaf, so the gbh2o shold be " 0.5/rb * tprcor/tl " + gb_mol = 1./rb * cf ! resistance to conductance (s/m -> umol/m**2/s) + + x = vegwp(1:nvegwcs) + + CALL calcstress_twoleaf(x, nvegwcs, rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& + gb_mol, gs0sun, gs0sha, qsatl, qaf, qg, qm, rhoair, & + psrf, fwet, laisun, laisha, sai, htop, tl, kmax_sun, & + kmax_sha, kmax_xyl, kmax_root, psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, & + nl_soil, z_soi, rss, ra, rd, smp, k_soil_root, k_ax_root, gssun, gssha) + + vegwp(1:nvegwcs) = x + + END SUBROUTINE PlantHydraulicStress_twoleaf + + SUBROUTINE calcstress_twoleaf(x,nvegwcs,rstfacsun, rstfacsha, etrsun, etrsha, rootflux,& + gb_mol, gs0sun, gs0sha, qsatl, qaf, qg, qm,rhoair,& + psrf, fwet, laisun, laisha, sai, htop, tl, kmax_sun, kmax_sha, kmax_xyl, kmax_root, & + psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, nl_soil, z_soi, rss, raw, rd, smp, & + k_soil_root, k_ax_root, gssun, gssha) + ! + ! DESCRIPTIONS + ! compute the transpiration stress using a plant hydraulics approach + ! calls spacF, spacA, and getvegwp + ! + ! !ARGUMENTS: + integer, intent(in) :: nvegwcs + real(r8), intent(inout) :: x(nvegwcs) ! working copy of vegwp(p,:) + real(r8), intent(out) :: rstfacsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8), intent(out) :: rstfacsha ! shaded sunlit canopy transpiration wetness factor (0 to 1) + real(r8), intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) + real(r8), intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) + real(r8), intent(out) :: rootflux(nl_soil) ! root water uptake from different layers + + integer, intent(in) :: nl_soil + real(r8), intent(in) :: z_soi(nl_soil) + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: gs0sun ! sunlit Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8), intent(in) :: gs0sha ! shaded Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8), intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8), intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density [kg/m**3] + real(r8), intent(in) :: psrf ! atmospheric pressure [Pa] + real(r8), intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8), intent(in) :: rss ! soil surface resistance [s/m] + real(r8), intent(in) :: raw ! moisture resistance [s/m] + real(r8), intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8), intent(in) :: laisun ! Sunlit leaf area index + real(r8), intent(in) :: laisha ! Shaded leaf area index + real(r8), intent(in) :: sai ! stem area index + real(r8), intent(in) :: htop ! canopy top [m] + real(r8), intent(in) :: tl ! leaf temperature + real(r8), intent(in) :: kmax_sun + real(r8), intent(in) :: kmax_sha + real(r8), intent(in) :: kmax_xyl + real(r8), intent(in) :: kmax_root + real(r8), intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), intent(in) :: ck ! + real(r8), intent(in) :: smp(nl_soil) ! soil matrix potential + real(r8), intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] + real(r8), intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] + real(r8), intent(out) :: gssun ! sunlit leaf conductance + real(r8), intent(out) :: gssha ! shaded leaf conductance + + + real(r8) :: wtl ! water conductance for leaf [m/s] + real(r8) :: A(nvegwcs,nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=A*f + real(r8) :: f(nvegwcs) ! flux divergence (mm/s) + real(r8) :: dx(nvegwcs) ! change in vegwp from one iter to the next [mm] + real(r8) :: qflx_sun ! [kg/m2/s] + real(r8) :: qflx_sha ! [kg/m2/s] + real(r8) :: qeroot,dqeroot + real(r8),dimension(nl_soil) :: xroot ! local gs_mol copies + integer :: i,j ! index + real(r8) :: cf ! s m**2/umol -> s/m + integer :: iter,iterqflx ! newton's method iteration number + logical :: flag ! signal that matrix was not invertible + logical :: night ! signal to store vegwp within this routine, b/c it is night-time and full suite won't be called + integer, parameter :: itmax=50 ! EXIT newton's method IF iters>itmax + real(r8),parameter :: toldx=1.e-9 !tolerances for a satisfactory solution + real(r8),parameter :: tolf = 1.e-6_r8 + real(r8),parameter :: tolf_leafxyl = 1.e-16_r8 + real(r8),parameter :: tolf_root = 1.e-14_r8 !tolerances for a satisfactory solution + logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs + logical :: haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top + real(r8) :: soilflux ! total soil column transpiration [mm/s] + real(r8) :: x_root_top + real(r8) :: x_root_top1 + real(r8) :: x_root_top2 + real(r8) :: dxsoiltop + real(r8) :: maxscale + real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai WHERE transpiration is calc'd + integer, parameter :: leafsun=1 + integer, parameter :: leafsha=2 + integer, parameter :: xyl=3 + integer, parameter :: root=4 + real(r8) fsto1,fsto2,fx,fr,grav1 + real(r8) tprcor + !------------------------------------------------------------------------------ + + !temporary flag for night time vegwp(sun)>0 + + gssun=gs0sun + gssha=gs0sha + CALL getqflx_gs2qflx_twoleaf(gb_mol,gssun,gssha,qflx_sun,qflx_sha,qsatl,qaf,& + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) + x_root_top = x(root) + + IF(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)THEN + CALL getrootqflx_x2qe(nl_soil,smp,x_root_top ,z_soi,k_soil_root,k_ax_root,qeroot,dqeroot) + + CALL spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,sai,htop,& + qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& + psi50_sun,psi50_sha,psi50_xyl,psi50_root,ck) + + IF ( maxval(abs(dx)) > 200000._r8) THEN + maxscale = min(maxval(abs(dx)),maxval(abs(x))) / 2 + dx = maxscale * dx / maxval(abs(dx))! * log(maxval(abs(dx))/maxscale) !rescale step to max of 50000 + ENDIF + + x=x+dx + + ! this is a catch to force spac gradient to atmosphere + IF ( x(xyl) > x(root) ) x(xyl) = x(root) + IF ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) + IF ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) + + ! compute attenuated flux; the actual transpiration + etrsun=qflx_sun*plc(x(leafsun),psi50_sun,ck) + etrsha=qflx_sha*plc(x(leafsha),psi50_sha,ck) + + ! retrieve stressed stomatal conductance + CALL getqflx_qflx2gs_twoleaf(gb_mol,gssun,gssha,etrsun,etrsha,qsatl,qaf,& + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) + + tprcor = 44.6*273.16*psrf/1.013e5 + ! compute water stress + ! .. generally -> B= gs_stressed / gs_unstressed + ! .. when gs=0 -> B= plc( x ) + rstfacsun = amax1(gssun/gs0sun,1.e-2_r8) + rstfacsha = amax1(gssha/gs0sha,1.e-2_r8) + qeroot = etrsun + etrsha + CALL getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) + x(root) = x_root_top + DO j = 1,nl_soil + rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) + ENDDO + ELSE + IF ( x(xyl) > x(root) ) x(xyl) = x(root) + IF ( x(leafsun) > x(xyl) ) x(leafsun) = x(xyl) + IF ( x(leafsha) > x(xyl) ) x(leafsha) = x(xyl) + etrsun = 0._r8 + etrsha = 0._r8 + rstfacsun = amax1(plc(x(leafsun),psi50_sun,ck),1.e-2_r8) + rstfacsha = amax1(plc(x(leafsha),psi50_sha,ck),1.e-2_r8) + gssun = gs0sun * rstfacsun + gssha = gs0sha * rstfacsha + rootflux = 0._r8 + ENDIF + + soilflux = sum(rootflux(:)) + + END SUBROUTINE calcstress_twoleaf + + !------------------------------------------------------------------------------ + SUBROUTINE spacAF_twoleaf(x,nvegwcs,dx,nl_soil,qflx_sun,qflx_sha,laisun,laisha,sai,htop,& + qeroot,dqeroot,kmax_sun,kmax_sha,kmax_xyl,kmax_root,& + psi50_sun,psi50_sha,psi50_xyl,psi50_root,ck) +!----------------------------------------------------------------------- +! !DESCRIPTION +! Returns invA, the inverse matrix relating delta(vegwp) to f +! d(vegwp)=invA*f +! evaluated at vegwp(p) +! +! The methodology is currently hardcoded for linear algebra assuming the +! number of vegetation segments is four. Thus the matrix A and it's inverse +! invA are both 4x4 matrices. A more general method could be done using for +! example a LINPACK linear algebra solver. +! +!----------------------------------------------------------------------- +! !ARGUMENTS: + integer , intent(in) :: nvegwcs + real(r8), intent(in) :: x(nvegwcs) ! working copy of veg water potential for patch p [mm H2O] + real(r8), intent(out) :: dx(nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=invA*f + integer , intent(in) :: nl_soil + real(r8), intent(in) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8), intent(in) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8), intent(in) :: laisun ! Sunlit leaf area index + real(r8), intent(in) :: laisha ! Shaded leaf area index + real(r8), intent(in) :: sai ! Stem area index + real(r8), intent(in) :: htop ! Canopy top [m] + real(r8), intent(in) :: qeroot ! soil-root interface conductance [mm/s] + real(r8), intent(in) :: dqeroot ! soil-root interface conductance [mm/s] + real(r8), intent(in) :: kmax_sun + real(r8), intent(in) :: kmax_sha + real(r8), intent(in) :: kmax_xyl + real(r8), intent(in) :: kmax_root + real(r8), intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), intent(in) :: ck + ! + ! !LOCAL VARIABLES: + real(r8) wtl ! heat conductance for leaf [m/s] + real(r8) fsto1 ! sunlit transpiration reduction function [-] + real(r8) fsto2 ! shaded transpiration reduction function [-] + real(r8) fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) dfsto1 ! 1st derivative of fsto1 w.r.t. change in vegwp + real(r8) dfsto2 ! 1st derivative of fsto2 w.r.t. change in vegwp + real(r8) dfx ! 1st derivative of fx w.r.t. change in vegwp + real(r8) dfr ! 1st derivative of fr w.r.t. change in vegwp + real(r8) A11, A13, A22, A23, A31, A32, A33, A34, A43, A44 ! matrix relating vegwp to flux divergence f=A*d(vegwp) + real(r8) leading ! inverse of determiniant + real(r8) determ ! determinant of matrix + real(r8) grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) invfactor ! + real(r8) f(nvegwcs) + real(r8), parameter :: tol_lai=1.e-7_r8 ! minimum lai WHERE transpiration is calc'd + integer, parameter :: leafsun=1 + integer, parameter :: leafsha=2 + integer, parameter :: xyl=3 + integer, parameter :: root=4 + integer :: j ! index + !------------------------------------------------------------------------------ + + grav1 = htop*1000._r8 + + !compute conductance attenuation for each segment + fsto1 = plc(x(leafsun),psi50_sun,ck) + fsto2 = plc(x(leafsha),psi50_sha,ck) + fx = plc(x(xyl),psi50_xyl,ck) + fr = plc(x(root),psi50_root,ck) + + !compute 1st deriv of conductance attenuation for each segment + dfsto1 = d1plc(x(leafsun),psi50_sun,ck) + dfsto2 = d1plc(x(leafsha),psi50_sha,ck) + dfx = d1plc(x(xyl),psi50_xyl,ck) + dfr = d1plc(x(root),psi50_root,ck) + + + A11 = - laisun * kmax_sun * fx - qflx_sun * dfsto1 + A13 = laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) + laisun * kmax_sun * fx + A22 = - laisha * kmax_sha * fx - qflx_sha * dfsto2 + A23 = laisha * kmax_sha * dfx * (x(xyl)-x(leafsha)) + laisha * kmax_sha * fx + A31 = laisun * kmax_sun * fx + A32 = laisha * kmax_sha * fx + A33 = - laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) - laisun * kmax_sun * fx& + - laisha * kmax_sha * dfx * (x(xyl)-x(leafsha)) - laisha * kmax_sha * fx& + - sai * kmax_xyl / htop * fr + A34 = sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1) + sai * kmax_xyl / htop * fr + A43 = sai * kmax_xyl / htop * fr + A44 = - sai * kmax_xyl / htop * fr& + - sai * kmax_xyl / htop * dfr * (x(root)-x(xyl)-grav1) + dqeroot + + !compute flux divergence across each plant segment + f(leafsun) = qflx_sun * fsto1 - laisun * kmax_sun * fx * (x(xyl)-x(leafsun)) + f(leafsha) = qflx_sha * fsto2 - laisha * kmax_sha * fx * (x(xyl)-x(leafsha)) + f(xyl) = laisun * kmax_sun * fx * (x(xyl)-x(leafsun))& + + laisha * kmax_sha * fx * (x(xyl)-x(leafsha)) & + - sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) + f(root) = sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) - qeroot + + IF(qflx_sha > 0 )THEN + determ=A44*A22*A33*A11-A44*A22*A31*A13-A44*A32*A23*A11-A43*A11*A22*A34 + + IF(determ .ne. 0)THEN + dx(leafsun) = ((A22*A33*A44 - A22*A34*A43 - A23*A32*A44)*f(leafsun) + A13*A32*A44*f(leafsha) & + - A13*A22*A44*f(xyl) + A13*A22*A34*f(root)) / determ + dx(leafsha) = ( A23*A31*A44*f(leafsun) + (A11*A33*A44 - A11*A34*A43 - A13*A31*A44)*f(leafsha) & + - A11*A23*A44*f(xyl) + A11*A23*A34*f(root)) / determ + dx(xyl) = (-A22*A31*A44*f(leafsun) - A11*A32*A44*f(leafsha) & + + A11*A22*A44*f(xyl) - A11*A22*A34*f(root)) / determ + dx(root) = ( A22*A31*A43*f(leafsun) + A11*A32*A43*f(leafsha) & + - A11*A22*A43*f(xyl) +(A11*A22*A33 - A11*A23*A32 - A13*A22*A31)*f(root)) / determ + ELSE + dx = 0._r8 + ENDIF + ELSE + A33 = - laisun * kmax_sun * dfx * (x(xyl)-x(leafsun)) - laisun * kmax_sun * fx - sai * kmax_xyl / htop * fr + f(xyl) = laisun * kmax_sun * fx * (x(xyl)-x(leafsun)) - sai * kmax_xyl / htop * fr * (x(root)-x(xyl)-grav1) + determ=A11*A33*A44-A34*A11*A43-A13*A31*A44 + IF(determ .ne. 0)THEN + dx(leafsun) = (- A13*A44*f(xyl) + A13*A34*f(root) + (A33*A44 - A34*A43)*f(leafsun)) / determ + dx(xyl) = ( A11*A44*f(xyl) - A11*A34*f(root) - A31*A44*f(leafsun)) / determ + dx(root) = (- A11*A43*f(xyl) + (A11*A33 - A13*A31)*f(root) + A31*A43*f(leafsun)) / determ + + dx(leafsha) = x(leafsun) - x(leafsha) + dx(leafsun) + ELSE + dx = 0._r8 + ENDIF + ENDIF + + END SUBROUTINE spacAF_twoleaf + + SUBROUTINE getvegwp_twoleaf(x, nvegwcs, nl_soil, z_soi, gb_mol, gs_mol_sun, gs_mol_sha, & + qsatl, qaf,qg,qm,rhoair, psrf, fwet, laisun, laisha, htop, sai, tl, rss, & + raw, rd, smp, k_soil_root, k_ax_root, kmax_xyl, kmax_root, rstfacsun, rstfacsha, & + psi50_sun, psi50_sha, psi50_xyl, psi50_root, ck, rootflux, etrsun, etrsha) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculates transpiration and returns corresponding vegwp in x +! +! !USES: +! calls getqflx +!----------------------------------------------------------------------- + USE MOD_Const_Physical, only: tfrz + IMPLICIT NONE + ! + ! !ARGUMENTS: + integer, intent(in) :: nvegwcs + real(r8), intent(out) :: x(nvegwcs) ! working copy of veg water potential for patch p + integer, intent(in) :: nl_soil ! number of soil layers + real(r8), intent(in) :: z_soi(nl_soil) ! node depth [m] + real(r8), intent(in) :: gb_mol ! Leaf boundary layer conductance [umol H2O/m**2/s] + real(r8), intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance [umol H2O/m**2/s] + real(r8), intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance [umol H2O/m**2/s] + real(r8), intent(in) :: qsatl ! Sunlit leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8), intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8), intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density [kg/m**3] + real(r8), intent(in) :: psrf ! atmospheric pressure [Pa] + real(r8), intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8), intent(in) :: laisun ! Sunlit leaf area index + real(r8), intent(in) :: laisha ! Shaded leaf area index + real(r8), intent(in) :: htop ! canopy top [m] + real(r8), intent(in) :: sai ! stem area index + real(r8), intent(in) :: tl ! leaf temperature + real(r8), intent(in) :: kmax_xyl + real(r8), intent(in) :: kmax_root + real(r8), intent(in) :: rstfacsun + real(r8), intent(in) :: rstfacsha + real(r8), intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) + real(r8), intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8), intent(in) :: ck ! + real(r8), intent(in) :: rss ! soil surface resistance [s/m] + real(r8), intent(in) :: raw ! moisture resistance [s/m] + real(r8), intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8), intent(in) :: smp(nl_soil) ! soil matrix potential + real(r8), intent(in) :: k_soil_root(nl_soil) ! soil-root interface conductance [mm/s] + real(r8), intent(in) :: k_ax_root(nl_soil) ! root axial-direction conductance [mm/s] + real(r8), intent(out) :: etrsun ! transpiration from sunlit leaf (mm/s) + real(r8), intent(out) :: etrsha ! transpiration from shaded leaf (mm/s) + real(r8), intent(out) :: rootflux(nl_soil) ! root water uptake from different layers + ! + ! !LOCAL VARIABLES: +! real(r8) qflx_sun ! Sunlit leaf transpiration [kg/m2/s] +! real(r8) qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8) qeroot + real(r8) dummy + real(r8) fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) x_root_top + real(r8) xroot(nl_soil) + real(r8) grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) grav2(nl_soil) ! soil layer gravitational potential relative to surface (mm H2O) + integer j ! index + logical havegs ! signals direction of calculation gs->qflx or qflx->gs + logical haroot ! signals direction of calculation x_root_top->qeroot or qeroot->x_root_top + integer, parameter :: leafsun=1 + integer, parameter :: leafsha=2 + integer, parameter :: xyl=3 + integer, parameter :: root=4 + real(r8) :: soilflux ! total soil column transpiration [mm/s] + + !---------------------------------------------------------------------- + grav1 = 1000._r8 * htop + grav2(1:nl_soil) = 1000._r8 * z_soi(1:nl_soil) + + !compute transpiration demand + havegs=.true. + CALL getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,etrsun,etrsha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm,rstfacsun,rstfacsha) + + !calculate root water potential + qeroot = etrsun + etrsha + + CALL getrootqflx_qe2x(nl_soil,smp,z_soi,k_soil_root,k_ax_root,qeroot,xroot,x_root_top) + x(root) = x_root_top + + !calculate xylem water potential + fr = plc(x(root),psi50_root,ck) + x(xyl) = x(root) - grav1 - (etrsun+etrsha)/(fr*kmax_root/htop*sai) + + !calculate sun/sha leaf water potential + fx = plc(x(xyl),psi50_xyl,ck) + x(leafsha) = x(xyl) - (etrsha/(fx*kmax_xyl*laisha)) + x(leafsun) = x(xyl) - (etrsun/(fx*kmax_xyl*laisun)) + + + !calculate soil flux + DO j = 1,nl_soil + rootflux(j) = k_soil_root(j)*(smp(j)-xroot(j)) + ENDDO + + soilflux = sum(rootflux(:)) + + END SUBROUTINE getvegwp_twoleaf + + SUBROUTINE getqflx_gs2qflx_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf,& + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm,rstfacsun,rstfacsha) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL +! +!----------------------------------------------------------------------- + IMPLICIT NONE + + ! !ARGUMENTS: + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8), intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8), intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8), intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density (kg/m**3) + real(r8), intent(in) :: psrf ! atmospheric pressure (Pa) + real(r8), intent(in) :: laisun ! sunlit leaf area index (m2/m2) + real(r8), intent(in) :: laisha ! shaded leaf area index (m2/m2) + real(r8), intent(in) :: sai ! stem area index (m2/m2) + real(r8), intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8), intent(in) :: tl ! shaded leaf temperature + real(r8), intent(in) :: rss ! soil surface resistance [s/m] + real(r8), intent(in) :: raw ! moisture resistance [s/m] + real(r8), intent(in) :: rd ! aerodynamical resistance between ground and canopy air + real(r8),optional, intent(in) :: rstfacsun + real(r8),optional, intent(in) :: rstfacsha + + ! + ! !LOCAL VARIABLES: + real(r8) cf ! (umol/m**3) r = cf./g gmol(umol/m**2/s) -> r(s/m) + real(r8) tprcor ! tf*psur*100./1.013e5 + + real(r8) wtaq0 ! normalized latent heat conductance for air [-] + real(r8) wtgq0 ! normalized latent heat conductance for ground [-] + real(r8) wtlq0 ! normalized latent heat cond. for air and sunlit leaf [-] + real(r8) wtsqi ! latent heat resistance for air, grd and leaf [-] + + real(r8) delta + real(r8) caw ! latent heat conductance for air [m/s] + real(r8) cgw ! latent heat conductance for ground [m/s] + real(r8) cfw ! latent heat conductance for leaf [m/s] + + !---------------------------------------------------------------------- + tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor + + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + caw = 1. / raw + IF (qg < qaf)THEN + cgw = 1. / rd + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cfw = (1.-delta*(1.-fwet)) * (laisun+laisha+sai)*gb_mol/cf + (1.-fwet)*delta*& + (laisun/(1._r8/gb_mol+1._r8/gs_mol_sun)/cf+laisha/(1._r8/gb_mol+1._r8/gs_mol_sha)/cf) + wtsqi = 1. / ( caw + cgw + cfw ) + + wtaq0 = caw * wtsqi + wtgq0 = cgw * wtsqi + wtlq0 = cfw * wtsqi + + qflx_sun = rhoair * (1.-fwet) * delta & + * laisun / (1./gb_mol+1./gs_mol_sun)/cf & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) +! IF(qflx_sun < 1.e-7_r8)THEN +! qflx_sun = 0._r8 +! ENDIF + IF(present(rstfacsun))THEN + IF(rstfacsun .le. 1.e-2)qflx_sun = 0._r8 + ENDIF + qflx_sha = rhoair * (1.-fwet) * delta & + * laisha / (1./gb_mol+1./gs_mol_sha)/cf & + * ( (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg ) +! IF(qflx_sha < 1.e-7)THEN +! qflx_sha = 0._r8 +! ENDIF + IF(present(rstfacsha))THEN + IF(rstfacsha .le. 1.e-2)qflx_sha = 0._r8 + ENDIF + + END SUBROUTINE getqflx_gs2qflx_twoleaf + + SUBROUTINE getqflx_qflx2gs_twoleaf(gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf, & + rhoair,psrf,laisun,laisha,sai,fwet,tl,rss,raw,rd,qg,qm) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL +!----------------------------------------------------------------------- + IMPLICIT NONE + + ! !ARGUMENTS: + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (mol H2O/m**2/s), leaf scale + real(r8), intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8), intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + real(r8), intent(in) :: qg ! specific humidity at ground surface [kg/kg] + real(r8), intent(in) :: qm ! specific humidity at reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density (kg/m**3) + real(r8), intent(in) :: psrf ! atmospheric pressure (Pa) + real(r8), intent(in) :: laisun ! sunlit leaf area index (m2/m2) + real(r8), intent(in) :: laisha ! shaded leaf area index (m2/m2) + real(r8), intent(in) :: sai ! stem area index (m2/m2) + real(r8), intent(in) :: fwet ! fraction of foliage that is green and dry [-] + real(r8), intent(in) :: tl ! leaf temperature + real(r8), intent(in) :: rss ! soil surface resistance [s/m] + real(r8), intent(in) :: raw ! moisture resistance [s/m] + real(r8), intent(in) :: rd ! aerodynamical resistance between ground and canopy air + + ! + ! !LOCAL VARIABLES: + real(r8) wtlsun ! heat conductance for sunlit leaf boundary [m/s] + real(r8) wtlsha ! heat conductance for shaded leaf boundary [m/s] + real(r8) cf ! s m**2/umol -> s/m + real(r8) tprcor !tf*psur*100./1.013e5 + + real(r8) wtaq0 ! normalized latent heat conductance for air [-] + real(r8) wtgq0 ! normalized latent heat conductance for ground [-] + real(r8) wtlsunq0 ! normalized latent heat cond. for air and sunlit leaf [-] + real(r8) wtlshaq0 ! normalized latent heat cond. for air and shaded leaf [-] + + real(r8) delta + real(r8) caw ! latent heat conductance for air [m/s] + real(r8) cgw ! latent heat conductance for ground [m/s] + real(r8) cwet ! latent heat conductance for wet leaf [m/s] + real(r8) csunw_dry ! latent heat conductance for sunlit dry leaf [m/s] + real(r8) cshaw_dry ! latent heat conductance for shaded dry leaf [m/s] + real(r8) cqi_wet ! latent heat conductance for air, grd and wet leaf [-] + real(r8) cqi_leaf ! (wtaq0 + wtgq0)*qsatl - wtaq0*qm - wtgq0*qg [m/s] + real(r8) A1,B1,C1,A2,B2,C2 ! in binary quadratic equations + + !---------------------------------------------------------------------- + IF(qflx_sun .gt. 0 .or. qflx_sha .gt. 0)THEN + tprcor = 44.6*273.16*psrf/1.013e5 + cf = tprcor/tl * 1.e6_r8 ! gb->gbmol conversion factor + + delta = 0.0 + IF(qsatl-qaf .gt. 0.) delta = 1.0 + + caw = 1. / raw + IF (qg < qaf)THEN + cgw = 1. / rd + ELSE + IF (DEF_RSS_SCHEME .eq. 4) THEN + cgw = rss / rd + ELSE + cgw = 1. / (rd + rss) + ENDIF + ENDIF + cwet = (1.-delta*(1.-fwet)) * (laisun + laisha + sai) * gb_mol / cf + cqi_wet = caw + cgw + cwet + cqi_leaf = caw * (qsatl - qm) + cgw * (qsatl - qg) + + ! Solve equations: + ! A1 * csunw_dry + B1 * cfshaw_dry = C1 + ! A2 * csunw_dry + B2 * cfshaw_dry = C2 + + A1 = cqi_leaf - qflx_sun / rhoair + B1 = - qflx_sun / rhoair + C1 = qflx_sun * cqi_wet / rhoair + A2 = - qflx_sha / rhoair + B2 = cqi_leaf - qflx_sha / rhoair + C2 = qflx_sha * cqi_wet / rhoair + + csunw_dry = (B1*C2 - B2*C1)/(B1*A2 - B2*A1) + cshaw_dry = (A1*C2 - A2*C1)/(A1*B2 - B1*A2) + + IF (qflx_sun > 0._r8) THEN + gs_mol_sun = 1._r8 / ((1. - fwet) * delta * laisun / csunw_dry / cf - 1._r8 / gb_mol) + ENDIF + IF (qflx_sha > 0._r8) THEN + gs_mol_sha = 1._r8 / ((1. - fwet) * delta * laisha / cshaw_dry / cf - 1._r8 / gb_mol) + ENDIF + ENDIF + + END SUBROUTINE getqflx_qflx2gs_twoleaf + + SUBROUTINE getrootqflx_x2qe(nl_soil,smp,x_root_top,z_soisno,krad,kax,qeroot,dqeroot) + + USE MOD_Utils +!----------------------------------------------------------------------- +! !DESCRIPTION +! Return root water potential at top soil node. Return soil-root water flux. +! +!----------------------------------------------------------------------- + + integer , intent(in) :: nl_soil + real(r8), intent(in) :: smp (nl_soil) + real(r8), intent(in) :: x_root_top + real(r8), intent(in) :: z_soisno (nl_soil) + real(r8), intent(in) :: krad (nl_soil) + real(r8), intent(in) :: kax (nl_soil) + real(r8), intent(out) :: qeroot + real(r8), intent(out) :: dqeroot + +! Local variables + real(r8) den_AHR,den1,den2 ! used in calculating HR(Amenu model) + real(r8) amx_hr(nl_soil-1) ! "a" left off diagonal of tridiagonal matrix + real(r8) bmx_hr(nl_soil-1) ! "b" diagonal column for tridiagonal matrix + real(r8) cmx_hr(nl_soil-1) ! "c" right off diagonal tridiagonal matrix + real(r8) rmx_hr(nl_soil-1) ! "r" forcing term of tridiagonal matrix + real(r8) drmx_hr(nl_soil-1) ! "dr" forcing term of tridiagonal matrix for d/dxroot(1) + real(r8) x(nl_soil-1) ! root water potential from layer 2 to nl_soil + real(r8) dx(nl_soil-1) ! derivate of root water potential from layer 2 to nl_soil (dxroot(:)/dxroot(1)) + real(r8) xroot(nl_soil) ! root water potential from layer 2 to nl_soil + real(r8) zmm(1:nl_soil) ! layer depth [mm] + real(r8) qeroot_nl(1:nl_soil) ! root water potential from layer 2 to nl_soil + real(r8) dxroot2 ! dxroot(2)/dxroot(1) + integer j + + ! Because the depths in this routine are in mm, USE local + ! variable arrays instead of pointers + DO j = 1, nl_soil + zmm(j) = z_soisno(j)*1000. + ENDDO + + xroot(1) = x_root_top + zmm(1) + ! For the 2nd soil layer + j = 2 + den1 = zmm(j) - zmm(j-1) + den2 = zmm(j+1) - zmm(j) + amx_hr(j-1) = 0 + bmx_hr(j-1) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + cmx_hr(j-1) = -kax(j)/den2 + rmx_hr(j-1) = krad(j)*smp(j) + kax(j-1) - kax(j) + kax(j-1)/den1*xroot(1) + drmx_hr(j-1) = kax(j-1)/den1 + + ! For the middile soil layers + DO j = 3, nl_soil - 1 + den1 = zmm(j) - zmm(j-1) + den2 = zmm(j+1) - zmm(j) + amx_hr (j-1) = -kax(j-1)/den1 + bmx_hr (j-1) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + cmx_hr (j-1) = -kax(j)/den2 + rmx_hr (j-1) = krad(j)*smp(j) + kax(j-1) - kax(j) + drmx_hr(j-1) = 0._r8 + ENDDO + + ! For the bottom soil layer + j = nl_soil + den_AHR = zmm(j) - zmm(j-1) + amx_hr (j-1) = -kax(j-1)/den_AHR + bmx_hr (j-1) = kax(j-1)/den_AHR + krad(j) + cmx_hr (j-1) = 0 + rmx_hr (j-1) = krad(j)*smp(j) + kax(j-1) + drmx_hr(j-1) = 0._r8 + + ! Solve for root pressure potential using tridiagonal matric solver x = A^-1 * r + CALL tridia (nl_soil-1 ,amx_hr ,bmx_hr ,cmx_hr ,rmx_hr ,x) + + DO j = 2,nl_soil + xroot(j) = x(j-1) + ENDDO + + ! Solve the dx(:)/dxroot(1) = A^-1 * dr + CALL tridia (nl_soil-1 ,amx_hr ,bmx_hr ,cmx_hr ,drmx_hr, dx) + + dxroot2 = dx(1) + + ! calculate the water flux + j = 1 + den2 = zmm(j+1) - zmm(j) + qeroot = krad(j) * (smp(1) - xroot(1)) + (xroot(2) - xroot(1)) * kax(j)/den2 - kax(j) + + ! calculate the dqeroot/dx_root_top; + dqeroot = - krad(j) + (dxroot2 - 1) * kax(j)/den2 + DO j = 1,nl_soil + qeroot_nl(j) = krad(j)*(smp(j) - xroot(j)) + ENDDO + + END SUBROUTINE getrootqflx_x2qe + + SUBROUTINE getrootqflx_qe2x(nl_soil,smp,z_soisno,krad,kax,qeroot,xroot,x_root_top) + + USE MOD_Utils +!----------------------------------------------------------------------- +! !DESCRIPTION +! Return root water potential at top soil node. Return soil-root water flux. +!----------------------------------------------------------------------- + + integer, intent(in) :: nl_soil + real(r8), intent(in) :: smp (nl_soil) + real(r8), intent(in) :: z_soisno (nl_soil) + real(r8), intent(in) :: krad (nl_soil) + real(r8), intent(in) :: kax (nl_soil) + real(r8), intent(in) :: qeroot + real(r8), intent(out) :: xroot (nl_soil) + real(r8), intent(out) :: x_root_top + +! Local variables + real(r8) den_AHR,den1,den2 ! used in calculating HR(Amenu model) + real(r8) amx_hr(nl_soil) ! "a" left off diagonal of tridiagonal matrix + real(r8) bmx_hr(nl_soil) ! "b" diagonal column for tridiagonal matrix + real(r8) cmx_hr(nl_soil) ! "c" right off diagonal tridiagonal matrix + real(r8) rmx_hr(nl_soil) ! "r" forcing term of tridiagonal matrix + real(r8) x(nl_soil) ! root water potential from layer 2 to nl_soil + real(r8) zmm(1:nl_soil) ! layer depth [mm] + real(r8) qeroot_nl(1:nl_soil) ! root water potential from layer 2 to nl_soil + integer j + + ! Because the depths in this routine are in mm, USE local + ! variable arrays instead of pointers + DO j = 1, nl_soil + zmm(j) = z_soisno(j)*1000. + ENDDO + + j = 1 + den2 = zmm(j+1) - zmm(j) + amx_hr(j) = 0 + bmx_hr(j) = kax(j)/den2 + krad(j) + cmx_hr(j) = -kax(j)/den2 + rmx_hr(j) = krad(j)*smp(j) - qeroot - kax(j) + + ! For the middile soil layers + DO j = 2, nl_soil - 1 + den1 = zmm(j) - zmm(j-1) + den2 = zmm(j+1) - zmm(j) + amx_hr(j) = -kax(j-1)/den1 + bmx_hr(j) = kax(j-1)/den1 + kax(j)/den2 + krad(j) + cmx_hr(j) = -kax(j)/den2 + rmx_hr(j) = krad(j)*smp(j) + kax(j-1) - kax(j) + ENDDO + + ! For the bottom soil layer + j = nl_soil + den_AHR = zmm(j) - zmm(j-1) + amx_hr(j) = -kax(j-1)/den_AHR + bmx_hr(j) = kax(j-1)/den_AHR + krad(j) + cmx_hr(j) = 0 + rmx_hr(j) = krad(j)*smp(j) + kax(j-1) + + ! Solve for root pressure potential using tridiagonal matric solver + CALL tridia (nl_soil ,amx_hr ,bmx_hr ,cmx_hr ,rmx_hr ,x) + + xroot(1:nl_soil) = x(1:nl_soil) + x_root_top = xroot(1) - zmm(1) + + END SUBROUTINE getrootqflx_qe2x + + FUNCTION plc(x,psi50,ck) +!----------------------------------------------------------------------- +! !DESCRIPTION +! Return value of vulnerability curve at x +! +!----------------------------------------------------------------------- + +! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input +! integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) +! integer , intent(in) :: plc_method ! + real(r8) , intent(in) :: psi50 ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8) , intent(in) :: ck + real(r8) :: plc ! attenuated conductance [0:1] 0=no flow + ! + ! !PARAMETERS +! integer , parameter :: vegetation_weibull=0 ! case number +! integer , parameter :: leafsun = 1 ! index for sunlit leaf +! integer , parameter :: leafsha = 2 ! index for shaded leaf +! integer , parameter :: xyl = 3 ! index for xylem +! integer , parameter :: root = 4 ! index for root + + ! !LOCAL VARIABLES + !real(r8) psi50,tmp + real(r8) tmp + integer i + + !------------------------------------------------------------------------------ +! select CASE(level) +! CASE (leafsun) +! psi50 = psi50_sun +! CASE (leafsha) +! psi50 = psi50_sha +! CASE (xyl) +! psi50 = psi50_xyl +! CASE (root) +! psi50 = psi50_root +! CASE default +! write(*,*),'must choose level from 1 to 4 (sunlit leaf to root)' +! END select + +! select CASE (plc_method) + !possible to add other methods later +! CASE (vegetation_weibull) + tmp = amax1(-(x/psi50)**ck,-500._r8) +! IF(tmp .lt. -500._r8)THEN +! plc = 0._r8 +! ELSE + plc=2._r8**tmp +! ENDIF + IF ( plc < 0.00001_r8) plc = 1.e-5_r8 +! CASE default +! write(*,*),'must choose plc method' +! END select + + END FUNCTION plc + !-------------------------------------------------------------------------------- + + FUNCTION d1plc(x,psi50,ck) +!----------------------------------------------------------------------- +! !DESCRIPTION +! Return 1st derivative of vulnerability curve at x +!----------------------------------------------------------------------- + +! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input +! integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) +! integer , intent(in) :: plc_method ! 0 for vegetation, 1 for soil + real(r8) , intent(in) :: psi50 ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sun ! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_sha ! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_xyl ! water potential at 50% loss of xylem tissue conductance (mmH2O) +! real(r8) , intent(in) :: psi50_root ! water potential at 50% loss of root tissue conductance (mmH2O) + real(r8) , intent(in) :: ck + real(r8) :: d1plc ! first deriv of plc curve at x + ! + ! !PARAMETERS +! integer , parameter :: vegetation_weibull=0 ! CASE number +! integer , parameter :: leafsun = 1 ! index for sunlit leaf +! integer , parameter :: leafsha = 2 ! index for shaded leaf +! integer , parameter :: xyl = 3 ! index for xylem +! integer , parameter :: root = 4 ! index for root + + ! !LOCAL VARIABLES +! real(r8) psi50,tmp + real(r8) tmp + !------------------------------------------------------------------------------ +! select CASE(level) +! CASE (leafsun) +! psi50 = psi50_sun +! CASE (leafsha) +! psi50 = psi50_sha +! CASE (xyl) +! psi50 = psi50_xyl +! CASE (root) +! psi50 = psi50_root +! CASE default +! write(*,*),'must choose level from 1 to 4 (sunlit leaf to root)' +! END select + +! select CASE (plc_method) + !possible to add other methods later +! CASE (vegetation_weibull) + tmp = amax1(-(x/psi50)**ck,-500._r8) +! IF(tmp .lt. -500._r8)THEN +! d1plc = 0._r8 +! ELSE + d1plc= ck * log(2._r8) * (2._r8**tmp) * tmp / x +! ENDIF +! CASE default +! write(*,*),'must choose plc method' +! END select + + END FUNCTION d1plc + + +END MODULE MOD_PlantHydraulic +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Qsadv.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Qsadv.F90 new file mode 100644 index 0000000000..efc004e67c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Qsadv.F90 @@ -0,0 +1,108 @@ +MODULE MOD_Qsadv + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: qsadv + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE qsadv(T,p,es,esdT,qs,qsdT) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, September 15, 1999 +! +! Description: computes saturation mixing ratio and change in saturation +! mixing ratio with respect to temperature +! +! Reference: polynomial approximations from: +! Piotr J. Flatau,et al,1992: polynomial fits to saturation +! vapor pressure. Journal of Applied meteorology,31,1507-1513. +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: T ! temperature (K) + real(r8), intent(in) :: p ! surface atmospheric pressure (pa) + + real(r8), intent(out) :: es ! vapor pressure (pa) + real(r8), intent(out) :: esdT ! d(es)/d(T) + real(r8), intent(out) :: qs ! humidity (kg/kg) + real(r8), intent(out) :: qsdT ! d(qs)/d(T) + +!-------------------------- Local Variables ---------------------------- + real(r8) td,vp,vp1,vp2 + real(r8) a0,a1,a2,a3,a4,a5,a6,a7,a8 + real(r8) b0,b1,b2,b3,b4,b5,b6,b7,b8 + + real(r8) c0,c1,c2,c3,c4,c5,c6,c7,c8 + real(r8) d0,d1,d2,d3,d4,d5,d6,d7,d8 + +! for water vapor (temperature range 0C-100C) + data a0/6.11213476 /,a1/ 0.444007856 /,a2/0.143064234e-01/ & + ,a3/0.264461437e-03/,a4/ 0.305903558e-05/,a5/0.196237241e-07/ & + ,a6/0.892344772e-10/,a7/-0.373208410e-12/,a8/0.209339997e-15/ + +! for derivative:water vapor + data b0/0.444017302 /,b1/ 0.286064092e-01/,b2/ 0.794683137e-03/ & + ,b3/ 0.121211669e-04/,b4/ 0.103354611e-06/,b5/ 0.404125005e-09/ & + ,b6/-0.788037859e-12/,b7/-0.114596802e-13/,b8/ 0.381294516e-16/ + +! for ice (temperature range -75C-0C) + data c0/6.11123516 /,c1/0.503109514 /,c2/0.188369801e-01/ & + ,c3/0.420547422e-03/,c4/0.614396778e-05/,c5/0.602780717e-07/ & + ,c6/0.387940929e-09/,c7/0.149436277e-11/,c8/0.262655803e-14/ + +! for derivative:ice + data d0/0.503277922 /,d1/0.377289173e-01/,d2/0.126801703e-02/ & + ,d3/0.249468427e-04/,d4/0.313703411e-06/,d5/0.257180651e-08/ & + ,d6/0.133268878e-10/,d7/0.394116744e-13/,d8/0.498070196e-16/ + +!----------------------------------------------------------------------- + + td = T-273.16 + +! IF (td < -75.0 .or. td > 75.0) THEN + !* print *, "qsadv: abnormal temperature", T +! ENDIF + + IF (td < -75.0) td = -75.0 + IF (td > 75.0) td = 75.0 + + IF (td >= 0.0)THEN + es = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 & + + td*(a5 + td*(a6 + td*(a7 + td*a8))))))) + esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 & + + td*(b5 + td*(b6 + td*(b7 + td*b8))))))) + ELSE + es = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 & + + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) + esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 & + + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) + ENDIF + + es = es * 100. ! pa + esdT = esdT * 100. ! pa/K + + vp = 1.0 / (p - 0.378*es) + vp1 = 0.622 * vp + vp2 = vp1 * vp + + qs = es * vp1 ! kg/kg + qsdT = esdT * vp2 * p ! 1 / K + + END SUBROUTINE qsadv + +END MODULE MOD_Qsadv +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_RainSnowTemp.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_RainSnowTemp.F90 new file mode 100644 index 0000000000..b47a49573e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_RainSnowTemp.F90 @@ -0,0 +1,308 @@ +#include + +MODULE MOD_RainSnowTemp + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: rain_snow_temp + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE rain_snow_temp (patchtype,& + forc_t,forc_q,forc_psrf,forc_prc,forc_prl,forc_us,forc_vs,tcrit,& + prc_rain,prc_snow,prl_rain,prl_snow,t_precip,bifall) + +!======================================================================= +! define the rate of rainfall and snowfall and precipitation water temp +! Original author: Yongjiu Dai, 09/1999; 08/31/2002, 04/2014, 01/2023 +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + USE MOD_WetBulb + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: patchtype ! land patch type (3=glaciers) + + real(r8), intent(in) :: forc_t ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: forc_q ! specific humidity at agcm reference height [kg/kg] + real(r8), intent(in) :: forc_psrf ! atmosphere pressure at the surface [pa] + real(r8), intent(in) :: forc_prc ! convective precipitation [mm/s] + real(r8), intent(in) :: forc_prl ! large scale precipitation [mm/s] + real(r8), intent(in) :: forc_us ! wind speed in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind speed in northward direction [m/s] + + real(r8), intent(in) :: tcrit ! critical temp. to determine rain or snow + + real(r8), intent(out) :: prc_rain ! convective rainfall [kg/(m2 s)] + real(r8), intent(out) :: prc_snow ! convective snowfall [kg/(m2 s)] + real(r8), intent(out) :: prl_rain ! large scale rainfall [kg/(m2 s)] + real(r8), intent(out) :: prl_snow ! large scale snowfall [kg/(m2 s)] + real(r8), intent(out) :: t_precip ! snowfall/rainfall temperature [kelvin] + real(r8), intent(out) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: flfall ! fraction of liquid water within falling precip. + + real(r8) :: all_snow_t ! temperature at which all precip falls entirely as snow (K) + real(r8) :: frac_rain_slope ! slope of the frac_rain vs. temperature relationship + real(r8) :: all_snow_t_c ! Temperature at which precip falls entirely as rain (deg C) + real(r8) :: all_rain_t_c ! Temperature at which precip falls entirely as snow (deg C) + + logical :: glaciers ! true: glacier column + real(r8) :: t_for_bifall_degC ! temperature to USE in bifall equation (deg C) + real(r8) :: forc_wind ! wind speed [m/s] + real(r8) :: t_hydro ! temperature of falling hydrometeor [deg C] +!----------------------------------------------------------------------- + +! wet-bulb temperature + CALL wetbulb(forc_t,forc_psrf,forc_q,t_precip) + + IF (trim(DEF_precip_phase_discrimination_scheme) == 'I') THEN + ! Wang, Y.H., Broxton, P., Fang, Y., Behrangi, A., Barlage, M., Zeng, X., & Niu, G.Y. (2019). + ! A Wet-Bulb Temperature Based Rain-Snow Partitioning Scheme Improves Snowpack Prediction + ! Over the Drier Western United States. Geophysical Research Letters, 46, 13,825-13,835. + ! + ! Behrangi et al. (2018) On distinguishing snowfall from rainfall + ! using near-surface atmospheric information: Comparative analysis, + ! uncertainties and hydrologic importance. Q J R Meteorol Soc. 144 (Suppl. 1):89-102 + + IF(t_precip - tfrz > 3.0)THEN + flfall = 1.0 ! fraction of liquid water within falling precip + ELSEIF (t_precip - tfrz >= -2.0)THEN + !Figure 5c of Behrangi et al. (2018) + flfall = max(0.0, 1.0 - 1.0/(1.0+5.00e-5*exp(2.0*(t_precip-tfrz+4.)))) + !Equation 1 of Wang et al. (2019) + !* flfall = max(0.0, 1.0 - 1.0/(1.0+6.99e-5*exp(2.0*(t_precip-tfrz+3.97)))) + ELSE + flfall = 0.0 + ENDIF + + ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'II') THEN + glaciers = .false. + IF (patchtype == 3) glaciers = .true. + + IF(glaciers) THEN + all_snow_t_c = -2.0 + all_rain_t_c = 0.0 + ELSE + all_snow_t_c = 0.0 + all_rain_t_c = 2.0 + ENDIF + + all_snow_t = all_snow_t_c + tfrz + frac_rain_slope = 1._r8 / (all_rain_t_c - all_snow_t_c) + + ! Re-partition precipitation into rain/snow for a single column. + ! Rain and snow variables should be set initially, and are updated here + + flfall = min(1.0_r8, max(0.0_r8,(forc_t - all_snow_t)*frac_rain_slope)) + ELSEIF (trim(DEF_precip_phase_discrimination_scheme) == 'III') THEN + ! Phillip Harder and John Pomeroy (2013) + ! Estimating precipitation phase using a psychrometric energy + ! balance method . Hydrol Process, 27, 1901-1914 + ! Hydromet_Temp [K] + CALL hydromet_temp(forc_psrf,(forc_t-273.15),forc_q,t_hydro) + + IF(t_hydro > 3.0)THEN + flfall = 1.0 ! fraction of liquid water within falling precip + ELSEIF ((t_hydro >= -3.0).and.(t_hydro <= 3.0))THEN + flfall = max(0.0, 1.0/(1.0+2.50286*0.125006**t_hydro)) + ELSE + flfall = 0.0 + ENDIF + + ELSE + ! the upper limit of air temperature is set for snowfall, this cut-off + ! was selected based on Fig. 1, Plate 3-1, of Snow Hydrology (1956). + ! the percentage of liquid water by mass, which is arbitrarily set to + ! vary linearly with air temp, from 0% at 273.16 to 40% max at 275.16. + + IF(forc_t>tfrz+2.0)THEN + flfall = 1.0 ! fraction of liquid water within falling precip. + ELSE + flfall = max(0.0, -54.632+0.2*forc_t) + ENDIF + + ENDIF + + ! new scheme for "bifall" from CLM5.0 + CALL NewSnowBulkDensity(forc_t,forc_us,forc_vs,bifall) + + prc_rain = forc_prc*flfall ! convective rainfall (mm/s) + prl_rain = forc_prl*flfall ! large scale rainfall (mm/s) + prc_snow = forc_prc*(1.-flfall) ! convective snowfall (mm/s) + prl_snow = forc_prl*(1.-flfall) ! large scale snowfall (mm/s) + + ! ------------------------------------------------------------- + ! temperature of rainfall or snowfall + ! ------------------------------------------------------------- + + IF (forc_t > 275.65) THEN + IF (t_precip < tfrz) t_precip = tfrz + ELSE + t_precip = min(tfrz,t_precip) + IF(flfall > 1.e-6)THEN + t_precip = tfrz - sqrt((1.0/flfall)-1.0)/100.0 + ENDIF + ENDIF + + END SUBROUTINE rain_snow_temp + + + SUBROUTINE NewSnowBulkDensity(forc_t,forc_us,forc_vs,bifall) +!======================================================================= +! Scheme for bulk density of newly fallen dry snow +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + + real(r8), intent(in) :: forc_t ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: forc_us ! wind speed in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind speed in northward direction [m/s] + + real(r8), intent(out) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + + real(r8) :: t_for_bifall_degC ! temperature to USE in bifall equation (deg C) + real(r8) :: forc_wind ! wind speed [m/s] + + !----------------------------------------------------------------------- + + IF (forc_t > tfrz + 2.0) THEN + bifall = 50.0 + 1.7*(17.0)**1.5 + ELSEIF (forc_t > tfrz - 15.0) THEN + bifall = 50.0 + 1.7*(forc_t - tfrz + 15.0)**1.5 + ELSE + ! Andrew Slater: A temp of about -15C gives the nicest + ! "blower" powder, but as you get colder the flake size decreases so + ! density goes up. e.g. the smaller snow crystals from the Arctic and Antarctic winters + IF (forc_t > tfrz - 57.55) THEN + t_for_bifall_degC = (forc_t-tfrz) + ELSE + ! Below -57.55 deg C, the following function starts to decrease with + ! decreasing temperatures. Limit the function to avoid this turning over. + t_for_bifall_degC = -57.55 + ENDIF + bifall = -(50.0/15.0 + 0.0333*15.0)*t_for_bifall_degC - 0.0333*t_for_bifall_degC**2 + ENDIF + + forc_wind = sqrt(forc_us**2 + forc_vs**2) + IF (forc_wind > 0.1) THEN + ! Density offset for wind-driven compaction, initial ideas based on Liston et. al (2007) J. + ! Glaciology, 53(181), 241-255. Modified for a continuous wind impact and slightly more + ! sensitive to wind - Andrew Slater, 2016 + bifall = bifall + (266.861 * ((1.0 + TANH(forc_wind/5.0))/2.0)**8.8) + ENDIF + + END SUBROUTINE NewSnowBulkDensity + + !!============================================== + + SUBROUTINE hydromet_temp(ppa, pta, pqa, pti) +!----------------------------------------------------------------------------- +! !DESCRIPTION +! Computes the temperature of a falling hydrometeor based on Harder, P., Pomeroy, J. (2013). +! +! Original Author: +! ---------------- +! V. Vionnet (11/2020) +! +! !REFERENCES: +! Harder, P., Pomeroy, J. (2013). +! Estimating precipitation phase using a psychrometric energy balance method +! Hydrological Processes 27(13), 1901-1914. https://dx.doi.org/10.1002/hyp.9799 + +! !REVISIONS: +! 2023.07.30 Aobo Tan & Zhongwang Wei @ SYSU +! +!----------------------------------------------------------------------------- + + real(r8), intent(in) :: ppa ! Air pressure (Pa) + real(r8), intent(in) :: pta ! Air temperature (deg C) + real(r8), intent(in) :: pqa ! Air specific humidity (kg/kg) + real(r8), intent(out) :: pti ! Hydrometeor temperature in deg C + + real(r8) :: zd ! Diffusivity of water vapour in air [m^2 s^-1] + real(r8) :: zlambda ! Thermal conductivity of air [J m^-1 s^-1 K^-1] + real(r8) :: zl ! Latent heat of sublimation or vaporization [J kg^-1] + real(r8) :: zrhoda ! Density of dry air [kg m^-3] + real(r8) :: zrh ! Relative humidity [-] + real(r8) :: rho_vast_diff, esat, rho_vast + real(r8) :: zt, ztint, zf, zfdiff, evsat + integer :: JITER + integer :: JJ, I, NN + + ! 1. Compute diffusivity of water vapour in air [m^2 s^-1] (Thorpe and Mason, 1966) + zd = 2.063e-5 * ((pta + 273.15) / 273.15) ** 1.75 + + ! 2. Compute thermal conductivity of air [J m^-1 s^-1 K^-1] + zlambda = 0.000063 * (pta + 273.15) + 0.00673 + + ! 3. Compute latent heat of sublimation or vaporization (depending on air temperature) + IF (pta < 0.) THEN + zl = 1000.0 * (2834.1 - 0.29 * pta - 0.004 * pta ** 2.) + + ELSE + zl = 1000.0 * (2501.0 - (2.361 * pta)) + ENDIF + + ! 4. Compute density of dry air [kg m^-3] + zrhoda = ppa / (287.04 * (pta + 273.15)) + + ! 5. Compute saturated water vapour pressure [Pa] + IF (pta > 0) THEN + evsat = 611.0 * EXP(17.27 * pta / (pta + 237.3)) + ELSE + evsat = 611.0 * EXP(21.87 * pta / (pta + 265.5)) + ENDIF + + ! 6. Solve iteratively to get Ti in Harder and Pomeroy (2013) using a Newton-Raphson approach + ! Set the first guess to pta + zt = pta + + ! Loop until convergence + DO JITER = 1, 10 + ztint = zt + + IF (zt > 0) THEN + esat = 611.0 * EXP(17.27 * zt / (zt + 237.3)) + ELSE + esat = 611.0 * EXP(21.87 * zt / (zt + 265.5)) + ENDIF + + rho_vast = esat / (461.5 * (zt + 273.15)) ! Saturated water vapour density + + zf = zt - pta - zd * zl / zlambda * (pqa * zrhoda - rho_vast) + + IF (zt > 0) THEN + rho_vast_diff = 611.0 / (461.5 * (zt + 273.15)) * EXP(17.27 * zt / (zt + 237.3)) * & + (-1 / (zt + 273.15) + 17.27 * 237.3 / ((zt + 237.3) ** 2.)) + ELSE + rho_vast_diff = 611.0 / (461.5 * (zt + 273.15)) * EXP(21.87 * zt / (zt + 265.5)) * & + (-1 / (zt + 273.15) + 21.87 * 265.5 / ((zt + 265.5) ** 2.)) + ENDIF + + zfdiff = 1 + zd * zl / zlambda * rho_vast_diff + zt = ztint - zf / zfdiff + IF (ABS(zt - ztint) .lt. 0.01) EXIT + ENDDO + + pti = zt + + END SUBROUTINE hydromet_temp + +END MODULE MOD_RainSnowTemp diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 new file mode 100644 index 0000000000..c98e654406 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Runoff.F90 @@ -0,0 +1,440 @@ +#include + +MODULE MOD_Runoff + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: SurfaceRunoff_TOPMOD + PUBLIC :: SubsurfaceRunoff_TOPMOD + PUBLIC :: Runoff_XinAnJiang + PUBLIC :: Runoff_SimpleVIC + PUBLIC :: SubsurfaceRunoff_SimpleVIC + + +!----------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,& + fsatmax,fsatdcf,& + z_soisno,dz_soisno,zi_soisno,& + eff_porosity,icefrac,zwt,gwat,& + rsur,rsur_se,rsur_ie,& + topoweti,alp_twi,chi_twi,mu_twi,frcsat,eta_out) + +!======================================================================= +! the original code was provide by Robert E. Dickinson based on +! following clues: a water table level determination level added +! including highland and lowland levels and fractional area of wetland +! (water table above the surface. Runoff is parametrized from the +! lowlands in terms of precip incident on wet areas and a base flow, +! where these are estimated using ideas from TOPMODEL. +! +! Author : Yongjiu Dai, 07/29/2002, Guoyue Niu, 06/2012 +!======================================================================= + + USE MOD_Namelist, only: DEF_TOPMOD_method + USE MOD_IncompleteGamma, only: GRATIO + USE MOD_MPAS_MPI + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: nl_soil ! number of soil layers + real(r8), intent(in) :: & + ! wtfact, &! (updated to gridded 'fsatmax' data) + ! fraction of model area with high water table + wimp, &! water impermeable if porosity less than wimp + porsl(1:nl_soil), &! saturated volumetric soil water content(porosity) + psi0(1:nl_soil), &! saturated soil suction (mm) (NEGATIVE) + hksati(1:nl_soil), &! hydraulic conductivity at saturation (mm h2o/s) + fsatmax, &! maximum fraction of saturation area [-] + fsatdcf, &! decay factor in calc of fraction of saturation area [1/m] + z_soisno(1:nl_soil), &! layer depth (m) + dz_soisno(1:nl_soil), &! layer thickness (m) + zi_soisno(0:nl_soil), &! interface level below a "z" level (m) + eff_porosity(1:nl_soil), &! effective porosity = porosity - vol_ice + icefrac(1:nl_soil), &! ice fraction (-) + gwat, &! net water input from top + zwt ! the depth from ground (soil) surface to water table [m] + + real(r8), intent(out) :: rsur ! surface runoff (mm h2o/s) + real(r8), intent(out), optional :: rsur_se! saturation excess surface runoff (mm h2o/s) + real(r8), intent(out), optional :: rsur_ie! infiltration excess surface runoff (mm h2o/s) + + real(r8), intent(in), optional :: topoweti + real(r8), intent(in), optional :: alp_twi, chi_twi, mu_twi + real(r8), intent(out), optional :: frcsat + real(r8), intent(out), optional :: eta_out + +!-------------------------- Local Variables ---------------------------- + + real(r8), parameter :: vdcf = 2.0 + + real(r8) qinmax ! maximum infiltration capability + real(r8) fsat ! fractional area with water table at surface + + real(r8) eta, pgr0, pgr1, qgr, gfun + integer niter + + ! updated to gridded 'fsatdcf' (by Shupeng Zhang) + ! real(r8), parameter :: fff = 0.5 ! runoff decay factor (m-1) + +!----------------------------------------------------------------------- + +! fraction of saturated area (updated to gridded 'fsatmax' and 'fsatdcf') + !fsat = wtfact*min(1.0,exp(-0.5*fff*zwt)) + IF ((DEF_TOPMOD_method == 0) .or. (DEF_TOPMOD_method == 1)) THEN + + fsat = fsatmax * exp(- fsatdcf * vdcf * zwt) + + ELSE + + IF (zwt <= 0.) THEN + + fsat = 1. + eta = mu_twi + + ELSE + + eta = topoweti + niter = 0 + DO WHILE (niter < 20) + niter = niter + 1 + CALL GRATIO (alp_twi+1, (eta-mu_twi)/chi_twi, pgr1, qgr, 0) + CALL GRATIO (alp_twi, (eta-mu_twi)/chi_twi, pgr0, qgr, 0) + gfun = ((eta-mu_twi)*pgr0 - chi_twi*alp_twi*pgr1)/vdcf - zwt + + IF (abs(gfun) > 1.e-6) THEN + eta = mu_twi + (chi_twi * alp_twi * pgr1 + vdcf*zwt) / pgr0 + ELSE + EXIT + ENDIF + ENDDO + + IF (abs(gfun) > 1.e-6) THEN + write(*,*) 'Fail to converge in TOPModel: (alp,chi,mu,twi,zwt,gfun) = ', & + alp_twi, chi_twi, mu_twi, topoweti, zwt, gfun + ENDIF + + CALL GRATIO (alp_twi, (eta-mu_twi)/chi_twi, pgr0, qgr, 0) + + fsat = qgr + + ENDIF + + IF (present(eta_out)) THEN + eta_out = eta + ENDIF + + ENDIF + + IF (present(frcsat)) THEN + frcsat = fsat + ENDIF + +! Maximum infiltration capacity + qinmax = minval(10.**(-6.0*icefrac(1:min(3,nl_soil)))*hksati(1:min(3,nl_soil))) + IF(eff_porosity(1) WaterDepthMax ) then + !RunoffSurface = (WaterDepthInit + w_int) - WaterDepthMax + RunoffSurface = watin - wsat_int + w_int + ELSE + InfilVarTmp = 1.0 - ((WaterDepthInit +watin ) / WaterDepthMax) + RunoffSurface =watin - wsat_int + w_int + wsat_int * (InfilVarTmp**(1.0+BVIC)) + ENDIF + + IF ( RunoffSurface < 0.0 ) RunoffSurface = 0.0 + IF ( RunoffSurface > watin) RunoffSurface = watin + + infil = watin - RunoffSurface + rsur= RunoffSurface * 1000. / deltim + rsubst = 0. + ENDIF + + END SUBROUTINE Runoff_SimpleVIC + + ! ------------------------------------------------------------------------- + SUBROUTINE SubsurfaceRunoff_SimpleVIC ( & + nl_soil, z_soisno, dz_soisno, wice_soisno, porsl, psi0, hksati, theta_r, & + nprms, prms, zwt, rsubst) + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o + USE MOD_Vars_TimeInvariants, only: smpmax + USE MOD_Hydro_SoilFunction, only: soil_vliq_from_psi + IMPLICIT NONE + + integer, intent(in) :: nl_soil ! number of soil layers + + real(r8), intent(in) :: & + z_soisno (1:nl_soil), & ! layer depth (m) + dz_soisno (1:nl_soil), & ! layer thickness (m) + wice_soisno(1:nl_soil), & ! ice lens (kg/m2) + porsl (1:nl_soil), & ! saturated volumetric soil water content(porosity) + psi0 (1:nl_soil), & ! saturated soil suction (mm) (NEGATIVE) + hksati (1:nl_soil), & ! hydraulic conductivity at saturation (mm h2o/s) + theta_r (1:nl_soil) ! residual moisture content [-] + + integer, intent(in) :: nprms + real(r8), intent(in) :: prms(nprms, 1:nl_soil) + + real(r8), intent(in) :: zwt ! [m] + + real(r8), intent(out) :: rsubst ! subsurface runoff (mm h2o/s) + + ! Local Variables + real(r8), parameter :: Ds = 0.061 ! a fraction of Dsmax + real(r8), parameter :: Ws = 0.646 ! a fraction of the potential water storage as Wmb-Wwb + real(r8) :: Dsmax ! maximum subsurface flow + real(r8) :: Wwb ! (layer 8+9, from 0.83m to 2.30m) water storage at wilting point + real(r8) :: Wmb ! (layer 8+9, from 0.83m to 2.30m) maximum water storage + real(r8) :: Wlb ! (layer 8+9, from 0.83m to 2.30m) liquid water storage + real(r8) :: Wab ! (layer 8+9, from 0.83m to 2.30m) relative water storage + + real(r8) :: vol_ice, icefrac, eff_porosity, imped, hk + real(r8), parameter :: e_ice=6.0 ! soil ice impedance factor + integer :: ilev + + Wwb = 0. + Wmb = 0. + Wlb = 0. + Dsmax = 0. + DO ilev = 8, 9 + vol_ice = max(min(porsl(ilev), wice_soisno(ilev)/(dz_soisno(ilev)*denice)), 0.) + eff_porosity = porsl(ilev) - vol_ice + + Wwb = Wwb + dz_soisno(ilev) * denh2o * & + soil_vliq_from_psi (smpmax, eff_porosity, theta_r(ilev), psi0(ilev), nprms, prms(:,ilev)) + + Wmb = Wmb + eff_porosity*dz_soisno(ilev)*denh2o + + Wlb = Wlb + dz_soisno(ilev) * denh2o * & + soil_vliq_from_psi ( psi0(ilev)-max((zwt-z_soisno(ilev))*1.e3, 0.), & + eff_porosity, theta_r(ilev), psi0(ilev), nprms, prms(:,ilev)) + + icefrac = vol_ice/porsl(ilev) + imped = 10.**(-e_ice*icefrac) + hk = imped * hksati(ilev) + Dsmax = max(Dsmax, hk) + ENDDO + + Wab = (Wlb-Wwb) / (Wmb-Wwb) + Wab = min(max(Wab, 0.), 1.) + + IF (Wab <= Ws) THEN + rsubst = Dsmax * Ds * (Wab/Ws) + ELSE + rsubst = Dsmax * Ds * (Wab/Ws) + Dsmax * (1-Ds/Ws) * ((Wab-Ws)/(1-Ws))**2 + ENDIF + + END SUBROUTINE SubsurfaceRunoff_SimpleVIC + +END MODULE MOD_Runoff +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SimpleOcean.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SimpleOcean.F90 new file mode 100644 index 0000000000..85c9ac548b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SimpleOcean.F90 @@ -0,0 +1,680 @@ +#include + +MODULE MOD_SimpleOcean + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: socean + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: seafluxes + PRIVATE :: srftsb + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE socean (dosst,deltim,oro,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,sabg,frl,tssea,tssub,scv,& + taux,tauy,fsena,fevpa,lfevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,emis,olrg) +!----------------------------------------------------------------------- +! Simple Ocean Model +! 1. calculate sea surface fluxes, based on CLM +! 2. calculate sea surface albedos and seaice/snow temperatures +! as in NCAR CCM3.6.16 +! Original authors : Yongjiu Dai and Xin-Zhong Liang (08/30/2001) +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, hvap, hsub, stefnc, vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, parameter :: psrfty=7 ! Number of surface types + integer, parameter :: plsice=4 ! number of seaice levels + + logical, intent(in) :: dosst ! true to update sst/ice/snow before calculation + real(r8), intent(in) :: deltim ! seconds in a time-step (s) + real(r8), intent(in) :: hu ! agcm reference height of wind [m] + real(r8), intent(in) :: ht ! agcm reference height of temperature [m] + real(r8), intent(in) :: hq ! agcm reference height of humidity [m] + real(r8), intent(in) :: us ! wind component in eastward direction [m/s] + real(r8), intent(in) :: vs ! wind component in northward direction [m/s] + real(r8), intent(in) :: tm ! temperature at agcm reference height [kelvin] + real(r8), intent(in) :: qm ! specific humidity at agcm reference height [kg/kg] + real(r8), intent(in) :: rhoair ! density air [kg/m3] + real(r8), intent(in) :: psrf ! atmosphere pressure at the surface [pa] [not used] + real(r8), intent(in) :: sabg ! surface solar absorbed flux [W/m2] + real(r8), intent(in) :: frl ! downward longwave radiation [W/m2] + + real(r8), intent(inout) :: oro ! ocean(0)/seaice(2)/ flag + real(r8), intent(inout) :: scv ! snow water equivalent depth (mm) + real(r8), intent(inout) :: tssub(plsice) ! surface/sub-surface temperatures [K] + real(r8), intent(out) :: tssea ! sea surface temperature [K] + + real(r8), intent(out) :: taux ! wind stress: E-W [kg/m/s**2] + real(r8), intent(out) :: tauy ! wind stress: N-S [kg/m/s**2] + real(r8), intent(out) :: fsena ! sensible heat from reference height to atmosphere [W/m2] + real(r8), intent(out) :: fevpa ! evaporation from reference height to atmosphere [mm/s] + real(r8), intent(out) :: lfevpa ! latent heat from reference height to atmosphere [W/m2] + real(r8), intent(out) :: fseng ! sensible heat flux from ground [W/m2] + real(r8), intent(out) :: fevpg ! evaporation heat flux from ground [mm/s] + + real(r8), intent(out) :: tref ! 2 m height air temperature [kelvin] + real(r8), intent(out) :: qref ! 2 m height air humidity + real(r8), intent(out) :: z0m ! effective roughness [m] + real(r8), intent(out) :: zol ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), intent(out) :: rib ! bulk Richardson number in surface layer + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: tstar ! temperature scaling parameter + real(r8), intent(out) :: qstar ! moisture scaling parameter + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + real(r8), intent(out) :: emis ! averaged bulk surface emissivity + real(r8), intent(out) :: olrg ! longwave up flux at surface [W/m2] + +!-------------------------- Local Variables ---------------------------- + integer isrfty ! surface type index (1-7) + real(r8) cgrndl ! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + real(r8) cgrnds ! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + real(r8) dshf ! Ts partial derivative for sensible heat flux + real(r8) dlhf ! Ts partial derivative for latent heat flux + real(r8) fnt ! net surface flux for input conditions [W/m2] + real(r8) dfntdt ! net surface flux ts partial derivative [W/m2] + real(r8) tsbsf(plsice) ! Non-adjusted srfc/sub-srfc temperatures + real(r8) snowh ! snow depth (liquid water equivalent) [m] + real(r8) sicthk ! sea-ice thickness [m] + + real(r8), parameter :: emisi = 1.0 ! (0.97) surface emissivity for ice or snow [-] + real(r8), parameter :: emisw = 1.0 ! (0.97) surface emissivity for water [-] + real(r8), parameter :: tsice = 271.36 ! freezing point of sea ice [K] + real(r8), parameter :: thsice = 2.0 ! initial thickness of sea ice [m] + real(r8), parameter :: snsice = 0.005 ! initial snow water equivalent over sea ice [m] + + integer j + +!----------------------------------------------------------------------- + + snowh = scv/1000. + + IF(dosst)THEN +! update sea temperatures and sea ice distribution +! as well as snow cover over sea ice + IF(nint(oro).eq.2 .and. tssea.gt.tsice) THEN + oro = 0.0 ! old sea ice melt out + snowh = 0. + scv = 0. + sicthk = 0. + DO j = 1,plsice + tssub(j) = tssea + ENDDO + ELSEIF(nint(oro).eq.0 .and. tssea.le.tsice) THEN + oro = 2.0 ! new sea ice formed + snowh = snsice + scv = snowh*1000. + sicthk = thsice + DO j = 1,plsice + tssub(j) = tssea + ENDDO + ENDIF + ENDIF + + tssea = tssub(1) + +! compute surface fluxes, derivatives, and exchange coefficients + CALL seafluxes (oro,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,tssea,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,cgrndl,cgrnds) + + IF(nint(oro).eq.0)THEN ! ocean + lfevpa = fevpa*hvap + olrg = stefnc*emisw*tssea**4 + (1.-emisw)*frl + emis = emisw + + ELSEIF(nint(oro).eq.2)THEN ! sea ice + lfevpa = fevpa*hsub + + ! net surface flux and derivate at current surface temperature + dshf = cgrnds + dlhf = hsub*cgrndl + olrg = stefnc*emisi*tssea**4 + (1.-emisi)*frl + + fnt = sabg + frl - olrg - fsena - lfevpa + dfntdt = -(dshf + dlhf) - stefnc*emisi*4.*tssea**3 + + ! initialize surface/subsurface temperatures for srftsb + DO j=1,plsice + tsbsf(j) = tssub(j) + ENDDO + + ! set sea ice surface type + isrfty = 2 + + ! diffusion calculation for temperature + CALL srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) + + DO j=1,plsice + tsbsf(j) = min(tsbsf(j),tfrz) + tssub(j) = tsbsf(j) + ENDDO + tssea = tssub(1) + + olrg = stefnc*emisi*tssea**4 + (1.-emisi)*frl + emis = emisi + + ENDIF + + END SUBROUTINE socean + + + + SUBROUTINE seafluxes (oro,hu,ht,hq,& + us,vs,tm,qm,rhoair,psrf,tssea,& + taux,tauy,fsena,fevpa,fseng,fevpg,tref,qref,& + z0m,zol,rib,ustar,qstar,tstar,fm,fh,fq,cgrndl,cgrnds) + +!======================================================================= +! this is the main SUBROUTINE to execute the calculation of thermal processes +! and surface fluxes +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002 +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,rgas,vonkar,grav + USE MOD_FrictionVelocity + USE MOD_Qsadv + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: & + oro, &! ocean(0)/seaice(2)/ flag + + ! atmospherical variables and agcm reference height + hu, &! agcm reference height of wind [m] + ht, &! agcm reference height of temperature [m] + hq, &! agcm reference height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + tssea ! sea surface temperature [K] + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsena, &! sensible heat from agcm reference height to atmosphere [W/m2] + fevpa, &! evaporation from agcm reference height to atmosphere [mm/s] + fseng, &! sensible heat flux from ground [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air humidity + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile FUNCTION for momentum + fh, &! integral of profile FUNCTION for heat + fq, &! integral of profile FUNCTION for moisture + cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + cgrnds ! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + +!-------------------------- Local Variables ---------------------------- + integer i + integer niters,&! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + eg, &! water vapor pressure at temperature T [Pa] + degdT, &! d(eg)/dT + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + qsatg, &! ground saturated specific humidity [kg/kg] + qsatgdT, &! d(qsatg)/dT + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + raih, &! temporary variable [kg/m2/s] + raiw, &! temporary variable [kg/m2/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile FUNCTION for momentum at 10m + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stablity effect [m/s] + ur, &! wind speed at reference height [m/s] + visa, &! kinematic viscosity of dry air [m2/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + xt, &! + xq, &! + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0hg, &! roughness length over ground, sensible heat [m] + z0qg ! roughness length over ground, latent heat [m] + + real, parameter :: zsice = 0.04 ! sea ice aerodynamic roughness length [m] + +!----------------------------------------------------------------------- +! potential temperature at the reference height + beta = 1. ! - (in computing W_*) + zii = 1000. ! m (pbl height) + +!----------------------------------------------------------------------- +! Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!----------------------------------------------------------------------- +! Initialization variables + nmozsgn = 0 + obuold = 0. + + CALL qsadv(tssea,psrf,eg,degdT,qsatg,qsatgdT) + +! potential temperature at the reference height + thm = tm + 0.0098*ht ! intermediate variable equivalent to + ! tm*(pgcm/psrf)**(rgas/cpair) + th = tm*(100000./psrf)**(rgas/cpair) ! potential T + thv = th*(1.+0.61*qm) ! virtual potential T + ur = max(0.1,sqrt(us*us+vs*vs)) ! limit set to 0.1 + + dth = thm-tssea + dqh = qm-qsatg + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-0. + + IF(nint(oro).eq.0)THEN ! ocean + ! Kinematic viscosity of dry air (m2/s)- Andreas (1989) CRREL Rep. 89-11 + visa=1.326e-5*(1.+6.542e-3*tm + 8.301e-6*tm**2 - 4.84e-9*tm**3) + + ! loop to obtain initial and good ustar and zo + ustar=0.06 + wc=0.5 + IF(dthv.ge.0.) THEN + um=max(ur,0.1) + ELSE + um=sqrt(ur*ur+wc*wc) + ENDIF + + DO i=1,5 + z0mg=0.013*ustar*ustar/grav+0.11*visa/ustar + ustar=vonkar*um/log(zldis/z0mg) + ENDDO + + ELSEIF(nint(oro).eq.2)THEN ! sea ice + z0mg = zsice + z0qg = z0mg + z0hg = z0mg + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + +! Evaluated stability-dependent variables using moz from prior iteration + niters=10 + displax = 0. + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters ! begin stability iteration + !---------------------------------------------------------------- + + IF(nint(oro).eq.0)THEN ! ocean + z0mg=0.013*ustar*ustar/grav + 0.11*visa/ustar + xq=2.67*(ustar*z0mg/visa)**0.25 - 2.57 + xt= xq + z0qg=z0mg/exp(xq) + z0hg=z0mg/exp(xt) + ENDIF + + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zol=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF(zol >= 0.) THEN ! stable + zol = min(2.,max(zol,1.e-6)) + ELSE ! unstable + zol = max(-100.,min(zol,-1.e-6)) + ENDIF + obu = zldis/zol + + IF(zol >= 0.)THEN + um = max(ur,0.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF(nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION ! END stability iteration + !---------------------------------------------------------------- + +! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + + raih = rhoair*cpair/rah + raiw = rhoair/raw + cgrnds = raih + cgrndl = raiw*qsatgdT + + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! surface fluxes of momentum, sensible and latent +! using ground temperatures from previous time step + taux = -rhoair*us/ram + tauy = -rhoair*vs/ram + + fseng = -raih*dth + fevpg = -raiw*dqh + fsena = fseng + fevpa = fevpg + +! 2 m height air temperature + tref = thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) + z0m = z0mg + + END SUBROUTINE seafluxes + + + + SUBROUTINE srftsb(isrfty,deltim,fnt,dfntdt,snowh,tsbsf) + +!----------------------------------------------------------------------- +! Compute surface and subsurface temperatures over sea-ice surfaces. +! +! Sea ice temperatures are specified in 'plsice' layers of fixed +! thickness and thermal properties. The forecast temperatures are +! determined from a backward/IMPLICIT diffusion calculation using +! linearized sensible/latent heat fluxes. The bottom ocean temperature +! is fixed at -2C, allowing heat flux exchange with underlying ocean. +! +! Sub-surface layers are indexed 1 at the surface, increasing downwards +! to plsice. Layers have mid-points and interfaces between layers. +! +! Temperatures are defined at mid-points, WHILE fluxes between layers +! and the top/bottom media are defined at layer interfaces. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: tkice, tkair + USE MOD_Utils + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, parameter :: psrfty = 7 ! Number of surface types + integer, parameter :: plsice = 4 ! number of seaice levels + + integer, intent(in) :: isrfty ! surface type index (1 - 7) + real(r8), intent(in) :: deltim ! seconds i a time step (s) + real(r8), intent(in) :: fnt ! top surface/atmosphere net energy flux + real(r8), intent(in) :: dfntdt ! ts partial derivative of net sfc flux + real(r8), intent(in) :: snowh ! snow depth (liquid water equivalent) [m] + + real(r8), intent(inout) :: tsbsf(1:plsice) ! surface/sub-surface tmps + +!-------------------------- Local Variables ---------------------------- + + integer :: j, jndx ! sub-surface layer index + + real(r8) cmass (1:plsice) ! specific heat of soil (J/kg/K) + real(r8) rho (1:plsice) ! mass densty of sub-sfc mat (kg/m3) + real(r8) tk (1:plsice) ! thermal conductivity (watts/m/K) + real(r8) diag (1:plsice) ! diagonal matrix elements + real(r8) htsrc (1:plsice) ! external heat source (W/m3) + real(r8) rhs (1:plsice) ! rhs of tri-diagonal matrix equation + real(r8) sbdiag(1:plsice) ! sub-diagonal matrix elements + real(r8) spdiag(1:plsice) ! super-diagonal matrix elements + real(r8) tin (1:plsice) ! initial sub-surface temperatures + real(r8) z (0:plsice) ! interface geometrical depth (m) + real(r8) ws (1:plsice) ! working storage for mtdlss + + real(r8) cmty ! layer mass heat capacity + real(r8) fbt ! ocean heat flux into sea-ice + real(r8) rhty ! layer mass density + real(r8) thck ! layer thickness + real(r8) tkty ! layer thermal conductivity + real(r8) cmsnow ! Snow mass heat capacity + real(r8) crt ! cmass*rho*rdtime + real(r8) delz ! layer thickness + real(r8) delzmn ! thick from mid-point to lyr above mid-point + real(r8) delzpl ! thick from mid-point to lyr below mid-point + real(r8) fmns ! 1/(delz*delzmn) + real(r8) fpls ! 1/(delz*delzpl) + real(r8) msnow ! mass path of snow + real(r8) mlice ! mass path of ice + real(r8) rdtime ! inverse model time step + real(r8) rhsnow ! snow mass density + real(r8) rztop ! 1/ztop + real(r8) tkbot ! bottom layer top interf thermal conduct + real(r8) tkmns ! layer bottom interface thermal conduct + real(r8) tkpls ! layer top interface thermal conductivity + real(r8) tksnow ! snow thermal conductivity + real(r8) tktop ! top layer bottom interface thermal conduct + real(r8) tmp ! crt - dfntdt(i)*rztop + real(r8) zbot ! bottom layer thickness + real(r8) zm ! present layer mid-point depth + real(r8) zmmn ! layer above mid-point depth + real(r8) zmpl ! layer below mid-point depth + real(r8) zsnow ! snow geometric depth + real(r8) ztop ! top layer thickness + logical scvr ! true IF surface snow covered + +!--------------------------Data Statements------------------------------ +! specified (and invariant) thermal properties for surface types + + real, parameter :: cmair = 1.00e3 ! mass specific heat of air [J/kg/K] + real, parameter :: cmice = 2.07e3 ! mass specific heat of ice [J/kg/K] + real, parameter :: frcair = 0.90 ! fraction of air assumed in mix of ice + real, parameter :: rhair = 1.25 ! mass density of surface air [kg/m3] + real, parameter :: rhice = 9.20e2 ! mass density of ice [kg/m3] + real, parameter :: snwedp = 10.0 ! snow:water equivalent depth factor [-] + + real(r8),parameter,dimension(psrfty,plsice) :: &!mass specific heat (J/kg/K) + cmtype = reshape(& + (/4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& + 4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& + 4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2,& + 4.20e3,2.07e3,2.07e3,1.04e3,7.20e2,5.60e2,4.16e2/), (/7,4/)) + + real(r8),parameter,dimension(psrfty,plsice) :: &! mass density (kg/m3) + rhtype = reshape(& + (/1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& + 1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& + 1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3,& + 1.00e3,9.20e2,9.20e2,2.50e3,2.50e3,2.50e3,2.50e3/),(/7,4/)) + + real(r8),parameter,dimension(psrfty,plsice) :: &!layer thicknesses (m) + thckly = reshape(& + (/ 2., .500, .250, .050, .090, .080, .120, & + 5., .500, .500, .366, .390, .435, .492, & + 10., .500, .500,1.369,1.459,1.628,1.841, & + 33., .500,8.500,6.990,7.450,8.310,9.400/), (/7,4/)) + + real(r8),parameter,dimension(psrfty,plsice) :: &!thermal conductivity (W/m/K) + tktype = reshape(& + (/15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & + 15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & + 15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 , & + 15.0 ,2.200 ,2.200 ,1.408 ,1.104 ,1.071 ,1.019 /), (/7,4/)) + +!----------------------------------------------------------------------- + + rdtime = 1./deltim + +! calculate snow properties + cmsnow = (1.-frcair)*cmice + frcair*cmair + rhsnow = (1.-frcair)*rhice + frcair*rhair + tksnow = (1.-frcair)*tkice + frcair*tkair + +! no external heat source + DO j=1,plsice + htsrc(j) = 0.0 + ENDDO + +! define logical for snow covered surfaces: + scvr = snowh.gt.0. + +! define thermal properties for each sub/surface layer, starting +! with the top layer + jndx = isrfty + thck = thckly(jndx,1) + cmty = cmtype(jndx,1) + rhty = rhtype(jndx,1) + tkty = tktype(jndx,1) + +! initialize fields for no snow cover + z(0) = 0.0 + z(1) = thck + cmass(1) = cmty + rho(1) = rhty + tk(1) = tkty + +! modify layer 1 fields for snow cover IF present +! snow equivalent depth times snow liquid water depth gives the physical +! depth of snow for thermal conduction computation; snow is mixed +! uniformly by mass with the top surface layer + IF(scvr) THEN + zsnow = snowh*snwedp + msnow = rhsnow*zsnow + mlice = rhty*thck + rho(1) = (msnow*rhsnow + mlice*rhty)/(msnow+mlice) + cmass(1) = (msnow*cmsnow + mlice*cmty)/(msnow+mlice) + tk(1) = (msnow*tksnow + mlice*tkty)/(msnow+mlice) + z(1) = (msnow+mlice) / rho(1) + ENDIF + +! set surface thermal properties for the lower sub/surface layers: + DO j=2,plsice + jndx = isrfty + thck = thckly(jndx,j) + cmass(j) = cmtype(jndx,j) + rho(j) = rhtype(jndx,j) + tk(j) = tktype(jndx,j) + z(j) = z(j-1) + thck + ENDDO + +! define set of linear equations for temperature + DO j=1,plsice + tin(j) = tsbsf(j) + ENDDO + +! IF sea ice, compute heat flux from underlying ocean, assumed to be at +! the temperature of -2C + fbt = 0.0 + IF(isrfty.eq.2) THEN + zbot = 0.5*(z(plsice) - z(plsice-1)) + fbt = -tk(plsice)*(271.16 - tin(plsice))/zbot + ENDIF + +! set up linear equations + sbdiag(1) = 0. + spdiag(plsice) = 0. + +! single layer + IF (plsice.eq.1) THEN + rztop = 1./(z(1) - z(0)) + crt = (cmass(1)*rho(1)*rdtime) + diag(1) = crt - dfntdt*rztop + rhs(1) = diag(1)*tin(1) + fnt*rztop - fbt*rztop + htsrc(1) + +! more than one layer: top layer first + ELSEIF (plsice.gt.1) THEN + + crt = cmass(1)*rho(1)*rdtime + ztop = z(1) - z(0) + rztop = 1./ztop + tktop = 0.5*(tk(1) + tk(2)) + zmpl = 0.5*(z(2) + z(1)) + zm = 0.5*(z(1) + z(0)) + delzpl = zmpl - zm + fpls = 1./(ztop*delzpl) + tmp = crt - dfntdt*rztop + + diag(1) = tmp + tktop*fpls + spdiag(1) = -tktop*fpls + rhs(1) = tmp*tin(1) + fnt*rztop + htsrc(1) + +! intermediate layers + DO j=2,plsice-1 + crt = cmass(j)*rho(j)*rdtime + delz = z(j) - z(j-1) + zmpl = 0.5*(z(j+1) + z(j)) + zm = 0.5*(z(j) + z(j-1)) + zmmn = 0.5*(z(j-1) + z(j-2)) + delzpl = zmpl - zm + delzmn = zm - zmmn + fpls = 1./(delz*delzpl) + fmns = 1./(delz*delzmn) + tkpls = 0.5*(tk(j+1)+tk(j)) + tkmns = 0.5*(tk(j)+tk(j-1)) + + sbdiag(j) = -tkmns*fmns + diag(j) = crt + (tkpls*fpls + tkmns*fmns) + spdiag(j) = -tkpls*fpls + rhs(j) = crt*tin(j) + htsrc(j) + ENDDO + +! bottom layer + crt = cmass(plsice)*rho(plsice)*rdtime + zbot = z(plsice) - z(plsice-1) + zm = 0.5*(z(plsice) + z(plsice-1)) + zmmn = 0.5*(z(plsice-1) + z(plsice-2)) + delzmn = zm - zmmn + tkbot = 0.5*(tk(plsice-1) + tk(plsice)) + fmns = 1./(zbot*delzmn) + sbdiag(plsice) = -tkbot*fmns + diag(plsice) = crt + (tkbot*fmns) + rhs(plsice) = crt*tin(plsice) - fbt/zbot + htsrc(plsice) + ENDIF + + IF(plsice.eq.1) THEN + tsbsf(1) = rhs(1)/diag(1) + ELSE + CALL tridia (plsice,sbdiag,diag,spdiag,rhs,tsbsf) + ENDIF + + END SUBROUTINE srftsb + +END MODULE MOD_SimpleOcean +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowFraction.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowFraction.F90 new file mode 100644 index 0000000000..91b23f156a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowFraction.F90 @@ -0,0 +1,175 @@ +#include + +MODULE MOD_SnowFraction + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: snowfraction +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + PUBLIC :: snowfraction_pftwrap +#endif + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE snowfraction (lai,sai,z0m,zlnd,scv,snowdp,wt,sigf,fsno) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Provide snow cover fraction +! +! Original author: Yongjiu Dai, /09/1999/, /04/2014/ +! +! !REVISIONS: +! 10/2019, Hua Yuan: removed fveg to be compatible with PFT +! classification +! +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: scv ! snow water equivalent [mm or kg/m3] + real(r8), intent(in) :: snowdp ! snow depth [m] + real(r8), intent(in) :: z0m ! aerodynamic roughness length [m] + real(r8), intent(in) :: zlnd ! aerodynamic roughness length over soil surface [m] + real(r8), intent(in) :: lai ! leaf area index [-] + real(r8), intent(in) :: sai ! stem area index [-] + + real(r8), intent(out) :: wt ! fraction of vegetation covered with snow [-] + real(r8), intent(out) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(out) :: fsno ! fraction of soil covered by snow [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: fmelt ! dimensionless melting factor + real(r8), parameter :: m = 1.0 ! the value of m used in CLM4.5 is 1.0. + ! WHILE the value of m given by Niu et al (2007) is 1.6 + ! WHILE Niu (2012) suggested 3.0 + +!----------------------------------------------------------------------- + IF(lai+sai > 1e-6) THEN + ! Fraction of vegetation buried (covered) by snow + wt = 0.1*snowdp/z0m + wt = wt/(1.+wt) + + ! Fraction of vegetation cover free of snow + sigf = 1. - wt + ELSE + wt = 0. + sigf = 1. + ENDIF + +! 10/16/2019, yuan: + !IF(sigf < 0.001) sigf = 0. + !IF(sigf > 0.999) sigf = 1. + +! Fraction of soil covered by snow + fsno = 0.0 + IF(snowdp > 0.) THEN + fmelt = (scv/snowdp/100.) ** m + fsno = tanh(snowdp/(2.5 * zlnd * fmelt)) + ENDIF + + END SUBROUTINE snowfraction + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + SUBROUTINE snowfraction_pftwrap (ipatch,zlnd,scv,snowdp,wt,sigf,fsno) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! A wrap SUBROUTINE to calculate snow cover fraction for PFT|PC run +! +! !REVISIONS: +! +! 06/2019, Hua Yuan: initial code adapted from snowfraction() by +! Yongjiu Dai +! +! 08/2019, Hua Yuan: removed fveg to be compatible with PFT +! classification +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_LandPFT + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch ! patch index + + real(r8), intent(in) :: zlnd ! aerodynamic roughness length over soil surface [m] + real(r8), intent(in) :: scv ! snow water equivalent [mm or kg/m3] + real(r8), intent(in) :: snowdp ! snow depth [m] + + real(r8), intent(out) :: wt ! fraction of vegetation covered with snow [-] + real(r8), intent(out) :: sigf ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(out) :: fsno ! fraction of soil covered by snow [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: fmelt ! dimensionless melting factor + real(r8), parameter :: m = 1.0 ! the value of m used in CLM4.5 is 1.0. + ! WHILE the value of m given by Niu et al (2007) is 1.6 + ! WHILE Niu (2012) suggested 3.0 + + integer i, p, ps, pe + real(r8) wt_tmp +!----------------------------------------------------------------------- + + wt_tmp = 0. + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + DO i = ps, pe + p = pftclass(i) + + IF(tlai_p(i)+tsai_p(i) > 1.e-6) THEN + ! Fraction of vegetation buried (covered) by snow + wt = 0.1*snowdp/z0m_p(i) + wt = wt/(1.+wt) + + ! Fraction of vegetation cover free of snow + sigf_p(i) = 1. - wt + ELSE + wt = 0. + sigf_p(i) = 1. + ENDIF + + ! snow on vegetation, USE snowdp to calculate buried fraction + IF ( DEF_VEG_SNOW .and. tlai_p(i)+tsai_p(i) > 1.e-6 ) THEN + ! for trees, use hbot, htop to determine how much lsai being buried. + IF (p.gt.0 .and. p.le.8) THEN + wt = max(0., (snowdp-hbot_p(i))) / (htop_p(i)-hbot_p(i)) + wt = min(wt, 1.) + sigf_p(i) = 1. - wt + ENDIF + ENDIF + + wt_tmp = wt_tmp + wt*pftfrac(i) + ENDDO + + wt = wt_tmp + sigf = sum(sigf_p(ps:pe) * pftfrac(ps:pe)) + + ! Fraction of soil covered by snow + fsno = 0.0 + IF(snowdp > 0.) THEN + fmelt = (scv/snowdp/100.) ** m + fsno = tanh(snowdp/(2.5 * zlnd * fmelt)) + ENDIF + + END SUBROUTINE snowfraction_pftwrap +#endif + +END MODULE MOD_SnowFraction +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowLayersCombineDivide.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowLayersCombineDivide.F90 new file mode 100644 index 0000000000..e108a351d0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowLayersCombineDivide.F90 @@ -0,0 +1,1290 @@ +#include + +MODULE MOD_SnowLayersCombineDivide + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: snowcompaction + PUBLIC :: snowlayerscombine + PUBLIC :: SnowLayersCombine_snicar + PUBLIC :: snowlayersdivide + PUBLIC :: SnowLayersDivide_snicar + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: combo + PRIVATE :: winddriftcompaction + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + + SUBROUTINE snowcompaction (lb,deltim,imelt,fiold,& + t_soisno,wliq_soisno,wice_soisno,forc_us,forc_vs,dz_soisno) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! Revision: Yongjiu Dai, /07/31/2023 +! +! Four of metamorphisms of changing snow characteristics are +! implemented, i.e., destructive, overburden, melt and wind drift. The +! treatments of the destructive compaction was from SNTHERM.89 and +! SNTHERM.99 (1991, 1999). The contribution due to melt metamorphism is +! simply taken as a ratio of snow ice fraction after the melting versus +! before the melting. The treatments of the overburden compaction and +! the drifting compaction were borrowed from CLM5.0 which based on +! Vionnet et al. (2012) and van Kampenhout et al (2017). +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o, tfrz + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: lb ! lower bound of array + real(r8), intent(in) :: deltim ! seconds i a time step [second] + integer, intent(in) :: imelt(lb:0) ! signifies IF node in melting (imelt = 1) + real(r8), intent(in) :: fiold(lb:0) ! fraction of ice relative to the total water content + ! at the previous time step + real(r8), intent(in) :: t_soisno(lb:0) ! nodal temperature [K] + real(r8), intent(in) :: wice_soisno(lb:0) ! ice lens [kg/m2] + real(r8), intent(in) :: wliq_soisno(lb:0) ! liquid water [kg/m2] + real(r8), intent(in) :: forc_us ! wind speed in eastward direction [m/s] + real(r8), intent(in) :: forc_vs ! wind speed in northward direction [m/s] + + real(r8), intent(inout) :: dz_soisno(lb:0) ! layer thickness [m] + +!-------------------------- Local Variables ---------------------------- + integer j ! Numeber of doing loop + + real(r8), parameter :: c1 = 2.777e-7 ! [m2/(kg s)] + real(r8), parameter :: c2 = 23.0e-3 ! [m3/kg] + real(r8), parameter :: c3 = 2.777e-6 ! [1/s] + real(r8), parameter :: c4 = 0.04 ! [1/K] + real(r8), parameter :: c5 = 2.0 ! + real(r8), parameter :: c6 = 5.15e-7 ! + real(r8), parameter :: c7 = 4.0 ! + ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] + real(r8), parameter :: dm = 100.0 + real(r8), parameter :: eta0 = 9.e5 ! The Viscosity Coefficient Eta0 [kg-s/m2] + + real(r8) :: burden ! pressure of overlying snow [kg/m2] + real(r8) :: ddz1 ! rate of settling of snowpack due to destructive metamorphism. + real(r8) :: ddz2 ! rate of compaction of snowpack due to overburden. + real(r8) :: ddz3 ! rate of compaction of snowpack due to melt [1/s] + real(r8) :: ddz4 ! rate of compaction of snowpack due to wind drift. + + real(r8) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). + real(r8) :: fi ! fraction of ice relative to the total water content at current time step + real(r8) :: td ! t_soisno - tfrz [K] + real(r8) :: pdzdtc ! nodal rate of change in fractional-thickness due to compaction [fraction/s] + real(r8) :: void ! void (1 - vol_ice - vol_liq) + real(r8) :: wx ! water mass (ice+liquid) [kg/m2] + real(r8) :: bi ! partial density of ice [kg/m3] + + real(r8) :: zpseudo ! wind drift compaction / pseudo depth + ! (only valid IF wind_dependent_snow_density is .true.) + logical :: mobile ! current snow layer is mobile, i.e. susceptible to wind drift + ! (only valid IF wind_dependent_snow_density is .true.) + real(r8) :: f1, f2, eta, forc_wind + +!----------------------------------------------------------------------- + ! Begin calculation - note that the following column loops are only invoked IF lb < 0 + + burden = 0.0 + zpseudo = 0.0 + mobile = .true. + + DO j = lb, 0 + wx = wice_soisno(j) + wliq_soisno(j) + void = 1.0-(wice_soisno(j)/denice + wliq_soisno(j)/denh2o)/dz_soisno(j) + +! Disallow compaction for water saturated node and lower ice lens node. + IF(void <= 0.001 .or. wice_soisno(j) <= .1)THEN + burden = burden+wx + + ! saturated node is immobile + ! This is only needed IF wind_dependent_snow_density is true, but it's + ! simplest just to update mobile always + mobile = .false. + + CYCLE + ENDIF + + bi = wice_soisno(j) / dz_soisno(j) + fi = wice_soisno(j) / wx + td = tfrz-t_soisno(j) + + dexpf = exp(-c4*td) + +! Compaction due to destructive metamorphism + ddz1 = -c3*dexpf + IF(bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + +! Liquid water term + IF(wliq_soisno(j) > 0.01*dz_soisno(j)) ddz1=ddz1*c5 + +! Compaction due to overburden +!* ddz2 = -burden*exp(-0.08*td-c2*bi)/eta0 + f1 = 1.0/(1.0+60.0*wliq_soisno(j)/(denh2o*dz_soisno(j))) + f2 = 4.0 ! currently fixed to maximum value, holds in absence of angular grains + eta = f1*f2*(bi/450.0)*exp(0.1*td + c2*bi)*7.62237e6 + ddz2 = -(burden+wx/2.0) / eta + +! Compaction occurring during melt + IF(imelt(j) == 1)THEN + ddz3 = - 1.0/deltim * max(0.0,(fiold(j) - fi)/fiold(j)) + ELSE + ddz3 = 0.0 + ENDIF + +! Compaction occurring due to wind drift + forc_wind = sqrt(forc_us**2+forc_vs**2) + CALL winddriftcompaction( bi,forc_wind,dz_soisno(j),zpseudo,mobile,ddz4 ) + +! Time rate of fractional change in dz (units of s-1) + pdzdtc = ddz1 + ddz2 + ddz3 + ddz4 + +! The change in dz_soisno due to compaction +! Limit compaction to be no greater than fully saturated layer thickness + dz_soisno(j) = dz_soisno(j)*(1.0+pdzdtc*deltim) + dz_soisno(j) = max(dz_soisno(j),(wice_soisno(j)/denice+ wliq_soisno(j)/denh2o)) + +! Pressure of overlying snow + burden = burden+wx + + ENDDO + + END SUBROUTINE snowcompaction + + + + SUBROUTINE winddriftcompaction(bi,forc_wind,dz,zpseudo,mobile,compaction_rate) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! Compute wind drift compaction for a single column and level. Also +! updates zpseudo and mobile for this column. However, zpseudo remains +! unchanged IF mobile is already false or becomes false within this +! SUBROUTINE. +! +! The structure of the updates done here for zpseudo and mobile +! requires that this SUBROUTINE be called first for the top layer of +! snow, THEN for the 2nd layer down, etc. - and finally for the bottom +! layer. Before beginning the loops over layers, mobile should be +! initialized to .true. and zpseudo should be initialized to 0. +! +! !REVISIONS: Yongjiu Dai, /07/31/2023 +! +! !USES: + USE MOD_Precision + ! + ! !ARGUMENTS: + real(r8) , intent(in) :: bi ! partial density of ice [kg/m3] + real(r8) , intent(in) :: forc_wind ! atmospheric wind speed [m/s] + real(r8) , intent(in) :: dz ! layer depth for this column and level [m] + ! wind drift compaction / pseudo depth for this column at this layer + real(r8) , intent(inout) :: zpseudo + ! whether this snow column is still mobile at this layer (i.e., susceptible to wind drift) + logical , intent(inout) :: mobile + ! rate of compaction of snowpack due to wind drift, for the current column and layer + real(r8) , intent(out) :: compaction_rate + ! + ! !LOCAL VARIABLES: + real(r8) :: Frho ! Mobility density factor [-] + real(r8) :: MO ! Mobility index [-] + real(r8) :: SI ! Driftability index [-] + real(r8) :: gamma_drift ! Scaling factor for wind drift time scale [-] + real(r8) :: tau_inverse ! Inverse of the effective time scale [1/s] + + real(r8), parameter :: rho_min = 50._r8 ! wind drift compaction / minimum density [kg/m3] + real(r8), parameter :: rho_max = 350._r8 ! wind drift compaction / maximum density [kg/m3] + ! wind drift compaction / grain size (fixed value for now) + real(r8), parameter :: drift_gs = 0.35e-3_r8 + real(r8), parameter :: drift_sph = 1.0_r8 ! wind drift compaction / sphericity + real(r8), parameter :: tau_ref = 48._r8 * 3600._r8 ! wind drift compaction / reference time [s] + + !----------------------------------------------------------------------- + + IF (mobile) THEN + Frho = 1.25_r8 - 0.0042_r8*(max(rho_min, bi)-rho_min) + ! assuming dendricity = 0, sphericity = 1, grain size = 0.35 mm Non-dendritic snow + MO = 0.34_r8 * (-0.583_r8*drift_gs - 0.833_r8*drift_sph + 0.833_r8) + 0.66_r8*Frho + SI = -2.868_r8 * exp(-0.085_r8*forc_wind) + 1._r8 + MO + + IF (SI > 0.0_r8) THEN + SI = min(SI, 3.25_r8) + ! Increase zpseudo (wind drift / pseudo depth) to the middle of + ! the pseudo-node for the sake of the following calculation + zpseudo = zpseudo + 0.5_r8 * dz * (3.25_r8 - SI) + gamma_drift = SI*exp(-zpseudo/0.1_r8) + tau_inverse = gamma_drift / tau_ref + compaction_rate = -max(0.0_r8, rho_max-bi) * tau_inverse + ! Further increase zpseudo to the bottom of the pseudo-node for + ! the sake of calculations done on the underlying layer (i.e., + ! the next time through the j loop). + zpseudo = zpseudo + 0.5_r8 * dz * (3.25_r8 - SI) + ELSE ! SI <= 0 + mobile = .false. + compaction_rate = 0._r8 + ENDIF + ELSE ! .not. mobile + compaction_rate = 0._r8 + ENDIF + + END SUBROUTINE winddriftcompaction + + + + !----------------------------------------------------------------------- + SUBROUTINE snowlayerscombine (lb,snl, & + z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno,scv,snowdp) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! checks for elements which are below prescribed minimum for thickness +! or mass. If snow element thickness or mass is less than a prescribed +! minimum, it is combined with neighboring element to be best combine +! with, and executes the combination of mass and energy in +! clm_combo.f90 +! +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb ! lower bound of array + +! numbering from 1 (bottom) mss (surface) + real(r8), intent(inout) :: wice_soisno(lb:1) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:1) ! liquid water {kg/m2] + real(r8), intent(inout) :: t_soisno (lb:1) ! node temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:1) ! layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:1) ! node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:1) ! depth of layer interface [m] + real(r8), intent(inout) :: snowdp ! snow depth [m] + real(r8), intent(inout) :: scv ! snow mass - water equivalent [kg/m2] + integer, intent(inout) :: snl ! Number of snow + +!-------------------------- Local Variables ---------------------------- + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzmin(5) ! minimum of snow layer 1 (top) to msn0 (bottom) + real(r8) :: zwice ! total ice mass in snow + real(r8) :: zwliq ! total liquid water in snow + + integer :: i ! number of DO looping + integer :: j ! node index + integer :: k ! number of DO looping + integer :: l ! node index + integer :: msn_old ! number of snow layer 1 (top) to msn0 (bottom) + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + + data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ + +!----------------------------------------------------------------------- +! check the mass of ice lens of snow, when the total less than a small value, +! combine it with the underlying neighbor + msn_old = snl + DO j = msn_old+1, 0 + IF(wice_soisno(j) <= .1)THEN + wliq_soisno(j+1) = wliq_soisno(j+1) + wliq_soisno(j) + wice_soisno(j+1) = wice_soisno(j+1) + wice_soisno(j) + +! shift all elements above this down one. + IF(j > snl+1 .and. snl < -1)THEN + DO i = j, snl+2, -1 + t_soisno(i) = t_soisno(i-1) + wliq_soisno(i) = wliq_soisno(i-1) + wice_soisno(i) = wice_soisno(i-1) + dz_soisno(i) = dz_soisno(i-1) + ENDDO + ENDIF + + snl = snl + 1 +!* write(6,*) 'one snow layer is gone' + + ENDIF + + ENDDO + + IF(snl == 0)THEN + scv = 0. + snowdp = 0. +!* write(6,*) 'all snow has gone' + RETURN + ELSE + scv = 0. + snowdp = 0. + zwice = 0. + zwliq = 0. + DO j = snl + 1, 0 + scv = scv + wice_soisno(j) + wliq_soisno(j) + snowdp = snowdp + dz_soisno(j) + zwice = zwice + wice_soisno(j) + zwliq = zwliq + wliq_soisno(j) + ENDDO + ENDIF +!----------------------------------------------------------------------- +! check the snow depth + + IF(snowdp < 0.01)THEN !!! all snow gone + + snl = 0 + scv = zwice + IF(scv <= 0.) snowdp = 0. + +! the liquid water assumed ponding on soil surface + wliq_soisno(1) = wliq_soisno(1) + zwliq +!* write(6,'(17h all snow is gone)') + RETURN + + ELSE !!! snow layers combined + +! two or more layers + + IF(snl < -1)THEN + msn_old = snl + mssi = 1 + DO i = msn_old+1, 0 + +! If top node is removed, combine with bottom neighbor + IF(dz_soisno(i) < dzmin(mssi))THEN + IF(i == snl+1)THEN + neibor = i + 1 + +! If the bottom neighbor is not snow, combine with the top neighbor + ELSEIF(i == 0)THEN + neibor = i - 1 + +! If NONE of the above special cases apply, combine with the thinnest neighbor + ELSE + neibor = i + 1 + IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 + ENDIF + +! Node l and j are combined and stored as node j. + + IF(neibor > i)THEN + j = neibor + l = i + ELSE + j = i + l = neibor + ENDIF + CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& + dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) + +! Now shift all elements above this down one. + + IF(j-1 > snl+1) THEN + DO k = j-1, snl+2, -1 + t_soisno(k) = t_soisno(k-1) + wice_soisno(k) = wice_soisno(k-1) + wliq_soisno(k) = wliq_soisno(k-1) + dz_soisno(k) = dz_soisno(k-1) + ENDDO + ENDIF + + snl = snl + 1 + +!* write(6,'(7h Nodes ,i4,4h and,i4,14h combined into,i4)') l,j,j + + IF(snl >= -1) EXIT + +! The layer thickness great than the prescribed minimum value + + ELSE + mssi = mssi + 1 + ENDIF + ENDDO + + ENDIF + +! Reset the node depth and the depth of layer interface + + zi_soisno(0) = 0. + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO + + ENDIF !!! snow layers combined + + END SUBROUTINE snowlayerscombine + + + + SUBROUTINE snowlayersdivide(lb,snl,z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! subdivides snow layer when its thickness exceed the prescribed maximum +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: lb ! lower bound of array + integer, intent(inout) :: snl ! Number of snow + real(r8), intent(inout) :: wice_soisno(lb:0) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:0) ! liquid water [kg/m2] + real(r8), intent(inout) :: t_soisno (lb:0) ! Node temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:0) ! Layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:0) ! Node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:0) ! Depth of layer interface [m] + +!-------------------------- Local Variables ---------------------------- + +! numbering from 1 (surface) msno (bottom) + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzsno(5) ! Snow layer thickness [m] + real(r8) :: swice(5) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(5) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(5) ! Nodel temperature [K] + + integer k ! number of DO looping + integer msno ! number of snow layer 1 (top) to msno (bottom) + + real(r8) zwice,zwliq,propor + +!----------------------------------------------------------------------- + + msno = abs(snl) + DO k = 1, msno + dzsno(k) = dz_soisno (k + snl) + swice(k) = wice_soisno(k + snl) + swliq(k) = wliq_soisno(k + snl) + tsno(k) = t_soisno (k + snl) + ENDDO + + IF(msno == 1)THEN + IF(dzsno(1) > 0.03)THEN + msno = 2 +! Specified a new snow layer + dzsno(1) = dzsno(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. + + dzsno(2) = dzsno(1) + swice(2) = swice(1) + swliq(2) = swliq(1) + tsno(2) = tsno(1) +! write(6,*)'Subdivided Top Node into two layer (1/2)' + ENDIF + ENDIF + + IF(msno > 1)THEN + IF(dzsno(1) > 0.02)THEN + drr = dzsno(1) - 0.02 + propor = drr/dzsno(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) + + propor = 0.02/dzsno(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) + dzsno(1) = 0.02 + + CALL combo(dzsno(2),swliq(2),swice(2),tsno(2), & + drr,zwliq,zwice,tsno(1)) + +! write(6,*) 'Subdivided Top Node & +! 20 mm combined into underlying neighbor' + + IF(msno <= 2 .and. dzsno(2) > 0.07)THEN +! subdivided a new layer + msno = 3 + dzsno(2) = dzsno(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. + + dzsno(3) = dzsno(2) + swice(3) = swice(2) + swliq(3) = swliq(2) + tsno(3) = tsno(2) + ENDIF + ENDIF + ENDIF + + IF(msno > 2)THEN + IF(dzsno(2) > 0.05)THEN + drr = dzsno(2) - 0.05 + propor = drr/dzsno(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) + + propor = 0.05/dzsno(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) + dzsno(2) = 0.05 + + CALL combo(dzsno(3),swliq(3),swice(3),tsno(3), & + drr, zwliq, zwice, tsno(2)) + +! write(6,*)'Subdivided 50 mm from the subsurface layer & +! &and combined into underlying neighbor' + + IF(msno <= 3 .and. dzsno(3) > 0.18)THEN +! subdivided a new layer + msno = 4 + dzsno(3) = dzsno(3)/2. + swice(3) = swice(3)/2. + swliq(3) = swliq(3)/2. + + dzsno(4) = dzsno(3) + swice(4) = swice(3) + swliq(4) = swliq(3) + tsno(4) = tsno(3) + ENDIF + ENDIF + ENDIF + + IF(msno > 3)THEN + IF(dzsno(3) > 0.11)THEN + drr = dzsno(3) - 0.11 + propor = drr/dzsno(3) + zwice = propor*swice(3) + zwliq = propor*swliq(3) + + propor = 0.11/dzsno(3) + swice(3) = propor*swice(3) + swliq(3) = propor*swliq(3) + dzsno(3) = 0.11 + + CALL combo(dzsno(4),swliq(4),swice(4),tsno(4), & + drr, zwliq, zwice, tsno(3)) + +! write(6,*)'Subdivided 110 mm from the third Node & +! &and combined into underlying neighbor' + + IF(msno <= 4 .and. dzsno(4) > 0.41)THEN +! subdivided a new layer + msno = 5 + dzsno(4) = dzsno(4)/2. + swice(4) = swice(4)/2. + swliq(4) = swliq(4)/2. + + dzsno(5) = dzsno(4) + swice(5) = swice(4) + swliq(5) = swliq(4) + tsno(5) = tsno(4) + ENDIF + ENDIF + ENDIF + + IF(msno > 4)THEN + IF(dzsno(4) > 0.23)THEN + drr = dzsno(4) - 0.23 + propor = drr/dzsno(4) + zwice = propor*swice(4) + zwliq = propor*swliq(4) + + propor = 0.23/dzsno(4) + swice(4) = propor*swice(4) + swliq(4) = propor*swliq(4) + dzsno(4) = 0.23 + + CALL combo(dzsno(5),swliq(5),swice(5),tsno(5), & + drr, zwliq, zwice, tsno(4)) + +! write(6,*)'Subdivided 230 mm from the fourth Node & +! 'and combined into underlying neighbor' + ENDIF + ENDIF + + snl = - msno + + DO k = snl+1, 0 + dz_soisno(k) = dzsno(k - snl) + wice_soisno(k) = swice(k - snl) + wliq_soisno(k) = swliq(k - snl) + t_soisno(k) = tsno (k - snl) + ENDDO + + zi_soisno(0) = 0. + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO + + END SUBROUTINE snowlayersdivide + + + + SUBROUTINE combo ( dz_soisno, wliq_soisno, wice_soisno, t, & + dz2, wliq2, wice2, t2 ) + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! combines two elements and returns the following combined +! variabless: dz_soisno, t, wliq_soisno, wice_soisno. +! the combined temperature is based on the equation: +! the sum of the enthalpies of the two elements = that of the combined element. +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: cpice, cpliq, hfus, tfrz + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] + real(r8), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] + real(r8), intent(in) :: wice2 ! ice of element 2 [kg/m2] + real(r8), intent(in) :: t2 ! nodal temperature of element 2 [K] + + real(r8), intent(inout) :: dz_soisno ! nodal thickness of 1 elements being combined [m] + real(r8), intent(inout) :: wliq_soisno ! liquid water of element 1 + real(r8), intent(inout) :: wice_soisno ! ice of element 1 [kg/m2] + real(r8), intent(inout) :: t ! node temperature of elment 1 [K] + +!-------------------------- Local Variables ---------------------------- + + real(r8) dzc ! Total thickness of nodes 1 and 2 (dzc=dz_soisno+dz2). + real(r8) wliqc ! Combined liquid water [kg/m2] + real(r8) wicec ! Combined ice [kg/m2] + real(r8) tc ! Combined node temperature [K] + real(r8) h ! enthalpy of element 1 [J/m2] + real(r8) h2 ! enthalpy of element 2 [J/m2] + real(r8) hc ! temporary + +!----------------------------------------------------------------------- + + dzc = dz_soisno+dz2 + wicec = (wice_soisno+wice2) + wliqc = (wliq_soisno+wliq2) + h = (cpice*wice_soisno+cpliq*wliq_soisno)*(t-tfrz)+hfus*wliq_soisno + h2 = (cpice*wice2+cpliq*wliq2)*(t2-tfrz)+hfus*wliq2 + + hc = h + h2 + IF(hc < 0.)THEN + tc = tfrz + hc/(cpice*wicec+cpliq*wliqc) + ELSEIF(hc.le.hfus*wliqc)THEN + tc = tfrz + ELSE + tc = tfrz + (hc - hfus*wliqc)/(cpice*wicec+cpliq*wliqc) + ENDIF + + dz_soisno = dzc + wice_soisno = wicec + wliq_soisno = wliqc + t = tc + + END SUBROUTINE combo + + + SUBROUTINE SnowLayersCombine_snicar (lb,snl, & + z_soisno,dz_soisno,zi_soisno,wliq_soisno,wice_soisno,t_soisno,scv,snowdp,& + +! Aerosol Fluxes (Jan. 07, 2023) + mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi,& + mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ) +! Aerosol Fluxes (Jan. 07, 2023) + + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999; January 07, 2023 +! +! checks for elements which are below prescribed minimum for thickness or mass. +! If snow element thickness or mass is less than a prescribed minimum, +! it is combined with neighboring element to be best combine with, +! and executes the combination of mass and energy in clm_combo.f90 +! +! !REVISIONS: +! Yongjiu Dai, 01/2023: added Aerosol fluxes from SNICAR model +!======================================================================= + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb ! lower bound of array + +! numbering from 1 (bottom) mss (surface) + real(r8), intent(inout) :: wice_soisno(lb:1) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:1) ! liquid water {kg/m2] + real(r8), intent(inout) :: t_soisno (lb:1) ! node temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:1) ! layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:1) ! node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:1) ! depth of layer interface [m] + real(r8), intent(inout) :: snowdp ! snow depth [m] + real(r8), intent(inout) :: scv ! snow mass - water equivalent [kg/m2] + integer, intent(inout) :: snl ! Number of snow + +! Aerosol Fluxes (Jan. 07, 2023) + real(r8), intent(inout) :: & + mss_bcpho (lb:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lb:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lb:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lb:0), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lb:0), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lb:0), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lb:0), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lb:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) + +!-------------------------- Local Variables ---------------------------- + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzmin(5) ! minimum of snow layer 1 (top) to msn0 (bottom) + real(r8) :: zwice ! total ice mass in snow + real(r8) :: zwliq ! total liquid water in snow + + integer :: i ! number of DO looping + integer :: j ! node index + integer :: k ! number of DO looping + integer :: l ! node index + integer :: msn_old ! number of snow layer 1 (top) to msn0 (bottom) + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + + data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ + +!----------------------------------------------------------------------- +! check the mass of ice lens of snow, when the total less than a small value, +! combine it with the underlying neighbor + msn_old = snl + DO j = msn_old+1, 0 + IF(wice_soisno(j) <= .1)THEN + wliq_soisno(j+1) = wliq_soisno(j+1) + wliq_soisno(j) + wice_soisno(j+1) = wice_soisno(j+1) + wice_soisno(j) + +!Aerosol Fluxes (January 07, 2023) + IF (j < 0) THEN ! 01/11/2023, yuan: add j < 0 + mss_bcphi(j+1) = mss_bcphi(j+1) + mss_bcphi(j) + mss_bcpho(j+1) = mss_bcpho(j+1) + mss_bcpho(j) + mss_ocphi(j+1) = mss_ocphi(j+1) + mss_ocphi(j) + mss_ocpho(j+1) = mss_ocpho(j+1) + mss_ocpho(j) + mss_dst1 (j+1) = mss_dst1 (j+1) + mss_dst1 (j) + mss_dst2 (j+1) = mss_dst2 (j+1) + mss_dst2 (j) + mss_dst3 (j+1) = mss_dst3 (j+1) + mss_dst3 (j) + mss_dst4 (j+1) = mss_dst4 (j+1) + mss_dst4 (j) + ENDIF +!Aerosol Fluxes (January 07, 2023) + + +! shift all elements above this down one. + IF(j > snl+1 .and. snl < -1)THEN + DO i = j, snl+2, -1 + t_soisno(i) = t_soisno(i-1) + wliq_soisno(i) = wliq_soisno(i-1) + wice_soisno(i) = wice_soisno(i-1) + dz_soisno(i) = dz_soisno(i-1) + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(i) = mss_bcphi(i-1) + mss_bcpho(i) = mss_bcpho(i-1) + mss_ocphi(i) = mss_ocphi(i-1) + mss_ocpho(i) = mss_ocpho(i-1) + mss_dst1 (i) = mss_dst1 (i-1) + mss_dst2 (i) = mss_dst2 (i-1) + mss_dst3 (i) = mss_dst3 (i-1) + mss_dst4 (i) = mss_dst4 (i-1) +!Aerosol Fluxes (January 07, 2023) + ENDDO + ENDIF + + snl = snl + 1 +!* write(6,*) 'one snow layer is gone' + + ENDIF + + ENDDO + + IF(snl == 0)THEN + scv = 0._r8 + snowdp = 0._r8 + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(:) = 0._r8 + mss_bcpho(:) = 0._r8 + mss_ocphi(:) = 0._r8 + mss_ocpho(:) = 0._r8 + mss_dst1 (:) = 0._r8 + mss_dst2 (:) = 0._r8 + mss_dst3 (:) = 0._r8 + mss_dst4 (:) = 0._r8 +!Aerosol Fluxes (January 07, 2023) + +!* write(6,*) 'all snow has gone' + RETURN + ELSE + scv = 0._r8 + snowdp = 0._r8 + zwice = 0._r8 + zwliq = 0._r8 + DO j = snl + 1, 0 + scv = scv + wice_soisno(j) + wliq_soisno(j) + snowdp = snowdp + dz_soisno(j) + zwice = zwice + wice_soisno(j) + zwliq = zwliq + wliq_soisno(j) + ENDDO + ENDIF +!----------------------------------------------------------------------- +! check the snow depth + + IF(snowdp < 0.01_r8)THEN !!! all snow gone + + snl = 0 + scv = zwice + IF(scv <= 0._r8) snowdp = 0._r8 + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(:) = 0._r8 + mss_bcpho(:) = 0._r8 + mss_ocphi(:) = 0._r8 + mss_ocpho(:) = 0._r8 + mss_dst1 (:) = 0._r8 + mss_dst2 (:) = 0._r8 + mss_dst3 (:) = 0._r8 + mss_dst4 (:) = 0._r8 +!Aerosol Fluxes (January 07, 2023) + +! the liquid water assumed ponding on soil surface + wliq_soisno(1) = wliq_soisno(1) + zwliq +!* write(6,'(17h all snow is gone)') + RETURN + + ELSE !!! snow layers combined + +! two or more layers + + IF(snl < -1)THEN + msn_old = snl + mssi = 1 + DO i = msn_old+1, 0 + +! If top node is removed, combine with bottom neighbor + IF(dz_soisno(i) < dzmin(mssi))THEN + IF(i == snl+1)THEN + neibor = i + 1 + +! If the bottom neighbor is not snow, combine with the top neighbor + ELSEIF(i == 0)THEN + neibor = i - 1 + +! If NONE of the above special cases apply, combine with the thinnest neighbor + ELSE + neibor = i + 1 + IF((dz_soisno(i-1)+dz_soisno(i)) < (dz_soisno(i+1)+dz_soisno(i))) neibor = i-1 + ENDIF + +! Node l and j are combined and stored as node j. + + IF(neibor > i)THEN + j = neibor + l = i + ELSE + j = i + l = neibor + ENDIF + CALL combo ( dz_soisno(j), wliq_soisno(j), wice_soisno(j), t_soisno(j),& + dz_soisno(l), wliq_soisno(l), wice_soisno(l), t_soisno(l) ) + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(j) = mss_bcphi(j) + mss_bcphi(l) + mss_bcpho(j) = mss_bcpho(j) + mss_bcpho(l) + mss_ocphi(j) = mss_ocphi(j) + mss_ocphi(l) + mss_ocpho(j) = mss_ocpho(j) + mss_ocpho(l) + mss_dst1 (j) = mss_dst1 (j) + mss_dst1 (l) + mss_dst2 (j) = mss_dst2 (j) + mss_dst2 (l) + mss_dst3 (j) = mss_dst3 (j) + mss_dst3 (l) + mss_dst4 (j) = mss_dst4 (j) + mss_dst4 (l) +!Aerosol Fluxes (January 07, 2023) + + +! Now shift all elements above this down one. + + IF(j-1 > snl+1) THEN + DO k = j-1, snl+2, -1 + t_soisno(k) = t_soisno(k-1) + wice_soisno(k) = wice_soisno(k-1) + wliq_soisno(k) = wliq_soisno(k-1) + dz_soisno(k) = dz_soisno(k-1) + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(k) = mss_bcphi(k-1) + mss_bcpho(k) = mss_bcpho(k-1) + mss_ocphi(k) = mss_ocphi(k-1) + mss_ocpho(k) = mss_ocpho(k-1) + mss_dst1 (k) = mss_dst1 (k-1) + mss_dst2 (k) = mss_dst2 (k-1) + mss_dst3 (k) = mss_dst3 (k-1) + mss_dst4 (k) = mss_dst4 (k-1) +!Aerosol Fluxes (January 07, 2023) + ENDDO + ENDIF + + snl = snl + 1 + +!* write(6,'(7h Nodes ,i4,4h and,i4,14h combined into,i4)') l,j,j + + IF(snl >= -1) EXIT + +! The layer thickness great than the prescribed minimum value + + ELSE + mssi = mssi + 1 + ENDIF + ENDDO + + ENDIF + +! Reset the node depth and the depth of layer interface + + zi_soisno(0) = 0._r8 + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5_r8*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO + + ENDIF !!! snow layers combined + + END SUBROUTINE SnowLayersCombine_snicar +!----------------------------------------------------------------------- + + + SUBROUTINE SnowLayersDivide_snicar (lb,snl,z_soisno,dz_soisno,zi_soisno,& + wliq_soisno,wice_soisno,t_soisno,& + +! Aerosol Fluxes (Jan. 07, 2023) + mss_bcpho, mss_bcphi, mss_ocpho, mss_ocphi,& + mss_dst1 , mss_dst2 , mss_dst3 , mss_dst4 ) +! Aerosol Fluxes (Jan. 07, 2023) + + +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999, January 07, 2023 +! +! subdivides snow layer when its thickness exceed the prescribed maximum +! +! !REVISIONS: +! Yongjiu Dai, 01/2023: added Aerosol fluxes from SNICAR model +!======================================================================= + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: lb ! lower bound of array + integer, intent(inout) :: snl ! Number of snow + real(r8), intent(inout) :: wice_soisno(lb:0) ! ice lens [kg/m2] + real(r8), intent(inout) :: wliq_soisno(lb:0) ! liquid water [kg/m2] + real(r8), intent(inout) :: t_soisno (lb:0) ! Node temperature [K] + real(r8), intent(inout) :: dz_soisno (lb:0) ! Layer thickness [m] + real(r8), intent(inout) :: z_soisno (lb:0) ! Node depth [m] + real(r8), intent(inout) :: zi_soisno (lb-1:0) ! Depth of layer interface [m] + +! Aerosol Fluxes (Jan. 07, 2023) + real(r8), intent(inout) :: & + mss_bcpho (lb:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lb:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lb:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lb:0), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lb:0), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lb:0), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lb:0), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lb:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) + +!-------------------------- Local Variables ---------------------------- + +! numbering from 1 (surface) msno (bottom) + real(r8) :: drr ! thickness of the combined [m] + real(r8) :: dzsno(5) ! Snow layer thickness [m] + real(r8) :: swice(5) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(5) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(5) ! Node temperature [K] + + integer k ! number of DO looping + integer msno ! number of snow layer 1 (top) to msno (bottom) + + real(r8) zwice,zwliq,propor + +!Aerosol Fluxes (January 07, 2023) + real(r8) mss_aerosol(5,8) + real(r8) z_mss_aerosol(8) +!Aerosol Fluxes (January 07, 2023) + +!----------------------------------------------------------------------- + + msno = abs(snl) + DO k = 1, msno + dzsno(k) = dz_soisno (k + snl) + swice(k) = wice_soisno(k + snl) + swliq(k) = wliq_soisno(k + snl) + tsno (k) = t_soisno (k + snl) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(k, 1) = mss_bcphi(k+snl) + mss_aerosol(k, 2) = mss_bcpho(k+snl) + mss_aerosol(k, 3) = mss_ocphi(k+snl) + mss_aerosol(k, 4) = mss_ocpho(k+snl) + mss_aerosol(k, 5) = mss_dst1 (k+snl) + mss_aerosol(k, 6) = mss_dst2 (k+snl) + mss_aerosol(k, 7) = mss_dst3 (k+snl) + mss_aerosol(k, 8) = mss_dst4 (k+snl) +!Aerosol Fluxes (January 07, 2023) + + ENDDO + + IF(msno == 1)THEN + IF(dzsno(1) > 0.03)THEN + msno = 2 +! Specified a new snow layer + dzsno(1) = dzsno(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(1,:) = mss_aerosol(1,:)/2. +!Aerosol Fluxes (January 07, 2023) + + dzsno(2) = dzsno(1) + swice(2) = swice(1) + swliq(2) = swliq(1) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(2,:) = mss_aerosol(1,:) +!Aerosol Fluxes (January 07, 2023) + + tsno(2) = tsno(1) + +! write(6,*)'Subdivided Top Node into two layer (1/2)' + ENDIF + ENDIF + + IF(msno > 1)THEN + IF(dzsno(1) > 0.02)THEN + drr = dzsno(1) - 0.02 + propor = drr/dzsno(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) +!Aerosol Fluxes (January 07, 2023) + z_mss_aerosol(:) = propor*mss_aerosol(1,:) +!Aerosol Fluxes (January 07, 2023) + + propor = 0.02/dzsno(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(1,:) = propor*mss_aerosol(1,:) +!Aerosol Fluxes (January 07, 2023) + + dzsno(1) = 0.02 + + CALL combo(dzsno(2),swliq(2),swice(2),tsno(2), & + drr,zwliq,zwice,tsno(1)) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(2,:) = z_mss_aerosol(:) + mss_aerosol(2,:) +!Aerosol Fluxes (January 07, 2023) + +! write(6,*) 'Subdivided Top Node & +! 20 mm combined into underlying neighbor' + + IF(msno <= 2 .and. dzsno(2) > 0.07)THEN +! subdivided a new layer + msno = 3 + dzsno(2) = dzsno(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(2,:) = mss_aerosol(2,:)/2. +!Aerosol Fluxes (January 07, 2023) + + dzsno(3) = dzsno(2) + swice(3) = swice(2) + swliq(3) = swliq(2) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(3,:) = mss_aerosol(2,:) +!Aerosol Fluxes (January 07, 2023) + + tsno(3) = tsno(2) + ENDIF + ENDIF + ENDIF + + IF(msno > 2)THEN + IF(dzsno(2) > 0.05)THEN + drr = dzsno(2) - 0.05 + propor = drr/dzsno(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) +!Aerosol Fluxes (January 07, 2023) + z_mss_aerosol(:) = propor*mss_aerosol(2,:) +!Aerosol Fluxes (January 07, 2023) + + propor = 0.05/dzsno(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(2,:) = propor*mss_aerosol(2,:) +!Aerosol Fluxes (January 07, 2023) + + dzsno(2) = 0.05 + + CALL combo(dzsno(3),swliq(3),swice(3),tsno(3), & + drr, zwliq, zwice, tsno(2)) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(3,:) = z_mss_aerosol(:) + mss_aerosol(3,:) +!Aerosol Fluxes (January 07, 2023) + +! write(6,*)'Subdivided 50 mm from the subsurface layer & +! &and combined into underlying neighbor' + + IF(msno <= 3 .and. dzsno(3) > 0.18)THEN +! subdivided a new layer + msno = 4 + dzsno(3) = dzsno(3)/2. + swice(3) = swice(3)/2. + swliq(3) = swliq(3)/2. +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(3,:) = mss_aerosol(3,:)/2. +!Aerosol Fluxes (January 07, 2023) + + dzsno(4) = dzsno(3) + swice(4) = swice(3) + swliq(4) = swliq(3) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(4,:) = mss_aerosol(3,:) +!Aerosol Fluxes (January 07, 2023) + + tsno(4) = tsno(3) + + ENDIF + ENDIF + ENDIF + + IF(msno > 3)THEN + IF(dzsno(3) > 0.11)THEN + drr = dzsno(3) - 0.11 + propor = drr/dzsno(3) + zwice = propor*swice(3) + zwliq = propor*swliq(3) +!Aerosol Fluxes (January 07, 2023) + z_mss_aerosol(:) = propor*mss_aerosol(3,:) +!Aerosol Fluxes (January 07, 2023) + + propor = 0.11/dzsno(3) + swice(3) = propor*swice(3) + swliq(3) = propor*swliq(3) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(3,:) = propor*mss_aerosol(3,:) +!Aerosol Fluxes (January 07, 2023) + + dzsno(3) = 0.11 + + CALL combo(dzsno(4),swliq(4),swice(4),tsno(4), & + drr, zwliq, zwice, tsno(3)) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(4,:) = z_mss_aerosol(:) + mss_aerosol(4,:) +!Aerosol Fluxes (January 07, 2023) + +! write(6,*)'Subdivided 110 mm from the third Node & +! &and combined into underlying neighbor' + + IF(msno <= 4 .and. dzsno(4) > 0.41)THEN +! subdivided a new layer + msno = 5 + dzsno(4) = dzsno(4)/2. + swice(4) = swice(4)/2. + swliq(4) = swliq(4)/2. +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(4,:) = mss_aerosol(4,:)/2. +!Aerosol Fluxes (January 07, 2023) + + dzsno(5) = dzsno(4) + swice(5) = swice(4) + swliq(5) = swliq(4) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(5,:) = mss_aerosol(4,:) +!Aerosol Fluxes (January 07, 2023) + + tsno(5) = tsno(4) + + ENDIF + ENDIF + ENDIF + + IF(msno > 4)THEN + IF(dzsno(4) > 0.23)THEN + drr = dzsno(4) - 0.23 + propor = drr/dzsno(4) + zwice = propor*swice(4) + zwliq = propor*swliq(4) +!Aerosol Fluxes (January 07, 2023) + z_mss_aerosol(:) = propor*mss_aerosol(4,:) +!Aerosol Fluxes (January 07, 2023) + + propor = 0.23/dzsno(4) + swice(4) = propor*swice(4) + swliq(4) = propor*swliq(4) +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(4,:) = propor*mss_aerosol(4,:) +!Aerosol Fluxes (January 07, 2023) + + dzsno(4) = 0.23 + + CALL combo(dzsno(5),swliq(5),swice(5),tsno(5), & + drr, zwliq, zwice, tsno(4)) + +!Aerosol Fluxes (January 07, 2023) + mss_aerosol(5,:) = z_mss_aerosol(:) + mss_aerosol(5,:) +!Aerosol Fluxes (January 07, 2023) + +! write(6,*)'Subdivided 230 mm from the fourth Node & +! 'and combined into underlying neighbor' + ENDIF + ENDIF + + snl = - msno + + DO k = snl+1, 0 + dz_soisno(k) = dzsno(k - snl) + wice_soisno(k) = swice(k - snl) + wliq_soisno(k) = swliq(k - snl) + +!Aerosol Fluxes (January 07, 2023) + mss_bcphi(k) = mss_aerosol(k - snl, 1) + mss_bcpho(k) = mss_aerosol(k - snl, 2) + mss_ocphi(k) = mss_aerosol(k - snl, 3) + mss_ocpho(k) = mss_aerosol(k - snl, 4) + mss_dst1 (k) = mss_aerosol(k - snl, 5) + mss_dst2 (k) = mss_aerosol(k - snl, 6) + mss_dst3 (k) = mss_aerosol(k - snl, 7) + mss_dst4 (k) = mss_aerosol(k - snl, 8) +!Aerosol Fluxes (January 07, 2023) + + t_soisno(k) = tsno (k - snl) + + ENDDO + + zi_soisno(0) = 0. + DO k = 0, snl+1, -1 + z_soisno(k) = zi_soisno(k) - 0.5*dz_soisno(k) + zi_soisno(k-1) = zi_soisno(k) - dz_soisno(k) + ENDDO + + END SUBROUTINE SnowLayersDivide_snicar + +END MODULE MOD_SnowLayersCombineDivide +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 new file mode 100644 index 0000000000..ec1aa32286 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar.F90 @@ -0,0 +1,3000 @@ +#include + +MODULE MOD_SnowSnicar + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate albedo of snow containing impurities and the evolution of +! snow effective radius +! +! Original: +! 1) The Community Land Model version 5.0 (CLM5.0) +! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land +! Model (ELM v2.0) +! +! !REFERENCES: +! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling +! spectral snow albedo. Geosci. Model Dev., 14, 7673-7704, +! https://doi.org/10.5194/gmd-14-7673-2021 +! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land +! model (version 2.0) and assessing its impacts on snow and surface +! fluxes over the Tibetan Plateau. Geosci. Model Dev., 16, 75-94, +! https://doi.org/10.5194/gmd-16-75-2023 +! +! !REVISIONS: +! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Vars_Global, only: maxsnl + USE MOD_MPAS_MPI + + IMPLICIT NONE +! SAVE + real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 + real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice (kg/m^3) + + integer, parameter :: iulog = 6 ! "stdout" log file unit number, default is 6 + integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir + +!-------------------------------------------------------------------- +! DAI, Dec. 29, 2022 +! Temporary setting + + logical, parameter :: use_extrasnowlayers = .false. + character(len=256), parameter :: snow_shape = 'sphere' ! (=1), 'spheroid'(=2), 'hexagonal_plate'(=3), 'koch_snowflake'(=4) + logical, parameter :: use_dust_snow_internal_mixing = .false. + character(len=256), parameter :: snicar_atm_type = 'default' ! Atmospheric profile used to obtain surface-incident spectral flux distribution + ! and subsequent broadband albedo + ! = 'mid-latitude_winter' ! => 1 + ! = 'mid-latitude_summer' ! => 2 + ! = 'sub-Arctic_winter' ! => 3 + ! = 'sub-Arctic_summer' ! => 4 + ! = 'summit_Greenland' ! => 5 (sub-Arctic summer, surface pressure of 796hPa) + ! = 'high_mountain' ! => 6 (summer, surface pressure of 556 hPa) +!DAI, Dec. 29, 2022 +!----------------------------------------------------------------------- + + ! !PUBLIC MEMBER FUNCTIONS: + PUBLIC :: SNICAR_RT ! Snow albedo and vertically-resolved solar absorption + PUBLIC :: SNICAR_AD_RT ! Snow albedo and vertically-resolved solar absorption by adding-doubling solution + ! To USE this subroutine, set use_snicar_ad = true + PUBLIC :: SnowAge_grain ! Snow effective grain size evolution + PUBLIC :: SnowAge_init ! Initial read in of snow-aging file + PUBLIC :: SnowOptics_init ! Initial read in of snow-optics file + ! + ! !PUBLIC DATA MEMBERS: + integer, PUBLIC, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + ! (indices described above) [nbr] + logical, PUBLIC, parameter :: DO_SNO_OC = .false. ! parameter to include organic carbon (OC) + ! in snowpack radiative calculations + logical, PUBLIC, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations + ! !PRIVATE DATA MEMBERS: + integer, parameter :: numrad_snw = 5 ! number of spectral bands used in snow model [nbr] + integer, parameter :: nir_bnd_bgn = 2 ! first band index in near-IR spectrum [idx] + integer, parameter :: nir_bnd_end = 5 ! ending near-IR band index [idx] + integer, parameter :: idx_Mie_snw_mx = 1471 ! number of effective radius indices used in Mie lookup table [idx] + integer, parameter :: idx_T_max = 11 ! maximum temperature index used in aging lookup table [idx] + integer, parameter :: idx_T_min = 1 ! minimum temperature index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_max = 31 ! maximum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_min = 1 ! minimum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_rhos_max = 8 ! maximum snow density index used in aging lookup table [idx] + integer, parameter :: idx_rhos_min = 1 ! minimum snow density index used in aging lookup table [idx] + +#ifdef MODAL_AER + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + !mgf++ + integer, parameter :: idx_bc_nclrds_min = 1 ! minimum index for BC particle size in optics lookup table + integer, parameter :: idx_bc_nclrds_max = 10 ! maximum index for BC particle size in optics lookup table + integer, parameter :: idx_bcint_icerds_min = 1 ! minimum index for snow grain size in optics lookup table for within-ice BC + integer, parameter :: idx_bcint_icerds_max = 8 ! maximum index for snow grain size in optics lookup table for within-ice BC + !mgf-- +#endif + + integer, parameter :: snw_rds_max_tbl = 1500 ! maximum effective radius defined in Mie lookup table [microns] + integer, parameter :: snw_rds_min_tbl = 30 ! minimum effective radius defined in Mie lookup table [microns] + real(r8), parameter :: snw_rds_max = 1500._r8 ! maximum allowed snow effective radius [microns] + real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also "fresh snow" value) [microns + real(r8), parameter :: snw_rds_refrz = 1000._r8 ! effective radius of re-frozen snow [microns] + real(r8), parameter :: min_snw = 1.0E-30_r8 ! minimum snow mass required for SNICAR RT calculation [kg m-2] + !real(r8), parameter :: C1_liq_Brun89 = 1.28E-17_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89 + real(r8), parameter :: C1_liq_Brun89 = 0._r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: zeroed to accomodate dry snow aging + real(r8), parameter :: C2_liq_Brun89 = 4.22E-13_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: corrected for LWC in units of percent + + real(r8), parameter :: tim_cns_bc_rmv = 2.2E-8_r8 ! time constant for removal of BC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_oc_rmv = 2.2E-8_r8 ! time constant for removal of OC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_dst_rmv = 2.2E-8_r8 ! time constant for removal of dust in snow on sea-ice + ! [s-1] (50% mass removal/year) + !$acc declare copyin(C1_liq_Brun89, C2_liq_Brun89, & + !$acc tim_cns_bc_rmv, tim_cns_oc_rmv, tim_cns_dst_rmv) + + ! scaling of the snow aging rate (tuning option): + logical :: flg_snoage_scl = .false. ! flag for scaling the snow aging rate by some arbitrary factor + real(r8), parameter :: xdrdt = 1.0_r8 ! arbitrary factor applied to snow aging rate + ! snow and aerosol Mie parameters: + ! (arrays declared here, but are set in iniTimeConst) + ! (idx_Mie_snw_mx is number of snow radii with defined parameters (i.e. from 30um to 1500um)) + + ! direct-beam weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_drc(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! diffuse radiation weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_dfs(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! direct & diffuse flux + real(r8), allocatable :: flx_wgt_dir (:,:,:) ! (6, 90, numrad_snw) ! direct flux, six atmospheric types, 0-89 SZA + real(r8), allocatable :: flx_wgt_dif (:,:) ! (6, numrad_snw) ! diffuse flux, six atmospheric types + + ! snow grain shape + integer, parameter :: snow_shape_sphere = 1 + integer, parameter :: snow_shape_spheroid = 2 + integer, parameter :: snow_shape_hexagonal_plate = 3 + integer, parameter :: snow_shape_koch_snowflake = 4 + + ! atmospheric condition for SNICAR-AD + integer, parameter :: atm_type_default = 0 + integer, parameter :: atm_type_mid_latitude_winter = 1 + integer, parameter :: atm_type_mid_latitude_summer = 2 + integer, parameter :: atm_type_sub_Arctic_winter = 3 + integer, parameter :: atm_type_sub_Arctic_summer = 4 + integer, parameter :: atm_type_summit_Greenland = 5 + integer, parameter :: atm_type_high_mountain = 6 + +#ifdef MODAL_AER + !mgf++ + ! Size-dependent BC optical properties. Currently a fixed BC size is + ! assumed, but this framework enables optical properties to be + ! assigned based on the BC effective radius, should this be + ! implemented in the future. + ! + ! within-ice BC (i.e., BC that was deposited within hydrometeors) + real(r8), allocatable :: ss_alb_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc1(:,:) ! (numrad_snw,idx_bc_nclrds_max); + + ! external BC + real(r8), allocatable :: ss_alb_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc2(:,:) ! (numrad_snw,idx_bc_nclrds_max); + !mgf-- +#else + ! hydrophiliic BC + real(r8), allocatable :: ss_alb_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc1(:) ! (numrad_snw); + + ! hydrophobic BC + real(r8), allocatable :: ss_alb_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc2(:) ! (numrad_snw); +#endif + + ! hydrophobic OC + real(r8), allocatable :: ss_alb_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc1(:) ! (numrad_snw); + + ! hydrophilic OC + real(r8), allocatable :: ss_alb_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc2(:) ! (numrad_snw); + + ! dust species 1: + real(r8), allocatable :: ss_alb_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst1(:) ! (numrad_snw); + + ! dust species 2: + real(r8), allocatable :: ss_alb_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst2(:) ! (numrad_snw); + + ! dust species 3: + real(r8), allocatable :: ss_alb_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst3(:) ! (numrad_snw); + + ! dust species 4: + real(r8), allocatable :: ss_alb_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst4(:) ! (numrad_snw); + +#ifdef MODAL_AER + ! Absorption enhancement factors for within-ice BC + real(r8), allocatable :: bcenh (:,:,:) ! (numrad_snw,idx_bc_nclrds_max,idx_bcint_icerds_max); +#endif + + ! best-fit parameters for snow aging defined over: + ! 11 temperatures from 225 to 273 K + ! 31 temperature gradients from 0 to 300 K/m + ! 8 snow densities from 0 to 350 kg/m3 + ! (arrays declared here, but are set in iniTimeConst) + ! + real(r8), allocatable :: snowage_tau (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [hour] + real(r8), allocatable :: snowage_kappa (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [unitless] + real(r8), allocatable :: snowage_drdt0 (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [um hr-1] + + ! + ! !REVISION HISTORY: + ! Created by Mark Flanner + !----------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & + coszen, snl, h2osno, frac_sno, & + h2osno_liq, h2osno_ice, snw_rds, & + mss_cnc_aer_in, albsfc, albout, flx_abs) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Determine reflectance of, and vertically-resolved solar absorption in, +! snow with impurities. +! +! Original references on physical models of snow reflectance include: +! Wiscombe and Warren [1980] and Warren and Wiscombe [1980], +! Journal of Atmospheric Sciences, 37, +! +! The multi-layer solution for multiple-scattering used here is from: +! Toon et al. [1989], Rapid calculation of radiative heating rates +! and photodissociation rates in inhomogeneous multiple scattering atmospheres, +! J. Geophys. Res., 94, D13, 16287-16301 +! +! The implementation of the SNICAR model in CLM/CSIM is described in: +! Flanner, M., C. Zender, J. Randerson, and P. Rasch [2007], +! Present-day climate forcing and response from black carbon in snow, +! J. Geophys. Res., 112, D11202, doi: 10.1029/2006JD008003 +! +! !USES: +! +!----------------------------------------------------------------------- +! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + +#ifdef MODAL_AER + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- +#endif + + + ! Other local variables + integer :: APRX_TYP ! two-stream approximation type + ! (1=Eddington, 2=Quadrature, 3=Hemispheric Mean) [nbr] + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: n ! tridiagonal matrix index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_direct(maxsnl+1:0) ! direct-beam radiation at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_net(maxsnl+1:0) ! net radiative flux at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: F_sfc_net ! net flux at top of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: F_direct_btm ! direct-beam radiation at bottom of snowpack [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + ! intermediate variables for radiative transfer approximation: + real(r8):: gamma1(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma2(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma3(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma4(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: lambda(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: GAMMA(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: mu_one ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: e1(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e2(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e3(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e4(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: C_pls_btm(maxsnl+1:0) ! intermediate variable: upward flux at bottom interface (lyr) [W/m2] + real(r8):: C_mns_btm(maxsnl+1:0) ! intermediate variable: downward flux at bottom interface (lyr) [W/m2] + real(r8):: C_pls_top(maxsnl+1:0) ! intermediate variable: upward flux at top interface (lyr) [W/m2] + real(r8):: C_mns_top(maxsnl+1:0) ! intermediate variable: downward flux at top interface (lyr) [W/m2] + real(r8):: A(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: B(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: D(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: E(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: AS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: DS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: X(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: Y(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + !----------------------------------------------------------------------- +#ifdef MODAL_AER + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- +#endif + + ! Enforce expected array sizes + + ! associate(& + ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:)] snow liquid water equivalent (col) [kg/m2] + ! frac_sno => col_ws%frac_sno_eff & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) + ! ) + + ! Define constants + pi = SHR_CONST_PI + nint_snw_rds_min = nint(snw_rds_min) + + ! always USE Delta approximation for snow + DELTA = 1 + + ! (when called from CSIM, there is only one column) + + ! Zero absorbed radiative fluxes: + DO i=maxsnl+1,1,1 + flx_abs_lcl(:,:) = 0._r8 + flx_abs(i,:) = 0._r8 + ENDDO + + ! set snow/ice mass to be used for RT: + IF (flg_snw_ice == 1) THEN + h2osno_lcl = h2osno + ELSE + h2osno_lcl = h2osno_ice(0) + ENDIF + + ! Qualifier for computing snow RT: + ! 1) sunlight from atmosphere model + ! 2) minimum amount of snow on ground. + ! Otherwise, set snow albedo to zero + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw)) THEN + + ! Set variables specific to CLM + IF (flg_snw_ice == 1) THEN + ! If there is snow, but zero snow layers, we must create a layer locally. + ! This layer is presumed to have the fresh snow effective radius. + IF (snl > -1) THEN + flg_nosnl = 1 + snl_lcl = -1 + h2osno_ice_lcl(0) = h2osno_lcl + h2osno_liq_lcl(0) = 0._r8 + snw_rds_lcl(0) = nint_snw_rds_min + ELSE + flg_nosnl = 0 + snl_lcl = snl + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + ENDIF + + snl_btm = 0 + snl_top = snl_lcl+1 + + ! Set variables specific to CSIM + ELSE + flg_nosnl = 0 + snl_lcl = -1 + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + snl_btm = 0 + snl_top = 0 + ENDIF + +#ifdef MODAL_AER + !mgf++ + ! + ! Assume fixed BC effective radii of 100nm. This is close to + ! the effective radius of 95nm (number median radius of + ! 40nm) assumed for freshly-emitted BC in MAM. Future + ! implementations may prognose the BC effective radius in + ! snow. + rds_bcint_lcl(:) = 100._r8 + rds_bcext_lcl(:) = 100._r8 + !mgf-- +#endif + + ! Set local aerosol array + DO j=1,sno_nbr_aer + mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) + ENDDO + + + ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos + albsfc_lcl(1) = albsfc(1) + albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) + + + ! Error check for snow grain size: +#ifndef _OPENACC + IF (mpas_is_root) THEN + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN + write (iulog,*) "SNICAR ERROR: snow grain radius of out of bounds." + write (iulog,*) "flg_snw_ice= ", flg_snw_ice + write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl + write (iulog,*) "h2osno(c)= ", h2osno_lcl + CALL CoLM_stop() + ENDIF + ENDDO + ENDIF +#endif + + ! Incident flux weighting parameters + ! - sum of all VIS bands must equal 1 + ! - sum of all NIR bands must equal 1 + ! + ! Spectral bands (5-band CASE) + ! Band 1: 0.3-0.7um (VIS) + ! Band 2: 0.7-1.0um (NIR) + ! Band 3: 1.0-1.2um (NIR) + ! Band 4: 1.2-1.5um (NIR) + ! Band 5: 1.5-5.0um (NIR) + ! + ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere + ! + ! 3-band weights + IF (numrad_snw==3) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.66628670195247_r8 + flx_wgt(3) = 0.33371329804753_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.77887652162877_r8 + flx_wgt(3) = 0.22112347837123_r8 + ENDIF + + ! 5-band weights + ELSEIF(numrad_snw==5) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.49352158521175_r8 + flx_wgt(3) = 0.18099494230665_r8 + flx_wgt(4) = 0.12094898498813_r8 + flx_wgt(5) = 0.20453448749347_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.58581507618433_r8 + flx_wgt(3) = 0.20156903770812_r8 + flx_wgt(4) = 0.10917889346386_r8 + flx_wgt(5) = 0.10343699264369_r8 + ENDIF + ENDIF + + ! Loop over snow spectral bands + DO bnd_idx = 1,numrad_snw + + mu_not = coszen ! must set here, because of error handling + flg_dover = 1 ! default is to redo + err_idx = 0 ! number of times through loop + + DO WHILE (flg_dover > 0) + + ! DEFAULT APPROXIMATIONS: + ! VIS: Delta-Eddington + ! NIR (all): Delta-Hemispheric Mean + ! WARNING: DO NOT USE DELTA-EDDINGTON FOR NIR DIFFUSE - this sometimes results in negative albedo + ! + ! ERROR CONDITIONS: + ! Conditions which cause "trip", resulting in redo of RT approximation: + ! 1. negative absorbed flux + ! 2. total absorbed flux greater than incident flux + ! 3. negative albedo + ! NOTE: These errors have only been encountered in spectral bands 4 and 5 + ! + ! ERROR HANDLING + ! 1st error (flg_dover=2): switch approximation (Edd->HM or HM->Edd) + ! 2nd error (flg_dover=3): change zenith angle by 0.02 (this happens about 1 in 10^6 cases) + ! 3rd error (flg_dover=4): switch approximation with new zenith + ! Subsequent errors: repeatedly change zenith and approximations... + + IF (bnd_idx == 1) THEN + IF (flg_dover == 2) THEN + APRX_TYP = 3 + ELSEIF (flg_dover == 3) THEN + APRX_TYP = 1 + IF (coszen > 0.5_r8) THEN + mu_not = mu_not - 0.02_r8 + ELSE + mu_not = mu_not + 0.02_r8 + ENDIF + ELSEIF (flg_dover == 4) THEN + APRX_TYP = 3 + ELSE + APRX_TYP = 1 + ENDIF + + ELSE + IF (flg_dover == 2) THEN + APRX_TYP = 1 + ELSEIF (flg_dover == 3) THEN + APRX_TYP = 3 + IF (coszen > 0.5_r8) THEN + mu_not = mu_not - 0.02_r8 + ELSE + mu_not = mu_not + 0.02_r8 + ENDIF + ELSEIF (flg_dover == 4) THEN + APRX_TYP = 1 + ELSE + APRX_TYP = 3 + ENDIF + + ENDIF + + ! Set direct or diffuse incident irradiance to 1 + ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) + IF (flg_slr_in == 1) THEN + flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 + flx_slri_lcl(bnd_idx) = 0._r8 + ELSE + flx_slrd_lcl(bnd_idx) = 0._r8 + flx_slri_lcl(bnd_idx) = 1._r8 + ENDIF + + ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. + ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + ! Define local Mie parameters based on snow grain size and aerosol species, + ! retrieved from a lookup table. + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (direct radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) + ENDDO + ELSEIF (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (diffuse radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) + ENDDO + ENDIF + +!H. Wang + ! aerosol species 1 optical properties + ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +!H. Wang + ! aerosol species 3 optical properties + ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) + asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) + ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) + + ! aerosol species 4 optical properties + ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) + asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) + ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) + + ! aerosol species 5 optical properties + ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) + asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) + ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) + + ! aerosol species 6 optical properties + ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) + asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) + ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) + + ! aerosol species 7 optical properties + ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) + asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) + ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) + + ! aerosol species 8 optical properties + ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) + asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) + ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) + + + ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) + ! 2. optical Depths (tau_snw, tau_aer) + ! 3. weighted Mie properties (tau, omega, g) + + ! Weighted Mie parameters of each layer + DO i=snl_top,snl_btm,1 +#ifdef MODAL_AER + !mgf++ within-ice and external BC optical properties + ! + ! Lookup table indices for BC optical properties, + ! dependent on snow grain size and BC particle + ! size. + + ! valid for 25 < snw_rds < 1625 um: + IF (snw_rds_lcl(i) < 125) THEN + tmp1 = snw_rds_lcl(i)/50 + idx_bcint_icerds = nint(tmp1) + ELSEIF (snw_rds_lcl(i) < 175) THEN + idx_bcint_icerds = 2 + ELSE + tmp1 = (snw_rds_lcl(i)/250)+2 + idx_bcint_icerds = nint(tmp1) + ENDIF + + ! valid for 25 < bc_rds < 525 nm + idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) + idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) + + ! check bounds: + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + + ! retrieve absorption enhancement factor for within-ice BC + enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) + + ! get BC optical properties (moved from above) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct + + ! aerosol species 2 optical properties (external BC) + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) + +#else + ! bulk aerosol treatment (BC optical properties independent + ! of BC and ice grain size) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +#endif + !mgf-- + + L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) + tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) + + DO j=1,sno_nbr_aer + L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) + tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) + ENDDO + + tau_sum = 0._r8 + omega_sum = 0._r8 + g_sum = 0._r8 + + DO j=1,sno_nbr_aer + tau_sum = tau_sum + tau_aer(i,j) + omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) + g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) + ENDDO + + tau(i) = tau_sum + tau_snw(i) + omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) + g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) + ENDDO + + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 + g_star(i) = g(i)/(1+g(i)) + omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) + tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) + ENDDO + ELSE + DO i=snl_top,snl_btm,1 + g_star(i) = g(i) + omega_star(i) = omega(i) + tau_star(i) = tau(i) + ENDDO + ENDIF + + ! Total column optical depth: + ! tau_elm(i) = total optical depth above the bottom of layer i + tau_elm(snl_top) = 0._r8 + DO i=snl_top+1,snl_btm,1 + tau_elm(i) = tau_elm(i-1)+tau_star(i-1) + ENDDO + + ! Direct radiation at bottom of snowpack: + F_direct_btm = albsfc_lcl(bnd_idx)*mu_not * & + exp(-(tau_elm(snl_btm)+tau_star(snl_btm))/mu_not)*pi*flx_slrd_lcl(bnd_idx) + + ! Intermediates + ! Gamma values are approximation-specific. + + ! Eddington + IF (APRX_TYP==1) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = (7-(omega_star(i)*(4+(3*g_star(i)))))/4 + gamma2(i) = -(1-(omega_star(i)*(4-(3*g_star(i)))))/4 + gamma3(i) = (2-(3*g_star(i)*mu_not))/4 + gamma4(i) = 1-gamma3(i) + mu_one = 0.5 + ENDDO + + ! Quadrature + ELSEIF (APRX_TYP==2) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = (3**0.5)*(2-(omega_star(i)*(1+g_star(i))))/2 + gamma2(i) = omega_star(i)*(3**0.5)*(1-g_star(i))/2 + gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 + gamma4(i) = 1-gamma3(i) + mu_one = 1/(3**0.5) + ENDDO + + ! Hemispheric Mean + ELSEIF (APRX_TYP==3) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = 2 - (omega_star(i)*(1+g_star(i))) + gamma2(i) = omega_star(i)*(1-g_star(i)) + gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 + gamma4(i) = 1-gamma3(i) + mu_one = 0.5 + ENDDO + ENDIF + + ! Intermediates for tri-diagonal solution + DO i=snl_top,snl_btm,1 + lambda(i) = sqrt(abs((gamma1(i)**2) - (gamma2(i)**2))) + GAMMA(i) = gamma2(i)/(gamma1(i)+lambda(i)) + + e1(i) = 1+(GAMMA(i)*exp(-lambda(i)*tau_star(i))) + e2(i) = 1-(GAMMA(i)*exp(-lambda(i)*tau_star(i))) + e3(i) = GAMMA(i) + exp(-lambda(i)*tau_star(i)) + e4(i) = GAMMA(i) - exp(-lambda(i)*tau_star(i)) + ENDDO !ENDDO over snow layers + + ! Intermediates for tri-diagonal solution + DO i=snl_top,snl_btm,1 + IF (flg_slr_in == 1) THEN + + C_pls_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-(tau_elm(i)+tau_star(i))/mu_not)* & + (((gamma1(i)-(1/mu_not))*gamma3(i))+ & + (gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_mns_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-(tau_elm(i)+tau_star(i))/mu_not)* & + (((gamma1(i)+(1/mu_not))*gamma4(i))+ & + (gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_pls_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-tau_elm(i)/mu_not)*(((gamma1(i)-(1/mu_not))* & + gamma3(i))+(gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_mns_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-tau_elm(i)/mu_not)*(((gamma1(i)+(1/mu_not))* & + gamma4(i))+(gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + ELSE + C_pls_btm(i) = 0._r8 + C_mns_btm(i) = 0._r8 + C_pls_top(i) = 0._r8 + C_mns_top(i) = 0._r8 + ENDIF + ENDDO + + ! Coefficients for tridiaganol matrix solution + DO i=2*snl_lcl+1,0,1 + + !Boundary values for i=1 and i=2*snl_lcl, specifics for i=odd and i=even + IF (i==(2*snl_lcl+1)) THEN + A(i) = 0 + B(i) = e1(snl_top) + D(i) = -e2(snl_top) + E(i) = flx_slri_lcl(bnd_idx)-C_mns_top(snl_top) + + ELSEIF(i==0) THEN + A(i) = e1(snl_btm)-(albsfc_lcl(bnd_idx)*e3(snl_btm)) + B(i) = e2(snl_btm)-(albsfc_lcl(bnd_idx)*e4(snl_btm)) + D(i) = 0 + E(i) = F_direct_btm-C_pls_btm(snl_btm)+(albsfc_lcl(bnd_idx)*C_mns_btm(snl_btm)) + + ELSEIF(mod(i,2)==-1) THEN ! If odd and i>=3 (n=1 for i=3) + n=floor(i/2.0) + A(i) = (e2(n)*e3(n))-(e4(n)*e1(n)) + B(i) = (e1(n)*e1(n+1))-(e3(n)*e3(n+1)) + D(i) = (e3(n)*e4(n+1))-(e1(n)*e2(n+1)) + E(i) = (e3(n)*(C_pls_top(n+1)-C_pls_btm(n)))+(e1(n)*(C_mns_btm(n)-C_mns_top(n+1))) + + ELSEIF(mod(i,2)==0) THEN ! If even and i<=2*snl_lcl + n=(i/2) + A(i) = (e2(n+1)*e1(n))-(e3(n)*e4(n+1)) + B(i) = (e2(n)*e2(n+1))-(e4(n)*e4(n+1)) + D(i) = (e1(n+1)*e4(n+1))-(e2(n+1)*e3(n+1)) + E(i) = (e2(n+1)*(C_pls_top(n+1)-C_pls_btm(n)))+(e4(n+1)*(C_mns_top(n+1)-C_mns_btm(n))) + ENDIF + ENDDO + + AS(0) = A(0)/B(0) + DS(0) = E(0)/B(0) + + DO i=-1,(2*snl_lcl+1),-1 + X(i) = 1/(B(i)-(D(i)*AS(i+1))) + AS(i) = A(i)*X(i) + DS(i) = (E(i)-(D(i)*DS(i+1)))*X(i) + ENDDO + + Y(2*snl_lcl+1) = DS(2*snl_lcl+1) + DO i=(2*snl_lcl+2),0,1 + Y(i) = DS(i)-(AS(i)*Y(i-1)) + ENDDO + + ! Downward direct-beam and net flux (F_net) at the base of each layer: + DO i=snl_top,snl_btm,1 + F_direct(i) = mu_not*pi*flx_slrd_lcl(bnd_idx)*exp(-(tau_elm(i)+tau_star(i))/mu_not) + F_net(i) = (Y(2*i-1)*(e1(i)-e3(i))) + (Y(2*i)*(e2(i)-e4(i))) + & + C_pls_btm(i) - C_mns_btm(i) - F_direct(i) + ENDDO + + ! Upward flux at snowpack top: + F_sfc_pls = (Y(2*snl_lcl+1)*(exp(-lambda(snl_top)*tau_star(snl_top))+ & + GAMMA(snl_top))) + (Y(2*snl_lcl+2)*(exp(-lambda(snl_top)* & + tau_star(snl_top))-GAMMA(snl_top))) + C_pls_top(snl_top) + + ! Net flux at bottom = absorbed radiation by underlying surface: + F_btm_net = -F_net(snl_btm) + + + ! Bulk column albedo and surface net flux + albedo = F_sfc_pls/((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx)) + F_sfc_net = F_sfc_pls - ((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx)) + + trip = 0 + ! Absorbed flux in each layer + DO i=snl_top,snl_btm,1 + IF(i==snl_top) THEN + F_abs(i) = F_net(i)-F_sfc_net + ELSE + F_abs(i) = F_net(i)-F_net(i-1) + ENDIF + flx_abs_lcl(i,bnd_idx) = F_abs(i) + + + ! ERROR check: negative absorption + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN + trip = 1 + ENDIF + ENDDO + + flx_abs_lcl(1,bnd_idx) = F_btm_net + + IF (flg_nosnl == 1) THEN + ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer + !flx_abs_lcl(:,bnd_idx) = 0._r8 + !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net + + ! changed on 20070408: + ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and + ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. + flx_abs_lcl(0,bnd_idx) = F_abs(0) + flx_abs_lcl(1,bnd_idx) = F_btm_net + + ENDIF + + !Underflow check (we've already tripped the error condition above) + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN + flx_abs_lcl(i,bnd_idx) = 0._r8 + ENDIF + ENDDO + + F_abs_sum = 0._r8 + DO i=snl_top,snl_btm,1 + F_abs_sum = F_abs_sum + F_abs(i) + ENDDO + + + !ERROR check: absorption greater than incident flux + ! (should make condition more generic than "1._r8") + IF (F_abs_sum > 1._r8) THEN + trip = 1 + ENDIF + + !ERROR check: + IF ((albedo < 0._r8).and.(trip==0)) THEN + trip = 1 + ENDIF + + ! Set conditions for redoing RT calculation + IF ((trip == 1).and.(flg_dover == 1)) THEN + flg_dover = 2 + ELSEIF ((trip == 1).and.(flg_dover == 2)) THEN + flg_dover = 3 + ELSEIF ((trip == 1).and.(flg_dover == 3)) THEN + flg_dover = 4 + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx < 20)) THEN + flg_dover = 3 + err_idx = err_idx + 1 + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN + flg_dover = 0 +#ifndef _OPENACC + IF (mpas_is_root) THEN + write(iulog,*) "SNICAR ERROR: FOUND A WORMHOLE. STUCK IN INFINITE LOOP! Called from: ", flg_snw_ice + write(iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + write(iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + write(iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write(iulog,*) "SNICAR STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) + write(iulog,*) "SNICAR STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) + write(iulog,*) "SNICAR STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) + write(iulog,*) "SNICAR STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) + write(iulog,*) "SNICAR STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) + write(iulog,*) "SNICAR STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) + write(iulog,*) "frac_sno: ", frac_sno + CALL CoLM_stop() + ENDIF +#endif + ELSE + flg_dover = 0 + ENDIF + + ENDDO !ENDDO WHILE (flg_dover > 0) + + ! Energy conservation check: + ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) + energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) + IF (abs(energy_sum) > 0.00001_r8) THEN +#ifndef _OPENACC + IF (mpas_is_root) THEN + write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum + CALL CoLM_stop() + ENDIF +#endif + ENDIF + + albout_lcl(bnd_idx) = albedo + + ! Check that albedo is less than 1 + IF (albout_lcl(bnd_idx) > 1.0) THEN +#ifndef _OPENACC + IF (mpas_is_root) THEN + write(iulog,*) "SNICAR ERROR: Albedo > 1.0: " + write(iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx + write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & + " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) + write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in + + write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) + write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) + write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) + write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) + write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) + + write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) + write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) + write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) + write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) + write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + + write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) + write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) + write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) + write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) + write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + + CALL CoLM_stop() + ENDIF +#endif + ENDIF + + ENDDO ! loop over wvl bands + + + ! Weight output NIR albedo appropriately + albout(1) = albout_lcl(1) + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) + ENDDO + albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + + ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately + flx_abs(:,1) = flx_abs_lcl(:,1) + DO i=snl_top,1,1 + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) + ENDDO + flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + ENDDO + + ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + albout(1) = albsfc(1) + albout(2) = albsfc(2) + + ! There is either zero snow, or no sun + ELSE + albout(1) = 0._r8 + albout(2) = 0._r8 + ENDIF ! IF column has snow and coszen > 0 + + ! END associate + + END SUBROUTINE SNICAR_RT + !----------------------------------------------------------------------- + + + SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & + coszen, snl, h2osno, frac_sno, & + h2osno_liq, h2osno_ice, snw_rds, & + mss_cnc_aer_in, albsfc, albout, flx_abs) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Determine reflectance of, and vertically-resolved solar absorption in, +! snow with impurities, with updated shortwave scheme +! +! The multi-layer solution for multiple-scattering used here is from: +! Briegleb, P. and Light, B.: A Delta-Eddington mutiple scattering +! parameterization for solar radiation in the sea ice component of the +! community climate system model, 2007. +! +! The implementation of the SNICAR-AD model in ELM is described in: +! Dang et al., Inter-comparison and improvement of 2-stream shortwave +! radiative transfer models for unified treatment of cryospheric surfaces +! in ESMs, in review, 2019 +! +! To USE this subtroutine, set use_snicar_ad = true in ELM +! +! IF config_use_snicar_ad = true in MPAS-seaice +! Snow on land and snow on sea ice will be treated +! with the same model for their solar radiative properties. +! +! The inputs and outputs are the same to SUBROUTINE SNICAR_RT +! +! !USES: +!----------------------------------------------------------------------- +! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + +#ifdef MODAL_AER + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- +#endif + + + ! Other local variables + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + ! integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + ! integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + ! integer :: c_idx ! column indices [idx] + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + integer :: snw_shp_lcl(maxsnl+1:0) ! Snow grain shape option: + ! 1=sphere; 2=spheroid; 3=hexagonal plate; 4=koch snowflake + real(r8):: snw_fs_lcl(maxsnl+1:0) ! Shape factor: ratio of nonspherical grain effective radii to that of equal-volume sphere + ! 0=USE recommended default value + ! others(0 1 (i.e. nonspherical) + real(r8):: snw_ar_lcl(maxsnl+1:0) ! % Aspect ratio: ratio of grain width to length + ! 0=USE recommended default value + ! others(0.1 1 (i.e. nonspherical) + real(r8):: & + diam_ice , & ! effective snow grain diameter + fs_sphd , & ! shape factor for spheroid + fs_hex0 , & ! shape factor for hexagonal plate + fs_hex , & ! shape factor for hexagonal plate (reference) + fs_koch , & ! shape factor for koch snowflake + AR_tmp , & ! aspect ratio for spheroid + g_ice_Cg_tmp(7) , & ! temporary for calculation of asymetry factor + gg_ice_F07_tmp(7) , & ! temporary for calculation of asymetry factor + g_ice_F07 , & ! temporary for calculation of asymetry factor + g_ice , & ! asymmetry factor + gg_F07_intp , & ! temporary for calculation of asymetry factor (interpolated) + g_Cg_intp , & ! temporary for calculation of asymetry factor (interpolated) + R_1_omega_tmp , & ! temporary for dust-snow mixing calculation + C_dust_total ! dust concentration + + integer :: atm_type_index ! index for atmospheric type + integer :: slr_zen ! integer value of solar zenith angle + + ! SNICAR_AD new variables, follow sea-ice shortwave conventions + real(r8):: & + trndir(maxsnl+1:1) , & ! solar beam down transmission from top + trntdr(maxsnl+1:1) , & ! total transmission to direct beam for layers above + trndif(maxsnl+1:1) , & ! diffuse transmission to diffuse beam for layers above + rupdir(maxsnl+1:1) , & ! reflectivity to direct radiation for layers below + rupdif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers below + rdndif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers above + dfdir(maxsnl+1:1) , & ! down-up flux at interface due to direct beam at top surface + dfdif(maxsnl+1:1) , & ! down-up flux at interface due to diffuse beam at top surface + dftmp(maxsnl+1:1) ! temporary variable for down-up flux at interface + + real(r8):: & + rdir(maxsnl+1:0) , & ! layer reflectivity to direct radiation + rdif_a(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from above + rdif_b(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from below + tdir(maxsnl+1:0) , & ! layer transmission to direct radiation (solar beam + diffuse) + tdif_a(maxsnl+1:0) , & ! layer transmission to diffuse radiation from above + tdif_b(maxsnl+1:0) , & ! layer transmission to diffuse radiation from below + trnlay(maxsnl+1:0) ! solar beam transm for layer (direct beam only) + + real(r8):: & + ts , & ! layer delta-scaled extinction optical depth + ws , & ! layer delta-scaled single scattering albedo + gs , & ! layer delta-scaled asymmetry parameter + extins , & ! extinction + alp , & ! temporary for alpha + gam , & ! temporary for agamm + amg , & ! alp - gam + apg , & ! alp + gam + ue , & ! temporary for u + refk , & ! interface multiple scattering + refkp1 , & ! interface multiple scattering for k+1 + refkm1 , & ! interface multiple scattering for k-1 + tdrrdir , & ! direct tran times layer direct ref + tdndif ! total down diffuse = tot tran - direct tran + + real(r8) :: & + alpha , & ! term in direct reflectivity and transmissivity + agamm , & ! term in direct reflectivity and transmissivity + el , & ! term in alpha,agamm,n,u + taus , & ! scaled extinction optical depth + omgs , & ! scaled single particle scattering albedo + asys , & ! scaled asymmetry parameter + u , & ! term in diffuse reflectivity and transmissivity + n , & ! term in diffuse reflectivity and transmissivity + lm , & ! temporary for el + mu , & ! cosine solar zenith for either snow or water + ne ! temporary for n + + ! perpendicular and parallel relative to plane of incidence and scattering + real(r8) :: & + R1 , & ! perpendicular polarization reflection amplitude + R2 , & ! parallel polarization reflection amplitude + T1 , & ! perpendicular polarization transmission amplitude + T2 , & ! parallel polarization transmission amplitude + Rf_dir_a , & ! fresnel reflection to direct radiation + Tf_dir_a , & ! fresnel transmission to direct radiation + Rf_dif_a , & ! fresnel reflection to diff radiation from above + Rf_dif_b , & ! fresnel reflection to diff radiation from below + Tf_dif_a , & ! fresnel transmission to diff radiation from above + Tf_dif_b ! fresnel transmission to diff radiation from below + + real(r8) :: & + gwt , & ! gaussian weight + swt , & ! sum of weights + trn , & ! layer transmission + rdr , & ! rdir for gaussian integration + tdr , & ! tdir for gaussian integration + smr , & ! accumulator for rdif gaussian integration + smt , & ! accumulator for tdif gaussian integration + exp_min ! minimum exponential value + + integer :: & + ng , & ! gaussian integration index + snl_btm_itf , & ! index of bottom snow layer interfaces (1) [idx] + ngmax = 8 ! gaussian integration index + + ! Gaussian integration angle and coefficients + real(r8) :: difgauspt(1:8) , difgauswt(1:8) + + ! constants used in algorithm + real(r8) :: & + c0 = 0.0_r8 , & + c1 = 1.0_r8 , & + c3 = 3.0_r8 , & + c4 = 4.0_r8 , & + c6 = 6.0_r8 , & + cp01 = 0.01_r8 , & + cp5 = 0.5_r8 , & + cp75 = 0.75_r8 , & + c1p5 = 1.5_r8 , & + trmin = 0.001_r8 , & + argmax = 10.0_r8 ! maximum argument of exponential + + ! cconstant coefficients used for SZA parameterization + real(r8) :: & + sza_a0 = 0.085730_r8 , & + sza_a1 = -0.630883_r8 , & + sza_a2 = 1.303723_r8 , & + sza_b0 = 1.467291_r8 , & + sza_b1 = -3.338043_r8 , & + sza_b2 = 6.807489_r8 , & + puny = 1.0e-11_r8 , & + mu_75 = 0.2588_r8 ! cosine of 75 degree + + ! coefficients used for SZA parameterization + real(r8) :: & + sza_c1 , & ! coefficient, SZA parameteirzation + sza_c0 , & ! coefficient, SZA parameterization + sza_factor , & ! factor used to adjust NIR direct albedo + flx_sza_adjust , & ! direct NIR flux adjustment from sza_factor + mu0 ! incident solar zenith angle + + !----------------------------------------------------------------------- +#ifdef MODAL_AER + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- +#endif + + ! Constants for non-spherical ice particles and dust-snow internal mixing + real(r8) :: g_b2(7) + real(r8) :: g_b1(7) + real(r8) :: g_b0(7) + real(r8) :: g_F07_c2(7) + real(r8) :: g_F07_c1(7) + real(r8) :: g_F07_c0(7) + real(r8) :: g_F07_p2(7) + real(r8) :: g_F07_p1(7) + real(r8) :: g_F07_p0(7) + real(r8) :: dust_clear_d0(3) + real(r8) :: dust_clear_d1(3) + real(r8) :: dust_clear_d2(3) + real(r8) :: dust_cloudy_d0(3) + real(r8) :: dust_cloudy_d1(3) + real(r8) :: dust_cloudy_d2(3) + + !!! factors for considering snow grain shape + data g_b0(:) / 9.76029E-01_r8, 9.67798E-01_r8, 1.00111E+00_r8, 1.00224E+00_r8,& + 9.64295E-01_r8, 9.97475E-01_r8, 9.97475E-01_r8/ + data g_b1(:) / 5.21042E-01_r8, 4.96181E-01_r8, 1.83711E-01_r8, 1.37082E-01_r8,& + 5.50598E-02_r8, 8.48743E-02_r8, 8.48743E-02_r8/ + data g_b2(:) /-2.66792E-04_r8, 1.14088E-03_r8, 2.37011E-04_r8,-2.35905E-04_r8,& + 8.40449E-04_r8,-4.71484E-04_r8,-4.71484E-04_r8/ + + data g_F07_c2(:) / 1.349959E-1_r8, 1.115697E-1_r8, 9.853958E-2_r8, 5.557793E-2_r8,& + -1.233493E-1_r8, 0.0_r8, 0.0_r8/ + data g_F07_c1(:) /-3.987320E-1_r8,-3.723287E-1_r8,-3.924784E-1_r8,-3.259404E-1_r8,& + 4.429054E-2_r8,-1.726586E-1_r8,-1.726586E-1_r8/ + data g_F07_c0(:) / 7.938904E-1_r8, 8.030084E-1_r8, 8.513932E-1_r8, 8.692241E-1_r8,& + 7.085850E-1_r8, 6.412701E-1_r8, 6.412701E-1_r8/ + data g_F07_p2(:) / 3.165543E-3_r8, 2.014810E-3_r8, 1.780838E-3_r8, 6.987734E-4_r8,& + -1.882932E-2_r8,-2.277872E-2_r8,-2.277872E-2_r8/ + data g_F07_p1(:) / 1.140557E-1_r8, 1.143152E-1_r8, 1.143814E-1_r8, 1.071238E-1_r8,& + 1.353873E-1_r8, 1.914431E-1_r8, 1.914431E-1_r8/ + data g_F07_p0(:) / 5.292852E-1_r8, 5.425909E-1_r8, 5.601598E-1_r8, 6.023407E-1_r8,& + 6.473899E-1_r8, 4.634944E-1_r8, 4.634944E-1_r8/ + + !!! factors for considring dust-snow internal mixing + data dust_clear_d0(:) /1.0413E+00_r8,1.0168E+00_r8,1.0189E+00_r8/ + data dust_clear_d1(:) /1.0016E+00_r8,1.0070E+00_r8,1.0840E+00_r8/ + data dust_clear_d2(:) /2.4208E-01_r8,1.5300E-03_r8,1.1230E-04_r8/ + + data dust_cloudy_d0(:) /1.0388E+00_r8,1.0167E+00_r8,1.0189E+00_r8/ + data dust_cloudy_d1(:) /1.0015E+00_r8,1.0061E+00_r8,1.0823E+00_r8/ + data dust_cloudy_d2(:) /2.5973E-01_r8,1.6200E-03_r8,1.1721E-04_r8/ + + ! Enforce expected array sizes + + ! associate(& + ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:)] snow liquid water equivalent (col) [kg/m2] + ! frac_sno => col_ws%frac_sno_eff & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) + ! ) + + ! Define constants + pi = SHR_CONST_PI + nint_snw_rds_min = nint(snw_rds_min) + + ! always USE Delta approximation for snow + DELTA = 1 + + !Gaussian integration angle and coefficients for diffuse radiation + difgauspt(1:8) & ! gaussian angles (radians) + = (/ 0.9894009_r8, 0.9445750_r8, & + 0.8656312_r8, 0.7554044_r8, & + 0.6178762_r8, 0.4580168_r8, & + 0.2816036_r8, 0.0950125_r8/) + difgauswt(1:8) & ! gaussian weights + = (/ 0.0271525_r8, 0.0622535_r8, & + 0.0951585_r8, 0.1246290_r8, & + 0.1495960_r8, 0.1691565_r8, & + 0.1826034_r8, 0.1894506_r8/) + + snw_shp_lcl(:) = snow_shape_sphere + snw_fs_lcl(:) = 0._r8 + snw_ar_lcl(:) = 0._r8 + atm_type_index = atm_type_default + + ! Define snow grain shape + IF (trim(snow_shape) == 'sphere') THEN + snw_shp_lcl(:) = snow_shape_sphere + ELSEIF (trim(snow_shape) == 'spheroid') THEN + snw_shp_lcl(:) = snow_shape_spheroid + ELSEIF (trim(snow_shape) == 'hexagonal_plate') THEN + snw_shp_lcl(:) = snow_shape_hexagonal_plate + ELSEIF (trim(snow_shape) == 'koch_snowflake') THEN + snw_shp_lcl(:) = snow_shape_koch_snowflake + ELSE + IF (mpas_is_root) THEN + write(iulog,*) "snow_shape = ", snow_shape + CALL CoLM_stop() + ENDIF + ENDIF + + ! Define atmospheric type + IF (trim(snicar_atm_type) == 'default') THEN + atm_type_index = atm_type_default + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain + ELSE + IF (mpas_is_root) THEN + write(iulog,*) "snicar_atm_type = ", snicar_atm_type + CALL CoLM_stop() + ENDIF + ENDIF + + ! (when called from CSIM, there is only one column) + + ! Zero absorbed radiative fluxes: + DO i=maxsnl+1,1,1 + flx_abs_lcl(:,:) = 0._r8 + flx_abs(i,:) = 0._r8 + ENDDO + + ! set snow/ice mass to be used for RT: + IF (flg_snw_ice == 1) THEN + h2osno_lcl = h2osno + ELSE + h2osno_lcl = h2osno_ice(0) + ENDIF + + ! Qualifier for computing snow RT: + ! 1) sunlight from atmosphere model + ! 2) minimum amount of snow on ground. + ! Otherwise, set snow albedo to zero + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw) ) THEN + + ! Set variables specific to ELM + IF (flg_snw_ice == 1) THEN + ! If there is snow, but zero snow layers, we must create a layer locally. + ! This layer is presumed to have the fresh snow effective radius. + IF (snl > -1) THEN + flg_nosnl = 1 + snl_lcl = -1 + h2osno_ice_lcl(0) = h2osno_lcl + h2osno_liq_lcl(0) = 0._r8 + snw_rds_lcl(0) = nint_snw_rds_min + ELSE + flg_nosnl = 0 + snl_lcl = snl + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + ENDIF + + snl_btm = 0 + snl_top = snl_lcl+1 + + ! Set variables specific to CSIM + ELSE + flg_nosnl = 0 + snl_lcl = -1 + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + snl_btm = 0 + snl_top = 0 + ENDIF ! END IF flg_snw_ice == 1 + +#ifdef MODAL_AER + !mgf++ + ! + ! Assume fixed BC effective radii of 100nm. This is close to + ! the effective radius of 95nm (number median radius of + ! 40nm) assumed for freshly-emitted BC in MAM. Future + ! implementations may prognose the BC effective radius in + ! snow. + rds_bcint_lcl(:) = 100._r8 + rds_bcext_lcl(:) = 100._r8 + !mgf-- +#endif + + ! Set local aerosol array + DO j=1,sno_nbr_aer + mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) + ENDDO + + ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos + albsfc_lcl(1) = albsfc(1) + albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) + + ! Error check for snow grain size: + IF (mpas_is_root) THEN + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN + write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." + write (iulog,*) "flg_snw_ice= ", flg_snw_ice + write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl + write (iulog,*) "h2osno(c)= ", h2osno_lcl + CALL CoLM_stop() + ENDIF + ENDDO + ENDIF + + ! Incident flux weighting parameters + ! - sum of all VIS bands must equal 1 + ! - sum of all NIR bands must equal 1 + ! + ! Spectral bands (5-band CASE) + ! Band 1: 0.3-0.7um (VIS) + ! Band 2: 0.7-1.0um (NIR) + ! Band 3: 1.0-1.2um (NIR) + ! Band 4: 1.2-1.5um (NIR) + ! Band 5: 1.5-5.0um (NIR) + ! + ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere + ! + ! 3-band weights + IF (numrad_snw==3) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.66628670195247_r8 + flx_wgt(3) = 0.33371329804753_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.77887652162877_r8 + flx_wgt(3) = 0.22112347837123_r8 + ENDIF + + ! 5-band weights + ELSEIF(numrad_snw==5) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.49352158521175_r8 + flx_wgt(3) = 0.18099494230665_r8 + flx_wgt(4) = 0.12094898498813_r8 + flx_wgt(5) = 0.20453448749347_r8 + ELSE + slr_zen = nint(acos(coszen) * 180._r8 / pi) + IF (slr_zen>89) THEN + slr_zen = 89 + ENDIF + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dir(atm_type_index, slr_zen+1, 2) + flx_wgt(3) = flx_wgt_dir(atm_type_index, slr_zen+1, 3) + flx_wgt(4) = flx_wgt_dir(atm_type_index, slr_zen+1, 4) + flx_wgt(5) = flx_wgt_dir(atm_type_index, slr_zen+1, 5) + ENDIF + + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.58581507618433_r8 + flx_wgt(3) = 0.20156903770812_r8 + flx_wgt(4) = 0.10917889346386_r8 + flx_wgt(5) = 0.10343699264369_r8 + ELSE + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dif(atm_type_index, 2) + flx_wgt(3) = flx_wgt_dif(atm_type_index, 3) + flx_wgt(4) = flx_wgt_dif(atm_type_index, 4) + flx_wgt(5) = flx_wgt_dif(atm_type_index, 5) + ENDIF + ENDIF + ENDIF ! END IF numrad_snw + + ! Loop over snow spectral bands + + exp_min = exp(-argmax) + DO bnd_idx = 1,numrad_snw + + ! note that we can remove flg_dover since this algorithm is + ! stable for mu_not > 0.01 + + ! mu_not is cosine solar zenith angle above the fresnel level; make + ! sure mu_not is large enough for stable and meaningful radiation + ! solution: .01 is like sun just touching horizon with its lower edge + ! equivalent to mu0 in sea-ice shortwave model ice_shortwave.F90 + mu_not = max(coszen, cp01) + + + ! Set direct or diffuse incident irradiance to 1 + ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) + IF (flg_slr_in == 1) THEN + flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 + flx_slri_lcl(bnd_idx) = 0._r8 + ELSE + flx_slrd_lcl(bnd_idx) = 0._r8 + flx_slri_lcl(bnd_idx) = 1._r8 + ENDIF + + ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. + ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + ! Define local Mie parameters based on snow grain size and aerosol species, + ! retrieved from a lookup table. + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (direct radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) + ENDDO + ELSEIF (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (diffuse radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) + ENDDO + ENDIF + + ! Calculate the asymetry factors under different snow grain shapes + DO i=snl_top,snl_btm,1 + IF(snw_shp_lcl(i) == snow_shape_spheroid) THEN ! spheroid + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_sphd = 0.929_r8 + ELSE + fs_sphd = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 0.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_sphd/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_c0 + g_F07_c1 * AR_tmp + g_F07_c2 * (AR_tmp**2) + ELSEIF(snw_shp_lcl(i) == snow_shape_hexagonal_plate) THEN ! hexagonal plate + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_hex0 = 0.788_r8 + ELSE + fs_hex0 = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 2.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_hex0/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + ELSEIF(snw_shp_lcl(i) == snow_shape_koch_snowflake) THEN ! Koch snowflake + diam_ice = 2._r8 * snw_rds_lcl(i) /0.544_r8 + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_koch = 0.712_r8 + ELSE + fs_koch = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 2.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_koch/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + ENDIF + + ! Linear interpolation for calculating the asymetry factor at band_idx. + IF(snw_shp_lcl(i) > 1) THEN + IF(bnd_idx == 1) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8) +g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8)+gg_ice_F07_tmp(1) + ELSEIF(bnd_idx == 2) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+gg_ice_F07_tmp(1) + ELSEIF(bnd_idx == 3) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + ELSEIF(bnd_idx == 4) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + ELSEIF(bnd_idx == 5) THEN + g_Cg_intp = (g_ice_Cg_tmp(6)-g_ice_Cg_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +g_ice_Cg_tmp(5) + gg_F07_intp = (gg_ice_F07_tmp(6)-gg_ice_F07_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +gg_ice_F07_tmp(5) + ENDIF + g_ice_F07 = gg_F07_intp + (1._r8 - gg_F07_intp) / ss_alb_snw_lcl(i) / 2._r8 + g_ice = g_ice_F07 * g_Cg_intp + asm_prm_snw_lcl(i) = g_ice + ENDIF + + IF(asm_prm_snw_lcl(i) > 0.99_r8) THEN + asm_prm_snw_lcl(i) = 0.99_r8 + ENDIF + + ENDDO + !!!-END + + !H. Wang + ! aerosol species 1 optical properties + ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) + !H. Wang + ! aerosol species 3 optical properties + ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) + asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) + ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) + + ! aerosol species 4 optical properties + ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) + asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) + ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) + + ! aerosol species 5 optical properties + ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) + asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) + ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) + + ! aerosol species 6 optical properties + ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) + asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) + ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) + + ! aerosol species 7 optical properties + ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) + asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) + ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) + + ! aerosol species 8 optical properties + ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) + asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) + ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) + + + ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) + ! 2. optical Depths (tau_snw, tau_aer) + ! 3. weighted Mie properties (tau, omega, g) + + ! Weighted Mie parameters of each layer + DO i=snl_top,snl_btm,1 +#ifdef MODAL_AER + !mgf++ within-ice and external BC optical properties + ! + ! Lookup table indices for BC optical properties, + ! dependent on snow grain size and BC particle + ! size. + + ! valid for 25 < snw_rds < 1625 um: + IF (snw_rds_lcl(i) < 125) THEN + tmp1 = snw_rds_lcl(i)/50 + idx_bcint_icerds = nint(tmp1) + ELSEIF (snw_rds_lcl(i) < 175) THEN + idx_bcint_icerds = 2 + ELSE + tmp1 = (snw_rds_lcl(i)/250)+2 + idx_bcint_icerds = nint(tmp1) + ENDIF + + ! valid for 25 < bc_rds < 525 nm + idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) + idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) + + ! check bounds: + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + + ! retrieve absorption enhancement factor for within-ice BC + enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) + + ! get BC optical properties (moved from above) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct + + ! aerosol species 2 optical properties (external BC) + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) + +#else + ! bulk aerosol treatment (BC optical properties independent + ! of BC and ice grain size) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +#endif + + ! Calculate single-scattering albedo for internal mixing of dust-snow + IF (use_dust_snow_internal_mixing) THEN + IF (bnd_idx < 4) THEN + C_dust_total = mss_cnc_aer_lcl(i,5) + mss_cnc_aer_lcl(i,6) & + + mss_cnc_aer_lcl(i,7) + mss_cnc_aer_lcl(i,8) + C_dust_total = C_dust_total * 1.0E+06_r8 + IF(C_dust_total > 0._r8) THEN + IF (flg_slr_in == 1) THEN + R_1_omega_tmp = dust_clear_d0(bnd_idx) & + + dust_clear_d2(bnd_idx)*(C_dust_total**dust_clear_d1(bnd_idx)) + ELSE + R_1_omega_tmp = dust_cloudy_d0(bnd_idx) & + + dust_cloudy_d2(bnd_idx)*(C_dust_total**dust_cloudy_d1(bnd_idx)) + ENDIF + ss_alb_snw_lcl(i) = 1.0_r8 - (1.0_r8 - ss_alb_snw_lcl(i)) *R_1_omega_tmp + ENDIF + ENDIF + DO j = 5,8,1 + ss_alb_aer_lcl(j) = 0._r8 + asm_prm_aer_lcl(j) = 0._r8 + ext_cff_mss_aer_lcl(j) = 0._r8 + ENDDO + ENDIF + + !mgf-- + + L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) + tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) + + DO j=1,sno_nbr_aer + IF (use_dust_snow_internal_mixing .and. (j >= 5)) THEN + L_aer(i,j) = 0._r8 + ELSE + L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) + ENDIF + tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) + ENDDO + + tau_sum = 0._r8 + omega_sum = 0._r8 + g_sum = 0._r8 + + DO j=1,sno_nbr_aer + tau_sum = tau_sum + tau_aer(i,j) + omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) + g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) + ENDDO + + tau(i) = tau_sum + tau_snw(i) + omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) + g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) + ENDDO ! endWeighted Mie parameters of each layer + + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 + g_star(i) = g(i)/(1+g(i)) + omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) + tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) + ENDDO + ELSE + DO i=snl_top,snl_btm,1 + g_star(i) = g(i) + omega_star(i) = omega(i) + tau_star(i) = tau(i) + ENDDO + ENDIF + + ! Begin radiative transfer solver + ! Given input vertical profiles of optical properties, evaluate the + ! monochromatic Delta-Eddington adding-doubling solution + + ! note that trndir, trntdr, trndif, rupdir, rupdif, rdndif + ! are variables at the layer interface, + ! for snow with layers rangeing from snl_top to snl_btm + ! there are snl_top to snl_btm+1 layer interface + snl_btm_itf = snl_btm + 1 + + DO i = snl_top,snl_btm_itf,1 + trndir(i) = c0 + trntdr(i) = c0 + trndif(i) = c0 + rupdir(i) = c0 + rupdif(i) = c0 + rdndif(i) = c0 + ENDDO + + ! initialize top interface of top layer + trndir(snl_top) = c1 + trntdr(snl_top) = c1 + trndif(snl_top) = c1 + rdndif(snl_top) = c0 + + ! begin main level loop + ! for layer interfaces except for the very bottom + DO i = snl_top,snl_btm,1 + + ! initialize all layer apparent optical properties to 0 + rdir (i) = c0 + rdif_a(i) = c0 + rdif_b(i) = c0 + tdir (i) = c0 + tdif_a(i) = c0 + tdif_b(i) = c0 + trnlay(i) = c0 + + ! compute next layer Delta-eddington solution only IF total transmission + ! of radiation to the interface just above the layer exceeds trmin. + + IF (trntdr(i) > trmin ) THEN + + ! calculation over layers with penetrating radiation + + ! delta-transformed single-scattering properties + ! of this layer + ts = tau_star(i) + ws = omega_star(i) + gs = g_star(i) + + ! Delta-Eddington solution expressions + ! n(uu,et) = ((uu+c1)*(uu+c1)/et ) - ((uu-c1)*(uu-c1)*et) + ! u(w,gg,e) = c1p5*(c1 - w*gg)/e + ! el(w,gg) = sqrt(c3*(c1-w)*(c1 - w*gg)) + lm = sqrt(c3*(c1-ws)*(c1 - ws*gs)) !lm = el(ws,gs) + ue = c1p5*(c1 - ws*gs)/lm !ue = u(ws,gs,lm) + extins = max(exp_min, exp(-lm*ts)) + ne = ((ue+c1)*(ue+c1)/extins) - ((ue-c1)*(ue-c1)*extins) !ne = n(ue,extins) + + ! first calculation of rdif, tdif using Delta-Eddington formulas + ! rdif_a(k) = (ue+c1)*(ue-c1)*(c1/extins - extins)/ne + rdif_a(i) = (ue**2-c1)*(c1/extins - extins)/ne + tdif_a(i) = c4*ue/ne + + ! evaluate rdir,tdir for direct beam + trnlay(i) = max(exp_min, exp(-ts/mu_not)) + + ! Delta-Eddington solution expressions + ! alpha(w,uu,gg,e) = p75*w*uu*((c1 + gg*(c1-w))/(c1 - e*e*uu*uu)) + ! agamm(w,uu,gg,e) = p5*w*((c1 + c3*gg*(c1-w)*uu*uu)/(c1-e*e*uu*uu)) + ! alp = alpha(ws,mu_not,gs,lm) + ! gam = agamm(ws,mu_not,gs,lm) + alp = cp75*ws*mu_not*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu_not*mu_not)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu_not*mu_not)/(c1-lm*lm*mu_not*mu_not)) + apg = alp + gam + amg = alp - gam + + rdir(i) = apg*rdif_a(i) + amg*(tdif_a(i)*trnlay(i) - c1) + tdir(i) = apg*tdif_a(i) + (amg* rdif_a(i)-apg+c1)*trnlay(i) + + ! recalculate rdif,tdif using direct angular integration over rdir,tdir, + ! since Delta-Eddington rdif formula is not well-behaved (it is usually + ! biased low and can even be negative); USE ngmax angles and gaussian + ! integration for most accuracy: + R1 = rdif_a(i) ! USE R1 as temporary + T1 = tdif_a(i) ! USE T1 as temporary + swt = c0 + smr = c0 + smt = c0 + DO ng=1,ngmax + mu = difgauspt(ng) + gwt = difgauswt(ng) + swt = swt + mu*gwt + trn = max(exp_min, exp(-ts/mu)) + ! alp = alpha(ws,mu,gs,lm) + ! gam = agamm(ws,mu,gs,lm) + alp = cp75*ws*mu*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu*mu)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu*mu)/(c1-lm*lm*mu*mu)) + apg = alp + gam + amg = alp - gam + rdr = apg*R1 + amg*T1*trn - amg + tdr = apg*T1 + amg*R1*trn - apg*trn + trn + smr = smr + mu*rdr*gwt + smt = smt + mu*tdr*gwt + ENDDO ! ng + rdif_a(i) = smr/swt + tdif_a(i) = smt/swt + + ! homogeneous layer + rdif_b(i) = rdif_a(i) + tdif_b(i) = tdif_a(i) + + ENDIF ! trntdr(k) > trmin + + ! Calculate the solar beam transmission, total transmission, and + ! reflectivity for diffuse radiation from below at interface i, + ! the top of the current layer k: + ! + ! layers interface + ! + ! --------------------- i-1 + ! i-1 + ! --------------------- i + ! i + ! --------------------- + + trndir(i+1) = trndir(i)*trnlay(i) + refkm1 = c1/(c1 - rdndif(i)*rdif_a(i)) + tdrrdir = trndir(i)*rdir(i) + tdndif = trntdr(i) - trndir(i) + trntdr(i+1) = trndir(i)*tdir(i) + & + (tdndif + tdrrdir*rdndif(i))*refkm1*tdif_a(i) + rdndif(i+1) = rdif_b(i) + & + (tdif_b(i)*rdndif(i)*refkm1*tdif_a(i)) + trndif(i+1) = trndif(i)*refkm1*tdif_a(i) + + ENDDO ! END main level loop + + + ! compute reflectivity to direct and diffuse radiation for layers + ! below by adding succesive layers starting from the underlying + ! ground and working upwards: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- i+1 + ! i+1 + ! --------------------- + + ! set the underlying ground albedo == albedo of near-IR + ! unless bnd_idx == 1, for visible + rupdir(snl_btm_itf) = albsfc(2) + rupdif(snl_btm_itf) = albsfc(2) + IF (bnd_idx == 1) THEN + rupdir(snl_btm_itf) = albsfc(1) + rupdif(snl_btm_itf) = albsfc(1) + ENDIF + + DO i=snl_btm,snl_top,-1 + ! interface scattering + refkp1 = c1/( c1 - rdif_b(i)*rupdif(i+1)) + ! dir from top layer plus exp tran ref from lower layer, interface + ! scattered and tran thru top layer from below, plus diff tran ref + ! from lower layer with interface scattering tran thru top from below + rupdir(i) = rdir(i) & + + ( trnlay(i) *rupdir(i+1) & + + (tdir(i)-trnlay(i))*rupdif(i+1))*refkp1*tdif_b(i) + ! dif from top layer from above, plus dif tran upwards reflected and + ! interface scattered which tran top from below + rupdif(i) = rdif_a(i) + tdif_a(i)*rupdif(i+1)*refkp1*tdif_b(i) + ENDDO ! i + + ! net flux (down-up) at each layer interface from the + ! snow top (i = snl_top) to bottom interface above land (i = snl_btm_itf) + ! the interface reflectivities and transmissivities required + ! to evaluate interface fluxes are returned from solution_dEdd; + ! now compute up and down fluxes for each interface, using the + ! combined layer properties at each interface: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- + + DO i = snl_top, snl_btm_itf + ! interface scattering + refk = c1/(c1 - rdndif(i)*rupdif(i)) + ! dir tran ref from below times interface scattering, plus diff + ! tran and ref from below times interface scattering + ! fdirup(i) = (trndir(i)*rupdir(i) + & + ! (trntdr(i)-trndir(i)) & + ! *rupdif(i))*refk + ! dir tran plus total diff trans times interface scattering plus + ! dir tran with up dir ref and down dif ref times interface scattering + ! fdirdn(i) = trndir(i) + (trntdr(i) & + ! - trndir(i) + trndir(i) & + ! *rupdir(i)*rdndif(i))*refk + ! diffuse tran ref from below times interface scattering + ! fdifup(i) = trndif(i)*rupdif(i)*refk + ! diffuse tran times interface scattering + ! fdifdn(i) = trndif(i)*refk + + ! netflux, down - up + ! dfdir = fdirdn - fdirup + dfdir(i) = trndir(i) & + + (trntdr(i)-trndir(i)) * (c1 - rupdif(i)) * refk & + - trndir(i)*rupdir(i) * (c1 - rdndif(i)) * refk + IF (dfdir(i) < puny) dfdir(i) = c0 + ! dfdif = fdifdn - fdifup + dfdif(i) = trndif(i) * (c1 - rupdif(i)) * refk + IF (dfdif(i) < puny) dfdif(i) = c0 + ENDDO ! k + + ! SNICAR_AD_RT is called twice for direct and diffuse incident fluxes + ! direct incident + IF (flg_slr_in == 1) THEN + albedo = rupdir(snl_top) + dftmp = dfdir + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = (trndir(snl_top)*rupdir(snl_top) + & + (trntdr(snl_top)-trndir(snl_top)) & + *rupdif(snl_top))*refk + !diffuse incident + ELSE + albedo = rupdif(snl_top) + dftmp = dfdif + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = trndif(snl_top)*rupdif(snl_top)*refk + ENDIF + + ! Absorbed flux in each layer + DO i=snl_top,snl_btm,1 + F_abs(i) = dftmp(i)-dftmp(i+1) + flx_abs_lcl(i,bnd_idx) = F_abs(i) + + ! ERROR check: negative absorption + IF (mpas_is_root) THEN + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) + write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) + write(iulog,*) "SNICAR_AD STATS: L_snw(0)= ", L_snw(0) + write(iulog,*) "SNICAR_AD STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write(iulog,*) "SNICAR_AD STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) + write(iulog,*) "SNICAR_AD STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) + write(iulog,*) "SNICAR_AD STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) + write(iulog,*) "SNICAR_AD STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) + write(iulog,*) "SNICAR_AD STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) + write(iulog,*) "SNICAR_AD STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) + CALL CoLM_stop() + ENDIF + ENDIF + ENDDO + + ! absobed flux by the underlying ground + F_btm_net = dftmp(snl_btm_itf) + + ! note here, snl_btm_itf = 1 by snow column set up in CLM + flx_abs_lcl(1,bnd_idx) = F_btm_net + + IF (flg_nosnl == 1) THEN + ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer + !flx_abs_lcl(:,bnd_idx) = 0._r8 + !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net + + ! changed on 20070408: + ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and + ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. + flx_abs_lcl(0,bnd_idx) = F_abs(0) + flx_abs_lcl(1,bnd_idx) = F_btm_net + ENDIF + + !Underflow check (we've already tripped the error condition above) + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN + flx_abs_lcl(i,bnd_idx) = 0._r8 + ENDIF + ENDDO + + F_abs_sum = 0._r8 + DO i=snl_top,snl_btm,1 + F_abs_sum = F_abs_sum + F_abs(i) + ENDDO + + !ENDDO !ENDDO WHILE (flg_dover > 0) + + ! Energy conservation check: + ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) + energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) + IF (mpas_is_root) THEN + IF (abs(energy_sum) > 0.00001_r8) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum + write(iulog,*) "F_abs_sum: ",F_abs_sum + write(iulog,*) "F_btm_net: ",F_btm_net + write(iulog,*) "F_sfc_pls: ",F_sfc_pls + write(iulog,*) "mu_not*pi*flx_slrd_lcl(bnd_idx): ", mu_not*pi*flx_slrd_lcl(bnd_idx) + write(iulog,*) "flx_slri_lcl(bnd_idx)", flx_slri_lcl(bnd_idx) + write(iulog,*) "bnd_idx", bnd_idx + write(iulog,*) "F_abs", F_abs + write(iulog,*) "albedo", albedo + CALL CoLM_stop() + ENDIF + ENDIF + + albout_lcl(bnd_idx) = albedo + ! Check that albedo is less than 1 + IF (mpas_is_root) THEN + IF (albout_lcl(bnd_idx) > 1.0) THEN + write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " + write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx + write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & + " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) + write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in + + write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) + write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) + write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) + write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) + write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) + + write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) + write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) + write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) + write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) + write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + + write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) + write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) + write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) + write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) + write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + + CALL CoLM_stop() + ENDIF + ENDIF + + ENDDO ! loop over wvl bands + + + ! Weight output NIR albedo appropriately + albout(1) = albout_lcl(1) + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) + ENDDO + albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + + ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately + flx_abs(:,1) = flx_abs_lcl(:,1) + DO i=snl_top,1,1 + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) + ENDDO + flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + ENDDO + + ! near-IR direct albedo/absorption adjustment for high solar zenith angles + ! solar zenith angle parameterization + ! calculate the scaling factor for NIR direct albedo IF SZA>75 degree + IF ((mu_not < mu_75) .and. (flg_slr_in == 1)) THEN + sza_c1 = sza_a0 + sza_a1 * mu_not + sza_a2 * mu_not**2 + sza_c0 = sza_b0 + sza_b1 * mu_not + sza_b2 * mu_not**2 + sza_factor = sza_c1 * (log10(snw_rds_lcl(snl_top) * c1) - c6) + sza_c0 + flx_sza_adjust = albout(2) * (sza_factor-c1) * sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + albout(2) = albout(2) * sza_factor + flx_abs(snl_top,2) = flx_abs(snl_top,2) - flx_sza_adjust + ENDIF + + ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + albout(1) = albsfc(1) + albout(2) = albsfc(2) + + ! There is either zero snow, or no sun + ELSE + albout(1) = 0._r8 + albout(2) = 0._r8 + ENDIF ! IF column has snow and coszen > 0 + + ! END associate + + END SUBROUTINE SNICAR_AD_RT + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_grain( dtime , snl , dz ,& + qflx_snow_grnd , qflx_snwcp_ice , qflx_snofrz_lyr ,& + do_capsnow , frac_sno , h2osno ,& + h2osno_liq , h2osno_ice , t_soisno ,& + t_grnd , forc_t , snw_rds ) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Updates the snow effective grain size (radius). +! Contributions to grain size evolution are from: +! 1. vapor redistribution (dry snow) +! 2. liquid water redistribution (wet snow) +! 3. re-freezing of liquid water +! +! Vapor redistribution: Method is to retrieve 3 best-bit parameters that +! depend on snow temperature, temperature gradient, and density, +! that are derived from the microphysical model described in: +! Flanner and Zender (2006), Linking snowpack microphysics and albedo +! evolution, J. Geophys. Res., 111, D12208, doi:10.1029/2005JD006834. +! The parametric equation has the form: +! dr/dt = drdt_0*(tau/(dr_fresh+tau))^(1/kappa), WHERE: +! r is the effective radius, +! tau and kappa are best-fit parameters, +! drdt_0 is the initial rate of change of effective radius, and +! dr_fresh is the difference between the current and fresh snow states +! (r_current - r_fresh). +! +! Liquid water redistribution: Apply the grain growth FUNCTION from: +! Brun, E. (1989), Investigation of wet-snow metamorphism in respect of +! liquid-water content, Annals of Glaciology, 13, 22-26. +! There are two parameters that describe the grain growth rate as +! a FUNCTION of snow liquid water content (LWC). The "LWC=0" parameter +! is zeroed here because we are accounting for dry snowing with a +! different representation +! +! Re-freezing of liquid water: Assume that re-frozen liquid water clumps +! into an arbitrarily large effective grain size (snw_rds_refrz). +! The phenomenon is observed (Grenfell), but so far unquantified, as far as +! I am aware. +! +! !USES: +! +! DAI, Dec. 29, 2022 +!----------------------------------------------------------------------- +! !ARGUMENTS: + + IMPLICIT NONE + + real(r8) , intent(in) :: dtime ! land model time step [sec] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: dz ( maxsnl+1:1 ) ! layer thickness (col,lyr) [m] + + real(r8) , intent(in) :: qflx_snow_grnd ! snow on ground after interception (col) [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snwcp_ice ! excess precipitation due to snow capping [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snofrz_lyr ( maxsnl+1:0 ) ! snow freezing rate (col,lyr) [kg m-2 s-1] + + logical , intent(in) :: do_capsnow ! true => DO snow capping + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + real(r8) , intent(in) :: h2osno ! snow water (col) [mm H2O] + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg m-2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg m-2] + + real(r8) , intent(in) :: t_soisno ( maxsnl+1:1 ) ! soil and snow temperature (col,lyr) [K] + real(r8) , intent(in) :: t_grnd ! ground temperature (col) [K] + real(r8) , intent(in) :: forc_t ! Atmospheric temperature (col) [K] + + real(r8) , intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective grain radius (col,lyr) [microns, m-6] + + ! DAI, Dec. 29, 2022 + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + integer :: snl_top ! top snow layer index [idx] + integer :: snl_btm ! bottom snow layer index [idx] + integer :: i ! layer index [idx] + ! integer :: c_idx ! column index [idx] + integer :: fc ! snow column filter index [idx] + integer :: T_idx ! snow aging lookup table temperature index [idx] + integer :: Tgrd_idx ! snow aging lookup table temperature gradient index [idx] + integer :: rhos_idx ! snow aging lookup table snow density index [idx] + real(r8) :: t_snotop ! temperature at upper layer boundary [K] + real(r8) :: t_snobtm ! temperature at lower layer boundary [K] + real(r8) :: dTdz(maxsnl:0) ! snow temperature gradient (col,lyr) [K m-1] + real(r8) :: bst_tau ! snow aging parameter retrieved from lookup table [hour] + real(r8) :: bst_kappa ! snow aging parameter retrieved from lookup table [unitless] + real(r8) :: bst_drdt0 ! snow aging parameter retrieved from lookup table [um hr-1] + real(r8) :: dr ! incremental change in snow effective radius [um] + real(r8) :: dr_wet ! incremental change in snow effective radius from wet growth [um] + real(r8) :: dr_fresh ! difference between fresh snow r_e and current r_e [um] + real(r8) :: newsnow ! fresh snowfall [kg m-2] + real(r8) :: refrzsnow ! re-frozen snow [kg m-2] + real(r8) :: frc_newsnow ! fraction of layer mass that is new snow [frc] + real(r8) :: frc_oldsnow ! fraction of layer mass that is old snow [frc] + real(r8) :: frc_refrz ! fraction of layer mass that is re-frozen snow [frc] + real(r8) :: frc_liq ! fraction of layer mass that is liquid water[frc] + real(r8) :: rhos ! snow density [kg m-3] + real(r8) :: h2osno_lyr ! liquid + solid H2O in snow layer [kg m-2] + real(r8) :: cdz(maxsnl+1:0) ! column average layer thickness [m] + real(r8) :: snw_rds_fresh ! fresh snow radius [microns] + + real(r8) :: snot_top ! temperature in top snow layer (col) [K] + real(r8) :: dTdz_top ! temperature gradient in top layer (col) [K m-1] + real(r8) :: snw_rds_top ! effective grain radius, top layer (col) [microns, m-6] + real(r8) :: sno_liq_top ! liquid water fraction (mass) in top snow layer (col) [frc] + + !--------------------------------------------------------------------------! + + ! associate( & + ! snl => col_pp%snl , & ! Input: [integer (:) ] negative number of snow layers (col) [nbr] + ! dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer thickness (col,lyr) [m] + + ! qflx_snow_grnd => col_wf%qflx_snow_grnd , & ! Input: [real(r8) (:) ] snow on ground after interception (col) [kg m-2 s-1] + ! qflx_snwcp_ice => col_wf%qflx_snwcp_ice , & ! Input: [real(r8) (:) ] excess precipitation due to snow capping [kg m-2 s-1] + ! qflx_snofrz_lyr => col_wf%qflx_snofrz_lyr , & ! Input: [real(r8) (:,:) ] snow freezing rate (col,lyr) [kg m-2 s-1] + + ! do_capsnow => col_ws%do_capsnow , & ! Input: [logical (:) ] true => DO snow capping + ! frac_sno => col_ws%frac_sno_eff , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (col) [mm H2O] + ! h2osno_liq => col_ws%h2osno_liq , & ! Input: [real(r8) (:,:) ] liquid water content (col,lyr) [kg m-2] + ! h2osno_ice => col_ws%h2osno_ice , & ! Input: [real(r8) (:,:) ] ice content (col,lyr) [kg m-2] + ! snw_rds => col_ws%snw_rds , & ! Output: [real(r8) (:,:) ] effective grain radius (col,lyr) [microns, m-6] + ! snw_rds_top => col_ws%snw_rds_top , & ! Output: [real(r8) (:) ] effective grain radius, top layer (col) [microns, m-6] + ! sno_liq_top => col_ws%sno_liq_top , & ! Output: [real(r8) (:) ] liquid water fraction (mass) in top snow layer (col) [frc] + + ! t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil and snow temperature (col,lyr) [K] + ! t_grnd => col_es%t_grnd , & ! Input: [real(r8) (:) ] ground temperature (col) [K] + ! snot_top => col_es%snot_top , & ! Output: [real(r8) (:) ] temperature in top snow layer (col) [K] + ! dTdz_top => col_es%dTdz_top & ! Output: [real(r8) (:) ] temperature gradient in top layer (col) [K m-1] + ! ) + + + IF (snl < 0 .and. h2osno > 0._r8) THEN + + snl_btm = 0 + snl_top = snl + 1 + + cdz(snl_top:snl_btm)=frac_sno*dz(snl_top:snl_btm) + + ! loop over snow layers + DO i = snl_top, snl_btm, 1 + ! + !********** 1. DRY SNOW AGING *********** + ! + h2osno_lyr = h2osno_liq(i) + h2osno_ice(i) + + ! temperature gradient + IF (i == snl_top) THEN + ! top layer + t_snotop = t_soisno(snl_top) + t_snobtm = (t_soisno(i+1)*dz(i) & + + t_soisno(i)*dz(i+1)) & + / (dz(i)+dz(i+1)) + ELSE + t_snotop = (t_soisno(i-1)*dz(i) & + + t_soisno(i)*dz(i-1)) & + / (dz(i)+dz(i-1)) + t_snobtm = (t_soisno(i+1)*dz(i) & + + t_soisno(i)*dz(i+1)) & + / (dz(i)+dz(i+1)) + ENDIF + + dTdz(i) = abs((t_snotop - t_snobtm) / cdz(i)) + + ! snow density + rhos = (h2osno_liq(i)+h2osno_ice(i)) / cdz(i) + + ! make sure rhos doesn't drop below 50 (see rhos_idx below) + rhos=max(50._r8,rhos) + + ! best-fit table indecies + T_idx = nint((t_soisno(i)-223) / 5) + 1 + Tgrd_idx = nint(dTdz(i) / 10) + 1 + rhos_idx = nint((rhos-50) / 50) + 1 + + ! boundary check: + IF (T_idx < idx_T_min) THEN + T_idx = idx_T_min + ENDIF + IF (T_idx > idx_T_max) THEN + T_idx = idx_T_max + ENDIF + IF (Tgrd_idx < idx_Tgrd_min) THEN + Tgrd_idx = idx_Tgrd_min + ENDIF + IF (Tgrd_idx > idx_Tgrd_max) THEN + Tgrd_idx = idx_Tgrd_max + ENDIF + IF (rhos_idx < idx_rhos_min) THEN + rhos_idx = idx_rhos_min + ENDIF + IF (rhos_idx > idx_rhos_max) THEN + rhos_idx = idx_rhos_max + ENDIF + + ! best-fit parameters + bst_tau = snowage_tau(rhos_idx,Tgrd_idx,T_idx) + bst_kappa = snowage_kappa(rhos_idx,Tgrd_idx,T_idx) + bst_drdt0 = snowage_drdt0(rhos_idx,Tgrd_idx,T_idx) + + ! change in snow effective radius, using best-fit parameters + ! added checks suggested by mgf. --HW 10/15/2015 + dr_fresh = snw_rds(i)-snw_rds_min + +#ifdef MODAL_AER + IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN + dr_fresh = 0.0_r8 + ELSEIF ( dr_fresh < 0.0_r8 ) THEN + IF (mpas_is_root) THEN + write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min + CALL CoLM_stop() + ENDIF + ENDIF + + dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1._r8/bst_kappa)) * (dtime/3600._r8) +#else + dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1/bst_kappa)) * (dtime/3600) +#endif + ! + !********** 2. WET SNOW AGING *********** + ! + ! We are assuming wet and dry evolution occur simultaneously, and + ! the contributions from both can be summed. + ! This is justified by setting the linear offset constant C1_liq_Brun89 to zero [Brun, 1989] + + ! liquid water faction + frc_liq = min(0.1_r8, (h2osno_liq(i) / (h2osno_liq(i)+h2osno_ice(i)))) + + !dr_wet = 1E6_r8*(dtime*(C1_liq_Brun89 + C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*(snw_rds(i)/1E6)**(2))) + !simplified, units of microns: + dr_wet = 1E18_r8*(dtime*(C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*snw_rds(i)**(2))) + + dr = dr + dr_wet + + ! + !********** 3. SNOWAGE SCALING (TURNED OFF BY DEFAULT) ************* + ! + ! Multiply rate of change of effective radius by some constant, xdrdt + IF (flg_snoage_scl) THEN + dr = dr*xdrdt + ENDIF + + ! + !********** 4. INCREMENT EFFECTIVE RADIUS, ACCOUNTING FOR: *********** + ! DRY AGING + ! WET AGING + ! FRESH SNOW + ! RE-FREEZING + ! + ! new snowfall [kg/m2] + IF (do_capsnow .and. .not. use_extrasnowlayers) THEN + newsnow = max(0._r8, (qflx_snwcp_ice*dtime)) + ELSE + newsnow = max(0._r8, (qflx_snow_grnd*dtime)) + ENDIF + + ! snow that has re-frozen [kg/m2] + refrzsnow = max(0._r8, (qflx_snofrz_lyr(i)*dtime)) + + ! fraction of layer mass that is re-frozen + frc_refrz = refrzsnow / h2osno_lyr + + ! fraction of layer mass that is new snow + IF (i == snl_top) THEN + frc_newsnow = newsnow / h2osno_lyr + ELSE + frc_newsnow = 0._r8 + ENDIF + + IF ((frc_refrz + frc_newsnow) > 1._r8) THEN + frc_refrz = frc_refrz / (frc_refrz + frc_newsnow) + frc_newsnow = 1._r8 - frc_refrz + frc_oldsnow = 0._r8 + ELSE + frc_oldsnow = 1._r8 - frc_refrz - frc_newsnow + ENDIF + + ! temperature dependent fresh grain size + snw_rds_fresh = FreshSnowRadius (forc_t) + + ! mass-weighted mean of fresh snow, old snow, and re-frozen snow effective radius + snw_rds(i) = (snw_rds(i)+dr)*frc_oldsnow + snw_rds_fresh*frc_newsnow + snw_rds_refrz*frc_refrz + ! + !********** 5. CHECK BOUNDARIES *********** + ! + ! boundary check + IF (snw_rds(i) < snw_rds_min) THEN + snw_rds(i) = snw_rds_min + ENDIF + + IF (snw_rds(i) > snw_rds_max) THEN + snw_rds(i) = snw_rds_max + ENDIF + + ! set top layer variables for history files + IF (i == snl_top) THEN + snot_top = t_soisno(i) + dTdz_top = dTdz(i) + snw_rds_top = snw_rds(i) + sno_liq_top = h2osno_liq(i) / (h2osno_liq(i)+h2osno_ice(i)) + ENDIF + + ENDDO + ENDIF ! ENDIF (snl < 0 ) + + ! Special CASE: snow on ground, but not enough to have defined a snow layer: + ! set snw_rds to fresh snow grain size: + + IF (snl >= 0 .and. h2osno > 0._r8) THEN + snw_rds(0) = snw_rds_min + ENDIF + + ! END associate + + END SUBROUTINE SnowAge_grain + !----------------------------------------------------------------------- + + + SUBROUTINE SnowOptics_init( fsnowoptics ) + + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=256), intent(in) :: fsnowoptics ! snow optical properties file name + character(len= 32) :: subname = 'SnowOptics_init' ! SUBROUTINE name + integer :: atm_type_index ! index for atmospheric type + + logical :: readvar ! determine IF variable was read from NetCDF file + !----------------------------------------------------------------------- + + readvar = .true. + + atm_type_index = atm_type_default + ! Define atmospheric type + IF (trim(snicar_atm_type) == 'default') THEN + atm_type_index = atm_type_default + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain + ELSE + IF (mpas_is_root) THEN + write(iulog,*) "snicar_atm_type = ", snicar_atm_type + CALL CoLM_stop() + ENDIF + ENDIF + + ! + ! Open optics file: + IF (mpas_is_root) THEN + write(iulog,*) 'Attempting to read snow optical properties .....' + write(iulog,*) subname,trim(fsnowoptics) + ENDIF + + ! direct-beam snow Mie parameters: + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ice_drc', ss_alb_snw_drc) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ice_drc', asm_prm_snw_drc) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ice_drc', ext_cff_mss_snw_drc) + + ! diffuse snow Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ice_dfs', ss_alb_snw_dfs) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ice_dfs', asm_prm_snw_dfs) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ice_dfs', ext_cff_mss_snw_dfs) + + !!! Direct and diffuse flux under different atmospheric conditions + ! Direct-beam incident spectral flux: + CALL ncio_read_bcast_serial (fsnowoptics, 'flx_wgt_dir', flx_wgt_dir) + + ! Diffuse incident spectral flux: + CALL ncio_read_bcast_serial (fsnowoptics, 'flx_wgt_dif', flx_wgt_dif) + +#ifdef MODAL_AER + ! size-dependent BC parameters and BC enhancement factors + IF (mpas_is_root) THEN + write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' + ENDIF + ! + ! BC species 1 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc1) + ! + ! BC species 2 Mie parameters (identical, before enhancement factors applied) + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc2) + ! + ! size-dependent BC absorption enhancement factors for within-ice BC + CALL ncio_read_bcast_serial (fsnowoptics, 'bcint_enh_mam', bcenh) + ! +#else + ! bulk aerosol treatment + ! BC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphil', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphil', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphil', ext_cff_mss_bc1) + + ! + ! BC species 2 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphob', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphob', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphob', ext_cff_mss_bc2) + ! +#endif + ! + ! OC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphil', ss_alb_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphil', asm_prm_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphil', ext_cff_mss_oc1) + ! + ! OC species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphob', ss_alb_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphob', asm_prm_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphob', ext_cff_mss_oc2) + ! + ! dust species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust01', ss_alb_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust01', asm_prm_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust01', ext_cff_mss_dst1) + ! + ! dust species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust02', ss_alb_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust02', asm_prm_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust02', ext_cff_mss_dst2) + ! + ! dust species 3 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust03', ss_alb_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust03', asm_prm_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust03', ext_cff_mss_dst3) + ! + ! dust species 4 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust04', ss_alb_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust04', asm_prm_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust04', ext_cff_mss_dst4) + ! + ! + + IF (mpas_is_root) THEN + write(iulog,*) 'Successfully read snow optical properties' + ENDIF + + + ! print some diagnostics: + IF (mpas_is_root) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & + ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & + ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for diffuse ice, rds=100um: ', & + ss_alb_snw_dfs(71,1), ss_alb_snw_dfs(71,2), ss_alb_snw_dfs(71,3), & + ss_alb_snw_dfs(71,4), ss_alb_snw_dfs(71,5) + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Including OC aerosols from snow radiative transfer calculations' + ELSE + write (iulog,*) 'SNICAR: Excluding OC aerosols from snow radiative transfer calculations' + ENDIF + ENDIF + ! +#ifdef MODAL_AER + IF (mpas_is_root) THEN + ! unique dimensionality for modal aerosol optical properties + write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & + ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of Mie mass extinction coefficients for BC: ', & + ext_cff_mss_bc2(1,1), ext_cff_mss_bc2(1,2), ext_cff_mss_bc2(2,1), ext_cff_mss_bc2(5,1), ext_cff_mss_bc2(1,10),& + ext_cff_mss_bc1(1,10) + write (iulog,*) 'SNICAR: Subset of Mie asymmetry parameters for BC: ', & + asm_prm_bc1(1,1), asm_prm_bc1(1,2), asm_prm_bc1(2,1), asm_prm_bc1(5,1), asm_prm_bc1(1,10), asm_prm_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of BC absorption enhancement factors: ', & + bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) + ENDIF +#else + IF (mpas_is_root) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & + ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & + ss_alb_bc2(1), ss_alb_bc2(2), ss_alb_bc2(3), ss_alb_bc2(4), ss_alb_bc2(5) + ENDIF +#endif + + IF (mpas_is_root) THEN + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & + ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic OC: ', & + ss_alb_oc2(1), ss_alb_oc2(2), ss_alb_oc2(3), ss_alb_oc2(4), ss_alb_oc2(5) + ENDIF + + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 1: ', & + ss_alb_dst1(1), ss_alb_dst1(2), ss_alb_dst1(3), ss_alb_dst1(4), ss_alb_dst1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 2: ', & + ss_alb_dst2(1), ss_alb_dst2(2), ss_alb_dst2(3), ss_alb_dst2(4), ss_alb_dst2(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 3: ', & + ss_alb_dst3(1), ss_alb_dst3(2), ss_alb_dst3(3), ss_alb_dst3(4), ss_alb_dst3(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 4: ', & + ss_alb_dst4(1), ss_alb_dst4(2), ss_alb_dst4(3), ss_alb_dst4(4), ss_alb_dst4(5) + write(iulog,*) + ENDIF + + END SUBROUTINE SnowOptics_init + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_init( fsnowaging ) + + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=256), intent(in) :: fsnowaging ! snow aging parameters file name + character(len= 32) :: subname = 'SnowAge_init' ! SUBROUTINE name + ! + ! Open snow aging (effective radius evolution) file: + IF (mpas_is_root) THEN + write(iulog,*) 'Attempting to read snow aging parameters .....' + write(iulog,*) subname,trim(fsnowaging) + ENDIF + + ! + ! SNOW aging parameters + ! + CALL ncio_read_bcast_serial (fsnowaging, 'tau', snowage_tau) + CALL ncio_read_bcast_serial (fsnowaging, 'kappa', snowage_kappa) + CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) + + ! + IF (mpas_is_root) THEN + write(iulog,*) 'Successfully read snow aging properties' + ENDIF + ! + ! print some diagnostics: + IF (mpas_is_root) THEN + write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) + write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) + write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) + ENDIF + + END SUBROUTINE SnowAge_init + !----------------------------------------------------------------------- + + + real(r8) FUNCTION FreshSnowRadius (forc_t) +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Returns fresh snow grain radius, which is linearly dependent on temperature. +! This is implemented to remedy an outstanding bias that SNICAR has in initial +! grain size. See e.g. Sandells et al, 2017 for a discussion (10.5194/tc-11-229-2017). +! +! Yang et al. (2017), 10.1016/j.jqsrt.2016.03.033 +! discusses grain size observations, which suggest a temperature dependence. +! +! !REVISION HISTORY: +! Author: Leo VanKampenhout +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Const_Physical, only: tfrz + USE MOD_Aerosol, only: fresh_snw_rds_max + + ! !ARGUMENTS: + real(r8), intent(in) :: forc_t ! atmospheric temperature (Kelvin) + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + real(r8), parameter :: tmin = tfrz - 30._r8 ! start of linear ramp + real(r8), parameter :: tmax = tfrz - 0._r8 ! END of linear ramp + real(r8), parameter :: gs_min = snw_rds_min ! minimum value + real(r8) :: gs_max ! maximum value + + IF ( fresh_snw_rds_max <= snw_rds_min )THEN + FreshSnowRadius = snw_rds_min + ELSE + gs_max = fresh_snw_rds_max + + IF (forc_t < tmin) THEN + FreshSnowRadius = gs_min + ELSEIF (forc_t > tmax) THEN + FreshSnowRadius = gs_max + ELSE + FreshSnowRadius = (tmax-forc_t)/(tmax-tmin)*gs_min + & + (forc_t-tmin)/(tmax-tmin)*gs_max + ENDIF + ENDIF + + END FUNCTION FreshSnowRadius + +END MODULE MOD_SnowSnicar +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 new file mode 100644 index 0000000000..808626426b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SnowSnicar_HiRes.F90 @@ -0,0 +1,2994 @@ +#include + +!------------------------------------------------------------------------- +MODULE MOD_SnowSnicar_HiRes + + !----------------------------------------------------------------------- + ! DESCRIPTION: + ! Calculate albedo of snow containing impurities + ! and the evolution of snow effective radius + ! + ! ORIGINAL: + ! 1) The Community Land Model version 5.0 (CLM5.0) + ! 2) Energy Exascale Earth System Model version 2.0 (E3SM v2.0) Land Model (ELM v2.0) + ! + ! REFERENCES: + ! 1) Flanner et al, 2021, SNICAR-ADv3: a community tool for modeling spectral snow albedo. + ! Geosci. Model Dev., 14, 7673–7704, https://doi.org/10.5194/gmd-14-7673-2021 + ! 2) Hao et al., 2023, Improving snow albedo modeling in the E3SM land model (version 2.0) + ! and assessing its impacts on snow and surface fluxes over the Tibetan Plateau. + ! Geosci. Model Dev., 16, 75–94, https://doi.org/10.5194/gmd-16-75-2023 + ! + ! REVISIONS: + ! Yongjiu Dai, and Hua Yuan, December, 2022 : ASSEMBLING and FITTING + ! + ! !USES: + USE MOD_Precision + USE MOD_Vars_Global, only: maxsnl + USE MOD_MPAS_MPI + + IMPLICIT NONE +! SAVE + real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 + real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice (kg/m^3) + + integer, parameter :: iulog = 6 ! "stdout" log file unit number, default is 6 + integer, parameter :: numrad = 5 ! number of solar radiation bands: vis, nir + +!-------------------------------------------------------------------- +! DAI, Dec. 29, 2022 +! Temporay setting + + logical, parameter :: use_extrasnowlayers = .false. + character(len=256), parameter :: snow_shape = 'sphere' ! (=1), 'spheroid'(=2), 'hexagonal_plate'(=3), 'koch_snowflake'(=4) + logical, parameter :: use_dust_snow_internal_mixing = .false. + character(len=256), parameter :: snicar_atm_type = 'default' ! Atmospheric profile used to obtain surface-incident spectral flux distribution + ! and subsequent broadband albedo + ! = 'mid-latitude_winter' ! => 1 + ! = 'mid-latitude_summer' ! => 2 + ! = 'sub-Arctic_winter' ! => 3 + ! = 'sub-Arctic_summer' ! => 4 + ! = 'summit_Greenland' ! => 5 (sub-Arctic summer, surface pressure of 796hPa) + ! = 'high_mountain' ! => 6 (summer, surface pressure of 556 hPa) +!DAI, Dec. 29, 2022 +!----------------------------------------------------------------------- + + ! !PUBLIC MEMBER FUNCTIONS: + PUBLIC :: SNICAR_RT ! Snow albedo and vertically-resolved solar absorption + PUBLIC :: SNICAR_AD_RT ! Snow albedo and vertically-resolved solar absorption by adding-doubling solution + ! To USE this subtroutine, set use_snicar_ad = true + PUBLIC :: SnowAge_grain ! Snow effective grain size evolution + PUBLIC :: SnowAge_init ! Initial read in of snow-aging file + PUBLIC :: SnowOptics_init ! Initial read in of snow-optics file + ! + ! !PUBLIC DATA MEMBERS: + integer, PUBLIC, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack + ! (indices described above) [nbr] + logical, PUBLIC, parameter :: DO_SNO_OC = .false. ! parameter to include organic carbon (OC) + ! in snowpack radiative calculations + logical, PUBLIC, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations + ! !PRIVATE DATA MEMBERS: + integer, parameter :: numrad_snw = 5 ! number of spectral bands used in snow model [nbr] + integer, parameter :: nir_bnd_bgn = 2 ! first band index in near-IR spectrum [idx] + integer, parameter :: nir_bnd_end = 5 ! ending near-IR band index [idx] + integer, parameter :: idx_Mie_snw_mx = 1471 ! number of effective radius indices used in Mie lookup table [idx] + integer, parameter :: idx_T_max = 11 ! maxiumum temperature index used in aging lookup table [idx] + integer, parameter :: idx_T_min = 1 ! minimum temperature index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_max = 31 ! maxiumum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_Tgrd_min = 1 ! minimum temperature gradient index used in aging lookup table [idx] + integer, parameter :: idx_rhos_max = 8 ! maxiumum snow density index used in aging lookup table [idx] + integer, parameter :: idx_rhos_min = 1 ! minimum snow density index used in aging lookup table [idx] + +#ifdef MODAL_AER + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + !mgf++ + integer, parameter :: idx_bc_nclrds_min = 1 ! minimum index for BC particle size in optics lookup table + integer, parameter :: idx_bc_nclrds_max = 10 ! maximum index for BC particle size in optics lookup table + integer, parameter :: idx_bcint_icerds_min = 1 ! minimum index for snow grain size in optics lookup table for within-ice BC + integer, parameter :: idx_bcint_icerds_max = 8 ! maximum index for snow grain size in optics lookup table for within-ice BC + !mgf-- +#endif + + integer, parameter :: snw_rds_max_tbl = 1500 ! maximum effective radius defined in Mie lookup table [microns] + integer, parameter :: snw_rds_min_tbl = 30 ! minimium effective radius defined in Mie lookup table [microns] + real(r8), parameter :: snw_rds_max = 1500._r8 ! maximum allowed snow effective radius [microns] + real(r8), parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also "fresh snow" value) [microns + real(r8), parameter :: snw_rds_refrz = 1000._r8 ! effective radius of re-frozen snow [microns] + real(r8), parameter :: min_snw = 1.0E-30_r8 ! minimum snow mass required for SNICAR RT calculation [kg m-2] + !real(r8), parameter :: C1_liq_Brun89 = 1.28E-17_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89 + real(r8), parameter :: C1_liq_Brun89 = 0._r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: zeroed to accomodate dry snow aging + real(r8), parameter :: C2_liq_Brun89 = 4.22E-13_r8 ! constant for liquid water grain growth [m3 s-1], + ! from Brun89: corrected for LWC in units of percent + + real(r8), parameter :: tim_cns_bc_rmv = 2.2E-8_r8 ! time constant for removal of BC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_oc_rmv = 2.2E-8_r8 ! time constant for removal of OC in snow on sea-ice + ! [s-1] (50% mass removal/year) + real(r8), parameter :: tim_cns_dst_rmv = 2.2E-8_r8 ! time constant for removal of dust in snow on sea-ice + ! [s-1] (50% mass removal/year) + !$acc declare copyin(C1_liq_Brun89, C2_liq_Brun89, & + !$acc tim_cns_bc_rmv, tim_cns_oc_rmv, tim_cns_dst_rmv) + + ! scaling of the snow aging rate (tuning option): + logical :: flg_snoage_scl = .false. ! flag for scaling the snow aging rate by some arbitrary factor + real(r8), parameter :: xdrdt = 1.0_r8 ! arbitrary factor applied to snow aging rate + ! snow and aerosol Mie parameters: + ! (arrays declared here, but are set in iniTimeConst) + ! (idx_Mie_snw_mx is number of snow radii with defined parameters (i.e. from 30um to 1500um)) + + ! direct-beam weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_drc (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_drc(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! diffuse radiation weighted ice optical properties + real(r8), allocatable :: ss_alb_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: asm_prm_snw_dfs (:,:) ! (idx_Mie_snw_mx,numrad_snw); + real(r8), allocatable :: ext_cff_mss_snw_dfs(:,:) ! (idx_Mie_snw_mx,numrad_snw); + + ! direct & diffuse flux + real(r8), allocatable :: flx_wgt_dir (:,:,:) ! (6, 90, numrad_snw) ! direct flux, six atmospheric types, 0-89 SZA + real(r8), allocatable :: flx_wgt_dif (:,:) ! (6, numrad_snw) ! diffuse flux, six atmospheric types + + ! snow grain shape + integer, parameter :: snow_shape_sphere = 1 + integer, parameter :: snow_shape_spheroid = 2 + integer, parameter :: snow_shape_hexagonal_plate = 3 + integer, parameter :: snow_shape_koch_snowflake = 4 + + ! atmospheric condition for SNICAR-AD + integer, parameter :: atm_type_default = 0 + integer, parameter :: atm_type_mid_latitude_winter = 1 + integer, parameter :: atm_type_mid_latitude_summer = 2 + integer, parameter :: atm_type_sub_Arctic_winter = 3 + integer, parameter :: atm_type_sub_Arctic_summer = 4 + integer, parameter :: atm_type_summit_Greenland = 5 + integer, parameter :: atm_type_high_mountain = 6 + +#ifdef MODAL_AER + !mgf++ + ! Size-dependent BC optical properties. Currently a fixed BC size is + ! assumed, but this framework enables optical properties to be + ! assigned based on the BC effective radius, should this be + ! implemented in the future. + ! + ! within-ice BC (i.e., BC that was deposited within hydrometeors) + real(r8), allocatable :: ss_alb_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc1 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc1(:,:) ! (numrad_snw,idx_bc_nclrds_max); + + ! external BC + real(r8), allocatable :: ss_alb_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: asm_prm_bc2 (:,:) ! (numrad_snw,idx_bc_nclrds_max); + real(r8), allocatable :: ext_cff_mss_bc2(:,:) ! (numrad_snw,idx_bc_nclrds_max); + !mgf-- +#else + ! hydrophiliic BC + real(r8), allocatable :: ss_alb_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc1(:) ! (numrad_snw); + + ! hydrophobic BC + real(r8), allocatable :: ss_alb_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_bc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_bc2(:) ! (numrad_snw); +#endif + + ! hydrophobic OC + real(r8), allocatable :: ss_alb_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc1(:) ! (numrad_snw); + + ! hydrophilic OC + real(r8), allocatable :: ss_alb_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_oc2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_oc2(:) ! (numrad_snw); + + ! dust species 1: + real(r8), allocatable :: ss_alb_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst1 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst1(:) ! (numrad_snw); + + ! dust species 2: + real(r8), allocatable :: ss_alb_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst2 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst2(:) ! (numrad_snw); + + ! dust species 3: + real(r8), allocatable :: ss_alb_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst3 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst3(:) ! (numrad_snw); + + ! dust species 4: + real(r8), allocatable :: ss_alb_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: asm_prm_dst4 (:) ! (numrad_snw); + real(r8), allocatable :: ext_cff_mss_dst4(:) ! (numrad_snw); + +#ifdef MODAL_AER + ! Absorption enhancement factors for within-ice BC + real(r8), allocatable :: bcenh (:,:,:) ! (numrad_snw,idx_bc_nclrds_max,idx_bcint_icerds_max); +#endif + + ! best-fit parameters for snow aging defined over: + ! 11 temperatures from 225 to 273 K + ! 31 temperature gradients from 0 to 300 K/m + ! 8 snow densities from 0 to 350 kg/m3 + ! (arrays declared here, but are set in iniTimeConst) + ! + real(r8), allocatable :: snowage_tau (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [hour] + real(r8), allocatable :: snowage_kappa (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [unitless] + real(r8), allocatable :: snowage_drdt0 (:,:,:) ! (idx_rhos_max,idx_Tgrd_max,idx_T_max) ! snow aging parameter retrieved from lookup table [um hr-1] + + ! + ! !REVISION HISTORY: + ! Created by Mark Flanner + !----------------------------------------------------------------------- + +CONTAINS + + !----------------------------------------------------------------------- + SUBROUTINE SNICAR_RT (flg_snw_ice, flg_slr_in, & + coszen, snl, h2osno, frac_sno, & + h2osno_liq, h2osno_ice, snw_rds, & + mss_cnc_aer_in, albsfc, albout, flx_abs) + ! + ! !DESCRIPTION: + ! Determine reflectance of, and vertically-resolved solar absorption in, + ! snow with impurities. + ! + ! Original references on physical models of snow reflectance include: + ! Wiscombe and Warren [1980] and Warren and Wiscombe [1980], + ! Journal of Atmospheric Sciences, 37, + ! + ! The multi-layer solution for multiple-scattering used here is from: + ! Toon et al. [1989], Rapid calculation of radiative heating rates + ! and photodissociation rates in inhomogeneous multiple scattering atmospheres, + ! J. Geophys. Res., 94, D13, 16287-16301 + ! + ! The implementation of the SNICAR model in CLM/CSIM is described in: + ! Flanner, M., C. Zender, J. Randerson, and P. Rasch [2007], + ! Present-day climate forcing and response from black carbon in snow, + ! J. Geophys. Res., 112, D11202, doi: 10.1029/2006JD008003 + ! + ! !USES: + ! + ! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + +#ifdef MODAL_AER + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- +#endif + + + ! Other local variables + integer :: APRX_TYP ! two-stream approximation type + ! (1=Eddington, 2=Quadrature, 3=Hemispheric Mean) [nbr] + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: n ! tridiagonal matrix index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_direct(maxsnl+1:0) ! direct-beam radiation at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_net(maxsnl+1:0) ! net radiative flux at bottom of layer interface (lyr) [W/m^2] + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: F_sfc_net ! net flux at top of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: F_direct_btm ! direct-beam radiation at bottom of snowpack [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + ! intermediate variables for radiative transfer approximation: + real(r8):: gamma1(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma2(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma3(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: gamma4(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: lambda(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: GAMMA(maxsnl+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: mu_one ! two-stream coefficient from Toon et al. (lyr) [unitless] + real(r8):: e1(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e2(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e3(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: e4(maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (lyr) + real(r8):: C_pls_btm(maxsnl+1:0) ! intermediate variable: upward flux at bottom interface (lyr) [W/m2] + real(r8):: C_mns_btm(maxsnl+1:0) ! intermediate variable: downward flux at bottom interface (lyr) [W/m2] + real(r8):: C_pls_top(maxsnl+1:0) ! intermediate variable: upward flux at top interface (lyr) [W/m2] + real(r8):: C_mns_top(maxsnl+1:0) ! intermediate variable: downward flux at top interface (lyr) [W/m2] + real(r8):: A(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: B(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: D(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: E(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: AS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: DS(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: X(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + real(r8):: Y(2*maxsnl+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr) + !----------------------------------------------------------------------- +#ifdef MODAL_AER + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- +#endif + + ! Enforce expected array sizes + + ! associate(& + ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:)] snow liquid water equivalent (col) [kg/m2] + ! frac_sno => col_ws%frac_sno_eff & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) + ! ) + + ! Define constants + pi = SHR_CONST_PI + nint_snw_rds_min = nint(snw_rds_min) + + ! always USE Delta approximation for snow + DELTA = 1 + + ! (when called from CSIM, there is only one column) + + ! Zero absorbed radiative fluxes: + DO i=maxsnl+1,1,1 + flx_abs_lcl(:,:) = 0._r8 + flx_abs(i,:) = 0._r8 + ENDDO + + ! set snow/ice mass to be used for RT: + IF (flg_snw_ice == 1) THEN + h2osno_lcl = h2osno + ELSE + h2osno_lcl = h2osno_ice(0) + ENDIF + + ! Qualifier for computing snow RT: + ! 1) sunlight from atmosphere model + ! 2) minimum amount of snow on ground. + ! Otherwise, set snow albedo to zero + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw)) THEN + + ! Set variables specific to CLM + IF (flg_snw_ice == 1) THEN + ! If there is snow, but zero snow layers, we must create a layer locally. + ! This layer is presumed to have the fresh snow effective radius. + IF (snl > -1) THEN + flg_nosnl = 1 + snl_lcl = -1 + h2osno_ice_lcl(0) = h2osno_lcl + h2osno_liq_lcl(0) = 0._r8 + snw_rds_lcl(0) = nint_snw_rds_min + ELSE + flg_nosnl = 0 + snl_lcl = snl + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + ENDIF + + snl_btm = 0 + snl_top = snl_lcl+1 + + ! Set variables specific to CSIM + ELSE + flg_nosnl = 0 + snl_lcl = -1 + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + snl_btm = 0 + snl_top = 0 + ENDIF + +#ifdef MODAL_AER + !mgf++ + ! + ! Assume fixed BC effective radii of 100nm. This is close to + ! the effective radius of 95nm (number median radius of + ! 40nm) assumed for freshly-emitted BC in MAM. Future + ! implementations may prognose the BC effective radius in + ! snow. + rds_bcint_lcl(:) = 100._r8 + rds_bcext_lcl(:) = 100._r8 + !mgf-- +#endif + + ! Set local aerosol array + DO j=1,sno_nbr_aer + mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) + ENDDO + + + ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos + albsfc_lcl(1) = albsfc(1) + albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) + + + ! Error check for snow grain size: +#ifndef _OPENACC + IF (mpas_is_root) THEN + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN + write (iulog,*) "SNICAR ERROR: snow grain radius of out of bounds." + write (iulog,*) "flg_snw_ice= ", flg_snw_ice + write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl + write (iulog,*) "h2osno(c)= ", h2osno_lcl + CALL CoLM_stop('SNICAR encountered inconsistent snow-layer state.') + ENDIF + ENDDO + ENDIF +#endif + + ! Incident flux weighting parameters + ! - sum of all VIS bands must equal 1 + ! - sum of all NIR bands must equal 1 + ! + ! Spectral bands (5-band CASE) + ! Band 1: 0.3-0.7um (VIS) + ! Band 2: 0.7-1.0um (NIR) + ! Band 3: 1.0-1.2um (NIR) + ! Band 4: 1.2-1.5um (NIR) + ! Band 5: 1.5-5.0um (NIR) + ! + ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere + ! + ! 3-band weights + IF (numrad_snw==3) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.66628670195247_r8 + flx_wgt(3) = 0.33371329804753_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.77887652162877_r8 + flx_wgt(3) = 0.22112347837123_r8 + ENDIF + + ! 5-band weights + ELSEIF(numrad_snw==5) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.49352158521175_r8 + flx_wgt(3) = 0.18099494230665_r8 + flx_wgt(4) = 0.12094898498813_r8 + flx_wgt(5) = 0.20453448749347_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.58581507618433_r8 + flx_wgt(3) = 0.20156903770812_r8 + flx_wgt(4) = 0.10917889346386_r8 + flx_wgt(5) = 0.10343699264369_r8 + ENDIF + ENDIF + + ! Loop over snow spectral bands + DO bnd_idx = 1,numrad_snw + + mu_not = coszen ! must set here, because of error handling + flg_dover = 1 ! default is to redo + err_idx = 0 ! number of times through loop + + DO WHILE (flg_dover > 0) + + ! DEFAULT APPROXIMATIONS: + ! VIS: Delta-Eddington + ! NIR (all): Delta-Hemispheric Mean + ! WARNING: DO NOT USE DELTA-EDDINGTON FOR NIR DIFFUSE - this sometimes results in negative albedo + ! + ! ERROR CONDITIONS: + ! Conditions which cause "trip", resulting in redo of RT approximation: + ! 1. negative absorbed flux + ! 2. total absorbed flux greater than incident flux + ! 3. negative albedo + ! NOTE: These errors have only been encountered in spectral bands 4 and 5 + ! + ! ERROR HANDLING + ! 1st error (flg_dover=2): switch approximation (Edd->HM or HM->Edd) + ! 2nd error (flg_dover=3): change zenith angle by 0.02 (this happens about 1 in 10^6 cases) + ! 3rd error (flg_dover=4): switch approximation with new zenith + ! Subsequent errors: repeatedly change zenith and approximations... + + IF (bnd_idx == 1) THEN + IF (flg_dover == 2) THEN + APRX_TYP = 3 + ELSEIF (flg_dover == 3) THEN + APRX_TYP = 1 + IF (coszen > 0.5_r8) THEN + mu_not = mu_not - 0.02_r8 + ELSE + mu_not = mu_not + 0.02_r8 + ENDIF + ELSEIF (flg_dover == 4) THEN + APRX_TYP = 3 + ELSE + APRX_TYP = 1 + ENDIF + + ELSE + IF (flg_dover == 2) THEN + APRX_TYP = 1 + ELSEIF (flg_dover == 3) THEN + APRX_TYP = 3 + IF (coszen > 0.5_r8) THEN + mu_not = mu_not - 0.02_r8 + ELSE + mu_not = mu_not + 0.02_r8 + ENDIF + ELSEIF (flg_dover == 4) THEN + APRX_TYP = 1 + ELSE + APRX_TYP = 3 + ENDIF + + ENDIF + + ! Set direct or diffuse incident irradiance to 1 + ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) + IF (flg_slr_in == 1) THEN + flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 + flx_slri_lcl(bnd_idx) = 0._r8 + ELSE + flx_slrd_lcl(bnd_idx) = 0._r8 + flx_slri_lcl(bnd_idx) = 1._r8 + ENDIF + + ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. + ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + ! Define local Mie parameters based on snow grain size and aerosol species, + ! retrieved from a lookup table. + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (direct radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) + ENDDO + ELSEIF (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (diffuse radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) + ENDDO + ENDIF + +!H. Wang + ! aerosol species 1 optical properties + ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +!H. Wang + ! aerosol species 3 optical properties + ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) + asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) + ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) + + ! aerosol species 4 optical properties + ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) + asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) + ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) + + ! aerosol species 5 optical properties + ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) + asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) + ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) + + ! aerosol species 6 optical properties + ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) + asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) + ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) + + ! aerosol species 7 optical properties + ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) + asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) + ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) + + ! aerosol species 8 optical properties + ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) + asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) + ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) + + + ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) + ! 2. optical Depths (tau_snw, tau_aer) + ! 3. weighted Mie properties (tau, omega, g) + + ! Weighted Mie parameters of each layer + DO i=snl_top,snl_btm,1 +#ifdef MODAL_AER + !mgf++ within-ice and external BC optical properties + ! + ! Lookup table indices for BC optical properties, + ! dependent on snow grain size and BC particle + ! size. + + ! valid for 25 < snw_rds < 1625 um: + IF (snw_rds_lcl(i) < 125) THEN + tmp1 = snw_rds_lcl(i)/50 + idx_bcint_icerds = nint(tmp1) + ELSEIF (snw_rds_lcl(i) < 175) THEN + idx_bcint_icerds = 2 + ELSE + tmp1 = (snw_rds_lcl(i)/250)+2 + idx_bcint_icerds = nint(tmp1) + ENDIF + + ! valid for 25 < bc_rds < 525 nm + idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) + idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) + + ! check bounds: + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + + ! retrieve absorption enhancement factor for within-ice BC + enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) + + ! get BC optical properties (moved from above) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct + + ! aerosol species 2 optical properties (external BC) + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) + +#else + ! bulk aerosol treatment (BC optical properties independent + ! of BC and ice grain size) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +#endif + !mgf-- + + L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) + tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) + + DO j=1,sno_nbr_aer + L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) + tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) + ENDDO + + tau_sum = 0._r8 + omega_sum = 0._r8 + g_sum = 0._r8 + + DO j=1,sno_nbr_aer + tau_sum = tau_sum + tau_aer(i,j) + omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) + g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) + ENDDO + + tau(i) = tau_sum + tau_snw(i) + omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) + g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) + ENDDO + + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 + g_star(i) = g(i)/(1+g(i)) + omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) + tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) + ENDDO + ELSE + DO i=snl_top,snl_btm,1 + g_star(i) = g(i) + omega_star(i) = omega(i) + tau_star(i) = tau(i) + ENDDO + ENDIF + + ! Total column optical depth: + ! tau_elm(i) = total optical depth above the bottom of layer i + tau_elm(snl_top) = 0._r8 + DO i=snl_top+1,snl_btm,1 + tau_elm(i) = tau_elm(i-1)+tau_star(i-1) + ENDDO + + ! Direct radiation at bottom of snowpack: + F_direct_btm = albsfc_lcl(bnd_idx)*mu_not * & + exp(-(tau_elm(snl_btm)+tau_star(snl_btm))/mu_not)*pi*flx_slrd_lcl(bnd_idx) + + ! Intermediates + ! Gamma values are approximation-specific. + + ! Eddington + IF (APRX_TYP==1) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = (7-(omega_star(i)*(4+(3*g_star(i)))))/4 + gamma2(i) = -(1-(omega_star(i)*(4-(3*g_star(i)))))/4 + gamma3(i) = (2-(3*g_star(i)*mu_not))/4 + gamma4(i) = 1-gamma3(i) + mu_one = 0.5 + ENDDO + + ! Quadrature + ELSEIF (APRX_TYP==2) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = (3**0.5)*(2-(omega_star(i)*(1+g_star(i))))/2 + gamma2(i) = omega_star(i)*(3**0.5)*(1-g_star(i))/2 + gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 + gamma4(i) = 1-gamma3(i) + mu_one = 1/(3**0.5) + ENDDO + + ! Hemispheric Mean + ELSEIF (APRX_TYP==3) THEN + DO i=snl_top,snl_btm,1 + gamma1(i) = 2 - (omega_star(i)*(1+g_star(i))) + gamma2(i) = omega_star(i)*(1-g_star(i)) + gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2 + gamma4(i) = 1-gamma3(i) + mu_one = 0.5 + ENDDO + ENDIF + + ! Intermediates for tri-diagonal solution + DO i=snl_top,snl_btm,1 + lambda(i) = sqrt(abs((gamma1(i)**2) - (gamma2(i)**2))) + GAMMA(i) = gamma2(i)/(gamma1(i)+lambda(i)) + + e1(i) = 1+(GAMMA(i)*exp(-lambda(i)*tau_star(i))) + e2(i) = 1-(GAMMA(i)*exp(-lambda(i)*tau_star(i))) + e3(i) = GAMMA(i) + exp(-lambda(i)*tau_star(i)) + e4(i) = GAMMA(i) - exp(-lambda(i)*tau_star(i)) + ENDDO !ENDDO over snow layers + + ! Intermediates for tri-diagonal solution + DO i=snl_top,snl_btm,1 + IF (flg_slr_in == 1) THEN + + C_pls_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-(tau_elm(i)+tau_star(i))/mu_not)* & + (((gamma1(i)-(1/mu_not))*gamma3(i))+ & + (gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_mns_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-(tau_elm(i)+tau_star(i))/mu_not)* & + (((gamma1(i)+(1/mu_not))*gamma4(i))+ & + (gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_pls_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-tau_elm(i)/mu_not)*(((gamma1(i)-(1/mu_not))* & + gamma3(i))+(gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + C_mns_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* & + exp(-tau_elm(i)/mu_not)*(((gamma1(i)+(1/mu_not))* & + gamma4(i))+(gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2))) + + ELSE + C_pls_btm(i) = 0._r8 + C_mns_btm(i) = 0._r8 + C_pls_top(i) = 0._r8 + C_mns_top(i) = 0._r8 + ENDIF + ENDDO + + ! Coefficients for tridiaganol matrix solution + DO i=2*snl_lcl+1,0,1 + + !Boundary values for i=1 and i=2*snl_lcl, specifics for i=odd and i=even + IF (i==(2*snl_lcl+1)) THEN + A(i) = 0 + B(i) = e1(snl_top) + D(i) = -e2(snl_top) + E(i) = flx_slri_lcl(bnd_idx)-C_mns_top(snl_top) + + ELSEIF(i==0) THEN + A(i) = e1(snl_btm)-(albsfc_lcl(bnd_idx)*e3(snl_btm)) + B(i) = e2(snl_btm)-(albsfc_lcl(bnd_idx)*e4(snl_btm)) + D(i) = 0 + E(i) = F_direct_btm-C_pls_btm(snl_btm)+(albsfc_lcl(bnd_idx)*C_mns_btm(snl_btm)) + + ELSEIF(mod(i,2)==-1) THEN ! If odd and i>=3 (n=1 for i=3) + n=floor(i/2.0) + A(i) = (e2(n)*e3(n))-(e4(n)*e1(n)) + B(i) = (e1(n)*e1(n+1))-(e3(n)*e3(n+1)) + D(i) = (e3(n)*e4(n+1))-(e1(n)*e2(n+1)) + E(i) = (e3(n)*(C_pls_top(n+1)-C_pls_btm(n)))+(e1(n)*(C_mns_btm(n)-C_mns_top(n+1))) + + ELSEIF(mod(i,2)==0) THEN ! If even and i<=2*snl_lcl + n=(i/2) + A(i) = (e2(n+1)*e1(n))-(e3(n)*e4(n+1)) + B(i) = (e2(n)*e2(n+1))-(e4(n)*e4(n+1)) + D(i) = (e1(n+1)*e4(n+1))-(e2(n+1)*e3(n+1)) + E(i) = (e2(n+1)*(C_pls_top(n+1)-C_pls_btm(n)))+(e4(n+1)*(C_mns_top(n+1)-C_mns_btm(n))) + ENDIF + ENDDO + + AS(0) = A(0)/B(0) + DS(0) = E(0)/B(0) + + DO i=-1,(2*snl_lcl+1),-1 + X(i) = 1/(B(i)-(D(i)*AS(i+1))) + AS(i) = A(i)*X(i) + DS(i) = (E(i)-(D(i)*DS(i+1)))*X(i) + ENDDO + + Y(2*snl_lcl+1) = DS(2*snl_lcl+1) + DO i=(2*snl_lcl+2),0,1 + Y(i) = DS(i)-(AS(i)*Y(i-1)) + ENDDO + + ! Downward direct-beam and net flux (F_net) at the base of each layer: + DO i=snl_top,snl_btm,1 + F_direct(i) = mu_not*pi*flx_slrd_lcl(bnd_idx)*exp(-(tau_elm(i)+tau_star(i))/mu_not) + F_net(i) = (Y(2*i-1)*(e1(i)-e3(i))) + (Y(2*i)*(e2(i)-e4(i))) + & + C_pls_btm(i) - C_mns_btm(i) - F_direct(i) + ENDDO + + ! Upward flux at snowpack top: + F_sfc_pls = (Y(2*snl_lcl+1)*(exp(-lambda(snl_top)*tau_star(snl_top))+ & + GAMMA(snl_top))) + (Y(2*snl_lcl+2)*(exp(-lambda(snl_top)* & + tau_star(snl_top))-GAMMA(snl_top))) + C_pls_top(snl_top) + + ! Net flux at bottom = absorbed radiation by underlying surface: + F_btm_net = -F_net(snl_btm) + + + ! Bulk column albedo and surface net flux + albedo = F_sfc_pls/((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx)) + F_sfc_net = F_sfc_pls - ((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx)) + + trip = 0 + ! Absorbed flux in each layer + DO i=snl_top,snl_btm,1 + IF(i==snl_top) THEN + F_abs(i) = F_net(i)-F_sfc_net + ELSE + F_abs(i) = F_net(i)-F_net(i-1) + ENDIF + flx_abs_lcl(i,bnd_idx) = F_abs(i) + + + ! ERROR check: negative absorption + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN + trip = 1 + ENDIF + ENDDO + + flx_abs_lcl(1,bnd_idx) = F_btm_net + + IF (flg_nosnl == 1) THEN + ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer + !flx_abs_lcl(:,bnd_idx) = 0._r8 + !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net + + ! changed on 20070408: + ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and + ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. + flx_abs_lcl(0,bnd_idx) = F_abs(0) + flx_abs_lcl(1,bnd_idx) = F_btm_net + + ENDIF + + !Underflow check (we've already tripped the error condition above) + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN + flx_abs_lcl(i,bnd_idx) = 0._r8 + ENDIF + ENDDO + + F_abs_sum = 0._r8 + DO i=snl_top,snl_btm,1 + F_abs_sum = F_abs_sum + F_abs(i) + ENDDO + + + !ERROR check: absorption greater than incident flux + ! (should make condition more generic than "1._r8") + IF (F_abs_sum > 1._r8) THEN + trip = 1 + ENDIF + + !ERROR check: + IF ((albedo < 0._r8).and.(trip==0)) THEN + trip = 1 + ENDIF + + ! Set conditions for redoing RT calculation + IF ((trip == 1).and.(flg_dover == 1)) THEN + flg_dover = 2 + ELSEIF ((trip == 1).and.(flg_dover == 2)) THEN + flg_dover = 3 + ELSEIF ((trip == 1).and.(flg_dover == 3)) THEN + flg_dover = 4 + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx < 20)) THEN + flg_dover = 3 + err_idx = err_idx + 1 + ELSEIF((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) THEN + flg_dover = 0 +#ifndef _OPENACC + IF (mpas_is_root) THEN + write(iulog,*) "SNICAR ERROR: FOUND A WORMHOLE. STUCK IN INFINITE LOOP! Called from: ", flg_snw_ice + write(iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + write(iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + write(iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write(iulog,*) "SNICAR STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) + write(iulog,*) "SNICAR STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) + write(iulog,*) "SNICAR STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) + write(iulog,*) "SNICAR STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) + write(iulog,*) "SNICAR STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) + write(iulog,*) "SNICAR STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) + write(iulog,*) "frac_sno: ", frac_sno + CALL CoLM_stop('SNICAR aerosol concentration is outside its valid range.') + ENDIF +#endif + ELSE + flg_dover = 0 + ENDIF + + ENDDO !ENDDO WHILE (flg_dover > 0) + + ! Energy conservation check: + ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) + energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) + IF (abs(energy_sum) > 0.00001_r8) THEN +#ifndef _OPENACC + IF (mpas_is_root) THEN + write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum + CALL CoLM_stop('SNICAR energy conservation check failed.') + ENDIF +#endif + ENDIF + + albout_lcl(bnd_idx) = albedo + + ! Check that albedo is less than 1 + IF (albout_lcl(bnd_idx) > 1.0) THEN +#ifndef _OPENACC + IF (mpas_is_root) THEN + write(iulog,*) "SNICAR ERROR: Albedo > 1.0: " + write(iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx + write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & + " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) + write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in + + write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) + write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) + write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) + write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) + write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) + + write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) + write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) + write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) + write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) + write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + + write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) + write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) + write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) + write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) + write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + + CALL CoLM_stop('SNICAR snow-grain radius is outside its valid range.') + ENDIF +#endif + ENDIF + + ENDDO ! loop over wvl bands + + + ! Weight output NIR albedo appropriately + albout(1) = albout_lcl(1) + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) + ENDDO + albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + + ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately + flx_abs(:,1) = flx_abs_lcl(:,1) + DO i=snl_top,1,1 + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) + ENDDO + flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + ENDDO + + ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + albout(1) = albsfc(1) + albout(2) = albsfc(2) + + ! There is either zero snow, or no sun + ELSE + albout(1) = 0._r8 + albout(2) = 0._r8 + ENDIF ! IF column has snow and coszen > 0 + + ! END associate + + END SUBROUTINE SNICAR_RT + !----------------------------------------------------------------------- + + + SUBROUTINE SNICAR_AD_RT (flg_snw_ice, flg_slr_in, & + coszen, snl, h2osno, frac_sno, & + h2osno_liq, h2osno_ice, snw_rds, & + mss_cnc_aer_in, albsfc, albout, flx_abs) + ! + ! !DESCRIPTION: + ! Determine reflectance of, and vertically-resolved solar absorption in, + ! snow with impurities, with updated shortwave scheme + ! + ! The multi-layer solution for multiple-scattering used here is from: + ! Briegleb, P. and Light, B.: A Delta-Eddington mutiple scattering + ! parameterization for solar radiation in the sea ice component of the + ! community climate system model, 2007. + ! + ! The implementation of the SNICAR-AD model in ELM is described in: + ! Dang et al., Inter-comparison and improvement of 2-stream shortwave + ! radiative transfer models for unified treatment of cryospheric surfaces + ! in ESMs, in review, 2019 + ! + ! To USE this subtroutine, set use_snicar_ad = true in ELM + ! + ! IF config_use_snicar_ad = true in MPAS-seaice + ! Snow on land and snow on sea ice will be treated + ! with the same model for their solar radiative properties. + ! + ! The inputs and outputs are the same to SUBROUTINE SNICAR_RT + ! + ! !USES: + ! + ! !ARGUMENTS: + + IMPLICIT NONE + + integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM + integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux,=2 for diffuse incident flux + real(r8) , intent(in) :: coszen ! cosine of solar zenith angle for next time step (col) [unitless] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: h2osno ! snow liquid water equivalent (col) [kg/m2] + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg/m2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg/m2] + integer , intent(in) :: snw_rds ( maxsnl+1:0 ) ! snow effective radius (col,lyr) [microns, m^-6] + real(r8) , intent(in) :: mss_cnc_aer_in ( maxsnl+1:0 , 1:sno_nbr_aer ) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg] + real(r8) , intent(in) :: albsfc ( 1:numrad ) ! albedo of surface underlying snow (col,bnd) [frc] + real(r8) , intent(out) :: albout ( 1:numrad ) ! snow albedo, averaged into 2 bands (=0 IF no sun or no snow) (col,bnd) [frc] + real(r8) , intent(out) :: flx_abs ( maxsnl+1:1 , 1:numrad ) ! absorbed flux in each layer per unit flux incident (col, lyr, bnd) + ! + ! !LOCAL VARIABLES: + ! + ! variables for snow radiative transfer calculations + + ! Local variables representing single-column values of arrays: + integer :: snl_lcl ! negative number of snow layers [nbr] + integer :: snw_rds_lcl(maxsnl+1:0) ! snow effective radius [m^-6] + real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1) + real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1) + real(r8):: mss_cnc_aer_lcl(maxsnl+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg] + real(r8):: h2osno_lcl ! total column snow mass [kg/m2] + real(r8):: h2osno_liq_lcl(maxsnl+1:0) ! liquid water mass [kg/m2] + real(r8):: h2osno_ice_lcl(maxsnl+1:0) ! ice mass [kg/m2] + real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc] + real(r8):: ss_alb_snw_lcl(maxsnl+1:0) ! single-scatter albedo of ice grains (lyr) [frc] + real(r8):: asm_prm_snw_lcl(maxsnl+1:0) ! asymmetry parameter of ice grains (lyr) [frc] + real(r8):: ext_cff_mss_snw_lcl(maxsnl+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg] + real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc] + real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc] + real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg] + +#ifdef MODAL_AER + !mgf++ + real(r8) :: rds_bcint_lcl(maxsnl+1:0) ! effective radius of within-ice BC [nm] + real(r8) :: rds_bcext_lcl(maxsnl+1:0) ! effective radius of external BC [nm] + !mgf-- +#endif + + + ! Other local variables + integer :: DELTA ! flag to USE Delta approximation (Joseph, 1976) + ! (1= USE, 0= don't USE) + real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, + ! specific to direct and diffuse cases (bnd) [frc] + integer :: flg_nosnl ! flag: =1 IF there is snow, but zero snow layers, + ! =0 IF at least 1 snow layer [flg] + ! integer :: trip ! flag: =1 to redo RT calculation IF result is unrealistic + ! integer :: flg_dover ! defines conditions for RT redo (explained below) + + real(r8):: albedo ! temporary snow albedo [frc] + real(r8):: flx_sum ! temporary summation variable for NIR weighting + real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc] + real(r8):: flx_abs_lcl(maxsnl+1:1,numrad_snw) ! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc] + + real(r8):: L_snw(maxsnl+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2] + real(r8):: tau_snw(maxsnl+1:0) ! snow optical depth (lyr) [unitless] + real(r8):: L_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2] + real(r8):: tau_aer(maxsnl+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless] + real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless] + real(r8):: tau_elm(maxsnl+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless] + real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc] + real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc] + + real(r8):: tau(maxsnl+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless] + real(r8):: omega(maxsnl+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc] + real(r8):: g(maxsnl+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc] + real(r8):: tau_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer + ! (lyr) [unitless] + real(r8):: omega_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc] + real(r8):: g_star(maxsnl+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer + ! (lyr) [frc] + + ! integer :: c_idx ! column indices [idx] + integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx] + integer :: rds_idx ! snow effective radius index for retrieving + ! Mie parameters from lookup table [idx] + integer :: snl_btm ! index of bottom snow layer (0) [idx] + integer :: snl_top ! index of top snow layer (-4 to 0) [idx] + integer :: fc ! column filter index + integer :: i ! layer index [idx] + integer :: j ! aerosol number index [idx] + integer :: m ! secondary layer index [idx] + integer :: nint_snw_rds_min ! nearest integer value of snw_rds_min + + real(r8):: F_abs(maxsnl+1:0) ! net absorbed radiative energy (lyr) [W/m^2] + real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2] + real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2] + real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2] + real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2] + real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc] + + integer :: err_idx ! counter for number of times through error loop [nbr] + real(r8):: pi ! 3.1415... + + integer :: snw_shp_lcl(maxsnl+1:0) ! Snow grain shape option: + ! 1=sphere; 2=spheroid; 3=hexagonal plate; 4=koch snowflake + real(r8):: snw_fs_lcl(maxsnl+1:0) ! Shape factor: ratio of nonspherical grain effective radii to that of equal-volume sphere + ! 0=USE recommended default value + ! others(0 1 (i.e. nonspherical) + real(r8):: snw_ar_lcl(maxsnl+1:0) ! % Aspect ratio: ratio of grain width to length + ! 0=USE recommended default value + ! others(0.1 1 (i.e. nonspherical) + real(r8):: & + diam_ice , & ! effective snow grain diameter + fs_sphd , & ! shape factor for spheroid + fs_hex0 , & ! shape factor for hexagonal plate + fs_hex , & ! shape factor for hexagonal plate (reference) + fs_koch , & ! shape factor for koch snowflake + AR_tmp , & ! aspect ratio for spheroid + g_ice_Cg_tmp(7) , & ! temporary for calculation of asymetry factor + gg_ice_F07_tmp(7) , & ! temporary for calculation of asymetry factor + g_ice_F07 , & ! temporary for calculation of asymetry factor + g_ice , & ! asymmetry factor + gg_F07_intp , & ! temporary for calculation of asymetry factor (interpolated) + g_Cg_intp , & ! temporary for calculation of asymetry factor (interpolated) + R_1_omega_tmp , & ! temporary for dust-snow mixing calculation + C_dust_total ! dust concentration + + integer :: atm_type_index ! index for atmospheric type + integer :: slr_zen ! integer value of solar zenith angle + + ! SNICAR_AD new variables, follow sea-ice shortwave conventions + real(r8):: & + trndir(maxsnl+1:1) , & ! solar beam down transmission from top + trntdr(maxsnl+1:1) , & ! total transmission to direct beam for layers above + trndif(maxsnl+1:1) , & ! diffuse transmission to diffuse beam for layers above + rupdir(maxsnl+1:1) , & ! reflectivity to direct radiation for layers below + rupdif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers below + rdndif(maxsnl+1:1) , & ! reflectivity to diffuse radiation for layers above + dfdir(maxsnl+1:1) , & ! down-up flux at interface due to direct beam at top surface + dfdif(maxsnl+1:1) , & ! down-up flux at interface due to diffuse beam at top surface + dftmp(maxsnl+1:1) ! temporary variable for down-up flux at interface + + real(r8):: & + rdir(maxsnl+1:0) , & ! layer reflectivity to direct radiation + rdif_a(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from above + rdif_b(maxsnl+1:0) , & ! layer reflectivity to diffuse radiation from below + tdir(maxsnl+1:0) , & ! layer transmission to direct radiation (solar beam + diffuse) + tdif_a(maxsnl+1:0) , & ! layer transmission to diffuse radiation from above + tdif_b(maxsnl+1:0) , & ! layer transmission to diffuse radiation from below + trnlay(maxsnl+1:0) ! solar beam transm for layer (direct beam only) + + real(r8):: & + ts , & ! layer delta-scaled extinction optical depth + ws , & ! layer delta-scaled single scattering albedo + gs , & ! layer delta-scaled asymmetry parameter + extins , & ! extinction + alp , & ! temporary for alpha + gam , & ! temporary for agamm + amg , & ! alp - gam + apg , & ! alp + gam + ue , & ! temporary for u + refk , & ! interface multiple scattering + refkp1 , & ! interface multiple scattering for k+1 + refkm1 , & ! interface multiple scattering for k-1 + tdrrdir , & ! direct tran times layer direct ref + tdndif ! total down diffuse = tot tran - direct tran + + real(r8) :: & + alpha , & ! term in direct reflectivity and transmissivity + agamm , & ! term in direct reflectivity and transmissivity + el , & ! term in alpha,agamm,n,u + taus , & ! scaled extinction optical depth + omgs , & ! scaled single particle scattering albedo + asys , & ! scaled asymmetry parameter + u , & ! term in diffuse reflectivity and transmissivity + n , & ! term in diffuse reflectivity and transmissivity + lm , & ! temporary for el + mu , & ! cosine solar zenith for either snow or water + ne ! temporary for n + + ! perpendicular and parallel relative to plane of incidence and scattering + real(r8) :: & + R1 , & ! perpendicular polarization reflection amplitude + R2 , & ! parallel polarization reflection amplitude + T1 , & ! perpendicular polarization transmission amplitude + T2 , & ! parallel polarization transmission amplitude + Rf_dir_a , & ! fresnel reflection to direct radiation + Tf_dir_a , & ! fresnel transmission to direct radiation + Rf_dif_a , & ! fresnel reflection to diff radiation from above + Rf_dif_b , & ! fresnel reflection to diff radiation from below + Tf_dif_a , & ! fresnel transmission to diff radiation from above + Tf_dif_b ! fresnel transmission to diff radiation from below + + real(r8) :: & + gwt , & ! gaussian weight + swt , & ! sum of weights + trn , & ! layer transmission + rdr , & ! rdir for gaussian integration + tdr , & ! tdir for gaussian integration + smr , & ! accumulator for rdif gaussian integration + smt , & ! accumulator for tdif gaussian integration + exp_min ! minimum exponential value + + integer :: & + ng , & ! gaussian integration index + snl_btm_itf , & ! index of bottom snow layer interfaces (1) [idx] + ngmax = 8 ! gaussian integration index + + ! Gaussian integration angle and coefficients + real(r8) :: difgauspt(1:8) , difgauswt(1:8) + + ! constants used in algorithm + real(r8) :: & + c0 = 0.0_r8 , & + c1 = 1.0_r8 , & + c3 = 3.0_r8 , & + c4 = 4.0_r8 , & + c6 = 6.0_r8 , & + cp01 = 0.01_r8 , & + cp5 = 0.5_r8 , & + cp75 = 0.75_r8 , & + c1p5 = 1.5_r8 , & + trmin = 0.001_r8 , & + argmax = 10.0_r8 ! maximum argument of exponential + + ! cconstant coefficients used for SZA parameterization + real(r8) :: & + sza_a0 = 0.085730_r8 , & + sza_a1 = -0.630883_r8 , & + sza_a2 = 1.303723_r8 , & + sza_b0 = 1.467291_r8 , & + sza_b1 = -3.338043_r8 , & + sza_b2 = 6.807489_r8 , & + puny = 1.0e-11_r8 , & + mu_75 = 0.2588_r8 ! cosine of 75 degree + + ! coefficients used for SZA parameterization + real(r8) :: & + sza_c1 , & ! coefficient, SZA parameteirzation + sza_c0 , & ! coefficient, SZA parameterization + sza_factor , & ! factor used to adjust NIR direct albedo + flx_sza_adjust , & ! direct NIR flux adjustment from sza_factor + mu0 ! incident solar zenith angle + + !----------------------------------------------------------------------- +#ifdef MODAL_AER + !mgf++ + integer :: idx_bcint_icerds ! index of ice effective radius for optical properties lookup table + integer :: idx_bcint_nclrds ! index of within-ice BC effective radius for optical properties lookup table + integer :: idx_bcext_nclrds ! index of external BC effective radius for optical properties lookup table + real(r8):: enh_fct ! extinction/absorption enhancement factor for within-ice BC + real(r8):: tmp1 ! temporary variable + !mgf-- +#endif + + ! Constants for non-spherical ice particles and dust-snow internal mixing + real(r8) :: g_b2(7) + real(r8) :: g_b1(7) + real(r8) :: g_b0(7) + real(r8) :: g_F07_c2(7) + real(r8) :: g_F07_c1(7) + real(r8) :: g_F07_c0(7) + real(r8) :: g_F07_p2(7) + real(r8) :: g_F07_p1(7) + real(r8) :: g_F07_p0(7) + real(r8) :: dust_clear_d0(3) + real(r8) :: dust_clear_d1(3) + real(r8) :: dust_clear_d2(3) + real(r8) :: dust_cloudy_d0(3) + real(r8) :: dust_cloudy_d1(3) + real(r8) :: dust_cloudy_d2(3) + + !!! factors for considering snow grain shape + data g_b0(:) / 9.76029E-01_r8, 9.67798E-01_r8, 1.00111E+00_r8, 1.00224E+00_r8,& + 9.64295E-01_r8, 9.97475E-01_r8, 9.97475E-01_r8/ + data g_b1(:) / 5.21042E-01_r8, 4.96181E-01_r8, 1.83711E-01_r8, 1.37082E-01_r8,& + 5.50598E-02_r8, 8.48743E-02_r8, 8.48743E-02_r8/ + data g_b2(:) /-2.66792E-04_r8, 1.14088E-03_r8, 2.37011E-04_r8,-2.35905E-04_r8,& + 8.40449E-04_r8,-4.71484E-04_r8,-4.71484E-04_r8/ + + data g_F07_c2(:) / 1.349959E-1_r8, 1.115697E-1_r8, 9.853958E-2_r8, 5.557793E-2_r8,& + -1.233493E-1_r8, 0.0_r8, 0.0_r8/ + data g_F07_c1(:) /-3.987320E-1_r8,-3.723287E-1_r8,-3.924784E-1_r8,-3.259404E-1_r8,& + 4.429054E-2_r8,-1.726586E-1_r8,-1.726586E-1_r8/ + data g_F07_c0(:) / 7.938904E-1_r8, 8.030084E-1_r8, 8.513932E-1_r8, 8.692241E-1_r8,& + 7.085850E-1_r8, 6.412701E-1_r8, 6.412701E-1_r8/ + data g_F07_p2(:) / 3.165543E-3_r8, 2.014810E-3_r8, 1.780838E-3_r8, 6.987734E-4_r8,& + -1.882932E-2_r8,-2.277872E-2_r8,-2.277872E-2_r8/ + data g_F07_p1(:) / 1.140557E-1_r8, 1.143152E-1_r8, 1.143814E-1_r8, 1.071238E-1_r8,& + 1.353873E-1_r8, 1.914431E-1_r8, 1.914431E-1_r8/ + data g_F07_p0(:) / 5.292852E-1_r8, 5.425909E-1_r8, 5.601598E-1_r8, 6.023407E-1_r8,& + 6.473899E-1_r8, 4.634944E-1_r8, 4.634944E-1_r8/ + + !!! factors for considring dust-snow internal mixing + data dust_clear_d0(:) /1.0413E+00_r8,1.0168E+00_r8,1.0189E+00_r8/ + data dust_clear_d1(:) /1.0016E+00_r8,1.0070E+00_r8,1.0840E+00_r8/ + data dust_clear_d2(:) /2.4208E-01_r8,1.5300E-03_r8,1.1230E-04_r8/ + + data dust_cloudy_d0(:) /1.0388E+00_r8,1.0167E+00_r8,1.0189E+00_r8/ + data dust_cloudy_d1(:) /1.0015E+00_r8,1.0061E+00_r8,1.0823E+00_r8/ + data dust_cloudy_d2(:) /2.5973E-01_r8,1.6200E-03_r8,1.1721E-04_r8/ + + ! Enforce expected array sizes + + ! associate(& + ! snl => col_pp%snl , & ! Input: [integer (:)] negative number of snow layers (col) [nbr] + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:)] snow liquid water equivalent (col) [kg/m2] + ! frac_sno => col_ws%frac_sno_eff & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) + ! ) + + ! Define constants + pi = SHR_CONST_PI + nint_snw_rds_min = nint(snw_rds_min) + + ! always USE Delta approximation for snow + DELTA = 1 + + !Gaussian integration angle and coefficients for diffuse radiation + difgauspt(1:8) & ! gaussian angles (radians) + = (/ 0.9894009_r8, 0.9445750_r8, & + 0.8656312_r8, 0.7554044_r8, & + 0.6178762_r8, 0.4580168_r8, & + 0.2816036_r8, 0.0950125_r8/) + difgauswt(1:8) & ! gaussian weights + = (/ 0.0271525_r8, 0.0622535_r8, & + 0.0951585_r8, 0.1246290_r8, & + 0.1495960_r8, 0.1691565_r8, & + 0.1826034_r8, 0.1894506_r8/) + + snw_shp_lcl(:) = snow_shape_sphere + snw_fs_lcl(:) = 0._r8 + snw_ar_lcl(:) = 0._r8 + atm_type_index = atm_type_default + + ! Define snow grain shape + IF (trim(snow_shape) == 'sphere') THEN + snw_shp_lcl(:) = snow_shape_sphere + ELSEIF (trim(snow_shape) == 'spheroid') THEN + snw_shp_lcl(:) = snow_shape_spheroid + ELSEIF (trim(snow_shape) == 'hexagonal_plate') THEN + snw_shp_lcl(:) = snow_shape_hexagonal_plate + ELSEIF (trim(snow_shape) == 'koch_snowflake') THEN + snw_shp_lcl(:) = snow_shape_koch_snowflake + ELSE + IF (mpas_is_root) THEN + write(iulog,*) "snow_shape = ", snow_shape + CALL CoLM_stop('SNICAR received an unsupported snow shape.') + ENDIF + ENDIF + + ! Define atmospheric type + IF (trim(snicar_atm_type) == 'default') THEN + atm_type_index = atm_type_default + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain + ELSE + IF (mpas_is_root) THEN + write(iulog,*) "snicar_atm_type = ", snicar_atm_type + CALL CoLM_stop('SNICAR received an unsupported atmospheric profile.') + ENDIF + ENDIF + + ! (when called from CSIM, there is only one column) + + ! Zero absorbed radiative fluxes: + DO i=maxsnl+1,1,1 + flx_abs_lcl(:,:) = 0._r8 + flx_abs(i,:) = 0._r8 + ENDDO + + ! set snow/ice mass to be used for RT: + IF (flg_snw_ice == 1) THEN + h2osno_lcl = h2osno + ELSE + h2osno_lcl = h2osno_ice(0) + ENDIF + + ! Qualifier for computing snow RT: + ! 1) sunlight from atmosphere model + ! 2) minimum amount of snow on ground. + ! Otherwise, set snow albedo to zero + IF ((coszen > 0._r8) .and. (h2osno_lcl > min_snw) ) THEN + + ! Set variables specific to ELM + IF (flg_snw_ice == 1) THEN + ! If there is snow, but zero snow layers, we must create a layer locally. + ! This layer is presumed to have the fresh snow effective radius. + IF (snl > -1) THEN + flg_nosnl = 1 + snl_lcl = -1 + h2osno_ice_lcl(0) = h2osno_lcl + h2osno_liq_lcl(0) = 0._r8 + snw_rds_lcl(0) = nint_snw_rds_min + ELSE + flg_nosnl = 0 + snl_lcl = snl + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + ENDIF + + snl_btm = 0 + snl_top = snl_lcl+1 + + ! Set variables specific to CSIM + ELSE + flg_nosnl = 0 + snl_lcl = -1 + h2osno_liq_lcl(:) = h2osno_liq(:) + h2osno_ice_lcl(:) = h2osno_ice(:) + snw_rds_lcl(:) = snw_rds(:) + snl_btm = 0 + snl_top = 0 + ENDIF ! END IF flg_snw_ice == 1 + +#ifdef MODAL_AER + !mgf++ + ! + ! Assume fixed BC effective radii of 100nm. This is close to + ! the effective radius of 95nm (number median radius of + ! 40nm) assumed for freshly-emitted BC in MAM. Future + ! implementations may prognose the BC effective radius in + ! snow. + rds_bcint_lcl(:) = 100._r8 + rds_bcext_lcl(:) = 100._r8 + !mgf-- +#endif + + ! Set local aerosol array + DO j=1,sno_nbr_aer + mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(:,j) + ENDDO + + ! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos + albsfc_lcl(1) = albsfc(1) + albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(2) + + ! Error check for snow grain size: + IF (mpas_is_root) THEN + DO i=snl_top,snl_btm,1 + IF ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) THEN + write (iulog,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds." + write (iulog,*) "flg_snw_ice= ", flg_snw_ice + write (iulog,*) " level: ", i, " snl(c)= ", snl_lcl + write (iulog,*) "h2osno(c)= ", h2osno_lcl + CALL CoLM_stop('SNICAR-AD encountered inconsistent snow-layer state.') + ENDIF + ENDDO + ENDIF + + ! Incident flux weighting parameters + ! - sum of all VIS bands must equal 1 + ! - sum of all NIR bands must equal 1 + ! + ! Spectral bands (5-band CASE) + ! Band 1: 0.3-0.7um (VIS) + ! Band 2: 0.7-1.0um (NIR) + ! Band 3: 1.0-1.2um (NIR) + ! Band 4: 1.2-1.5um (NIR) + ! Band 5: 1.5-5.0um (NIR) + ! + ! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere + ! + ! 3-band weights + IF (numrad_snw==3) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.66628670195247_r8 + flx_wgt(3) = 0.33371329804753_r8 + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.77887652162877_r8 + flx_wgt(3) = 0.22112347837123_r8 + ENDIF + + ! 5-band weights + ELSEIF(numrad_snw==5) THEN + ! Direct: + IF (flg_slr_in == 1) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.49352158521175_r8 + flx_wgt(3) = 0.18099494230665_r8 + flx_wgt(4) = 0.12094898498813_r8 + flx_wgt(5) = 0.20453448749347_r8 + ELSE + slr_zen = nint(acos(coszen) * 180._r8 / pi) + IF (slr_zen>89) THEN + slr_zen = 89 + ENDIF + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dir(atm_type_index, slr_zen+1, 2) + flx_wgt(3) = flx_wgt_dir(atm_type_index, slr_zen+1, 3) + flx_wgt(4) = flx_wgt_dir(atm_type_index, slr_zen+1, 4) + flx_wgt(5) = flx_wgt_dir(atm_type_index, slr_zen+1, 5) + ENDIF + + ! Diffuse: + ELSEIF (flg_slr_in == 2) THEN + IF (atm_type_index == atm_type_default) THEN + flx_wgt(1) = 1._r8 + flx_wgt(2) = 0.58581507618433_r8 + flx_wgt(3) = 0.20156903770812_r8 + flx_wgt(4) = 0.10917889346386_r8 + flx_wgt(5) = 0.10343699264369_r8 + ELSE + flx_wgt(1) = 1._r8 + flx_wgt(2) = flx_wgt_dif(atm_type_index, 2) + flx_wgt(3) = flx_wgt_dif(atm_type_index, 3) + flx_wgt(4) = flx_wgt_dif(atm_type_index, 4) + flx_wgt(5) = flx_wgt_dif(atm_type_index, 5) + ENDIF + ENDIF + ENDIF ! END IF numrad_snw + + ! Loop over snow spectral bands + + exp_min = exp(-argmax) + DO bnd_idx = 1,numrad_snw + + ! note that we can remove flg_dover since this algorithm is + ! stable for mu_not > 0.01 + + ! mu_not is cosine solar zenith angle above the fresnel level; make + ! sure mu_not is large enough for stable and meaningful radiation + ! solution: .01 is like sun just touching horizon with its lower edge + ! equivalent to mu0 in sea-ice shortwave model ice_shortwave.F90 + mu_not = max(coszen, cp01) + + + ! Set direct or diffuse incident irradiance to 1 + ! (This has to be within the bnd loop because mu_not is adjusted in rare cases) + IF (flg_slr_in == 1) THEN + flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0 + flx_slri_lcl(bnd_idx) = 0._r8 + ELSE + flx_slrd_lcl(bnd_idx) = 0._r8 + flx_slri_lcl(bnd_idx) = 1._r8 + ENDIF + + ! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands. + ! Since extremely high soot concentrations have a negligible effect on these bands, zero them. + IF ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + IF ( (numrad_snw == 3).and.(bnd_idx == 3) ) THEN + mss_cnc_aer_lcl(:,:) = 0._r8 + ENDIF + + ! Define local Mie parameters based on snow grain size and aerosol species, + ! retrieved from a lookup table. + IF (flg_slr_in == 1) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (direct radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx) + ENDDO + ELSEIF (flg_slr_in == 2) THEN + DO i=snl_top,snl_btm,1 + rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1 + ! snow optical properties (diffuse radiation) + ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx) + asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx) + ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx) + ENDDO + ENDIF + + ! Calculate the asymetry factors under different snow grain shapes + DO i=snl_top,snl_btm,1 + IF(snw_shp_lcl(i) == snow_shape_spheroid) THEN ! spheroid + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_sphd = 0.929_r8 + ELSE + fs_sphd = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 0.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_sphd/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_c0 + g_F07_c1 * AR_tmp + g_F07_c2 * (AR_tmp**2) + ELSEIF(snw_shp_lcl(i) == snow_shape_hexagonal_plate) THEN ! hexagonal plate + diam_ice = 2._r8*snw_rds_lcl(i) + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_hex0 = 0.788_r8 + ELSE + fs_hex0 = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 2.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_hex0/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + ELSEIF(snw_shp_lcl(i) == snow_shape_koch_snowflake) THEN ! Koch snowflake + diam_ice = 2._r8 * snw_rds_lcl(i) /0.544_r8 + IF(snw_fs_lcl(i) == 0._r8) THEN + fs_koch = 0.712_r8 + ELSE + fs_koch = snw_fs_lcl(i) + ENDIF + fs_hex = 0.788_r8 + IF(snw_ar_lcl(i) == 0._r8) THEN + AR_tmp = 2.5_r8 + ELSE + AR_tmp = snw_ar_lcl(i) + ENDIF + g_ice_Cg_tmp = g_b0 * ((fs_koch/fs_hex)**g_b1) * (diam_ice**g_b2) + gg_ice_F07_tmp = g_F07_p0 + g_F07_p1 * log(AR_tmp) + g_F07_p2 * ((log(AR_tmp))**2) + ENDIF + + ! Linear interpolation for calculating the asymetry factor at band_idx. + IF(snw_shp_lcl(i) > 1) THEN + IF(bnd_idx == 1) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8) +g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.5_r8-0.475_r8)+gg_ice_F07_tmp(1) + ELSEIF(bnd_idx == 2) THEN + g_Cg_intp = (g_ice_Cg_tmp(2)-g_ice_Cg_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+g_ice_Cg_tmp(1) + gg_F07_intp = (gg_ice_F07_tmp(2)-gg_ice_F07_tmp(1))/(1.055_r8-0.475_r8)*(0.85_r8-0.475_r8)+gg_ice_F07_tmp(1) + ELSEIF(bnd_idx == 3) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.1_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + ELSEIF(bnd_idx == 4) THEN + g_Cg_intp = (g_ice_Cg_tmp(3)-g_ice_Cg_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +g_ice_Cg_tmp(2) + gg_F07_intp = (gg_ice_F07_tmp(3)-gg_ice_F07_tmp(2))/(1.655_r8-1.055_r8)*(1.35_r8-1.055_r8)& + +gg_ice_F07_tmp(2) + ELSEIF(bnd_idx == 5) THEN + g_Cg_intp = (g_ice_Cg_tmp(6)-g_ice_Cg_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +g_ice_Cg_tmp(5) + gg_F07_intp = (gg_ice_F07_tmp(6)-gg_ice_F07_tmp(5))/(3.75_r8-3.0_r8)*(3.25_r8-3.0_r8)& + +gg_ice_F07_tmp(5) + ENDIF + g_ice_F07 = gg_F07_intp + (1._r8 - gg_F07_intp) / ss_alb_snw_lcl(i) / 2._r8 + g_ice = g_ice_F07 * g_Cg_intp + asm_prm_snw_lcl(i) = g_ice + ENDIF + + IF(asm_prm_snw_lcl(i) > 0.99_r8) THEN + asm_prm_snw_lcl(i) = 0.99_r8 + ENDIF + + ENDDO + !!!-END + + !H. Wang + ! aerosol species 1 optical properties + ! ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + ! asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ! ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ! ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + ! asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ! ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) + !H. Wang + ! aerosol species 3 optical properties + ss_alb_aer_lcl(3) = ss_alb_oc1(bnd_idx) + asm_prm_aer_lcl(3) = asm_prm_oc1(bnd_idx) + ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(bnd_idx) + + ! aerosol species 4 optical properties + ss_alb_aer_lcl(4) = ss_alb_oc2(bnd_idx) + asm_prm_aer_lcl(4) = asm_prm_oc2(bnd_idx) + ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(bnd_idx) + + ! aerosol species 5 optical properties + ss_alb_aer_lcl(5) = ss_alb_dst1(bnd_idx) + asm_prm_aer_lcl(5) = asm_prm_dst1(bnd_idx) + ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(bnd_idx) + + ! aerosol species 6 optical properties + ss_alb_aer_lcl(6) = ss_alb_dst2(bnd_idx) + asm_prm_aer_lcl(6) = asm_prm_dst2(bnd_idx) + ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(bnd_idx) + + ! aerosol species 7 optical properties + ss_alb_aer_lcl(7) = ss_alb_dst3(bnd_idx) + asm_prm_aer_lcl(7) = asm_prm_dst3(bnd_idx) + ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(bnd_idx) + + ! aerosol species 8 optical properties + ss_alb_aer_lcl(8) = ss_alb_dst4(bnd_idx) + asm_prm_aer_lcl(8) = asm_prm_dst4(bnd_idx) + ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(bnd_idx) + + + ! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2]) + ! 2. optical Depths (tau_snw, tau_aer) + ! 3. weighted Mie properties (tau, omega, g) + + ! Weighted Mie parameters of each layer + DO i=snl_top,snl_btm,1 +#ifdef MODAL_AER + !mgf++ within-ice and external BC optical properties + ! + ! Lookup table indices for BC optical properties, + ! dependent on snow grain size and BC particle + ! size. + + ! valid for 25 < snw_rds < 1625 um: + IF (snw_rds_lcl(i) < 125) THEN + tmp1 = snw_rds_lcl(i)/50 + idx_bcint_icerds = nint(tmp1) + ELSEIF (snw_rds_lcl(i) < 175) THEN + idx_bcint_icerds = 2 + ELSE + tmp1 = (snw_rds_lcl(i)/250)+2 + idx_bcint_icerds = nint(tmp1) + ENDIF + + ! valid for 25 < bc_rds < 525 nm + idx_bcint_nclrds = nint(rds_bcint_lcl(i)/50) + idx_bcext_nclrds = nint(rds_bcext_lcl(i)/50) + + ! check bounds: + IF (idx_bcint_icerds < idx_bcint_icerds_min) idx_bcint_icerds = idx_bcint_icerds_min + IF (idx_bcint_icerds > idx_bcint_icerds_max) idx_bcint_icerds = idx_bcint_icerds_max + IF (idx_bcint_nclrds < idx_bc_nclrds_min) idx_bcint_nclrds = idx_bc_nclrds_min + IF (idx_bcint_nclrds > idx_bc_nclrds_max) idx_bcint_nclrds = idx_bc_nclrds_max + IF (idx_bcext_nclrds < idx_bc_nclrds_min) idx_bcext_nclrds = idx_bc_nclrds_min + IF (idx_bcext_nclrds > idx_bc_nclrds_max) idx_bcext_nclrds = idx_bc_nclrds_max + + ! retrieve absorption enhancement factor for within-ice BC + enh_fct = bcenh(bnd_idx,idx_bcint_nclrds,idx_bcint_icerds) + + ! get BC optical properties (moved from above) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx,idx_bcint_nclrds) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx,idx_bcint_nclrds) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx,idx_bcint_nclrds)*enh_fct + + ! aerosol species 2 optical properties (external BC) + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx,idx_bcext_nclrds) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx,idx_bcext_nclrds) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx,idx_bcext_nclrds) + +#else + ! bulk aerosol treatment (BC optical properties independent + ! of BC and ice grain size) + ! aerosol species 1 optical properties (within-ice BC) + ss_alb_aer_lcl(1) = ss_alb_bc1(bnd_idx) + asm_prm_aer_lcl(1) = asm_prm_bc1(bnd_idx) + ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(bnd_idx) + + ! aerosol species 2 optical properties + ss_alb_aer_lcl(2) = ss_alb_bc2(bnd_idx) + asm_prm_aer_lcl(2) = asm_prm_bc2(bnd_idx) + ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(bnd_idx) +#endif + + ! Calculate single-scattering albedo for internal mixing of dust-snow + IF (use_dust_snow_internal_mixing) THEN + IF (bnd_idx < 4) THEN + C_dust_total = mss_cnc_aer_lcl(i,5) + mss_cnc_aer_lcl(i,6) & + + mss_cnc_aer_lcl(i,7) + mss_cnc_aer_lcl(i,8) + C_dust_total = C_dust_total * 1.0E+06_r8 + IF(C_dust_total > 0._r8) THEN + IF (flg_slr_in == 1) THEN + R_1_omega_tmp = dust_clear_d0(bnd_idx) & + + dust_clear_d2(bnd_idx)*(C_dust_total**dust_clear_d1(bnd_idx)) + ELSE + R_1_omega_tmp = dust_cloudy_d0(bnd_idx) & + + dust_cloudy_d2(bnd_idx)*(C_dust_total**dust_cloudy_d1(bnd_idx)) + ENDIF + ss_alb_snw_lcl(i) = 1.0_r8 - (1.0_r8 - ss_alb_snw_lcl(i)) *R_1_omega_tmp + ENDIF + ENDIF + DO j = 5,8,1 + ss_alb_aer_lcl(j) = 0._r8 + asm_prm_aer_lcl(j) = 0._r8 + ext_cff_mss_aer_lcl(j) = 0._r8 + ENDDO + ENDIF + + !mgf-- + + L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i) + tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i) + + DO j=1,sno_nbr_aer + IF (use_dust_snow_internal_mixing .and. (j >= 5)) THEN + L_aer(i,j) = 0._r8 + ELSE + L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j) + ENDIF + tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j) + ENDDO + + tau_sum = 0._r8 + omega_sum = 0._r8 + g_sum = 0._r8 + + DO j=1,sno_nbr_aer + tau_sum = tau_sum + tau_aer(i,j) + omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)) + g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j)) + ENDDO + + tau(i) = tau_sum + tau_snw(i) + omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i))) + g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i))) + ENDDO ! endWeighted Mie parameters of each layer + + ! DELTA transformations, IF requested + IF (DELTA == 1) THEN + DO i=snl_top,snl_btm,1 + g_star(i) = g(i)/(1+g(i)) + omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2))) + tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i) + ENDDO + ELSE + DO i=snl_top,snl_btm,1 + g_star(i) = g(i) + omega_star(i) = omega(i) + tau_star(i) = tau(i) + ENDDO + ENDIF + + ! Begin radiative transfer solver + ! Given input vertical profiles of optical properties, evaluate the + ! monochromatic Delta-Eddington adding-doubling solution + + ! note that trndir, trntdr, trndif, rupdir, rupdif, rdndif + ! are variables at the layer interface, + ! for snow with layers rangeing from snl_top to snl_btm + ! there are snl_top to snl_btm+1 layer interface + snl_btm_itf = snl_btm + 1 + + DO i = snl_top,snl_btm_itf,1 + trndir(i) = c0 + trntdr(i) = c0 + trndif(i) = c0 + rupdir(i) = c0 + rupdif(i) = c0 + rdndif(i) = c0 + ENDDO + + ! initialize top interface of top layer + trndir(snl_top) = c1 + trntdr(snl_top) = c1 + trndif(snl_top) = c1 + rdndif(snl_top) = c0 + + ! begin main level loop + ! for layer interfaces except for the very bottom + DO i = snl_top,snl_btm,1 + + ! initialize all layer apparent optical properties to 0 + rdir (i) = c0 + rdif_a(i) = c0 + rdif_b(i) = c0 + tdir (i) = c0 + tdif_a(i) = c0 + tdif_b(i) = c0 + trnlay(i) = c0 + + ! compute next layer Delta-eddington solution only IF total transmission + ! of radiation to the interface just above the layer exceeds trmin. + + IF (trntdr(i) > trmin ) THEN + + ! calculation over layers with penetrating radiation + + ! delta-transformed single-scattering properties + ! of this layer + ts = tau_star(i) + ws = omega_star(i) + gs = g_star(i) + + ! Delta-Eddington solution expressions + ! n(uu,et) = ((uu+c1)*(uu+c1)/et ) - ((uu-c1)*(uu-c1)*et) + ! u(w,gg,e) = c1p5*(c1 - w*gg)/e + ! el(w,gg) = sqrt(c3*(c1-w)*(c1 - w*gg)) + lm = sqrt(c3*(c1-ws)*(c1 - ws*gs)) !lm = el(ws,gs) + ue = c1p5*(c1 - ws*gs)/lm !ue = u(ws,gs,lm) + extins = max(exp_min, exp(-lm*ts)) + ne = ((ue+c1)*(ue+c1)/extins) - ((ue-c1)*(ue-c1)*extins) !ne = n(ue,extins) + + ! first calculation of rdif, tdif using Delta-Eddington formulas + ! rdif_a(k) = (ue+c1)*(ue-c1)*(c1/extins - extins)/ne + rdif_a(i) = (ue**2-c1)*(c1/extins - extins)/ne + tdif_a(i) = c4*ue/ne + + ! evaluate rdir,tdir for direct beam + trnlay(i) = max(exp_min, exp(-ts/mu_not)) + + ! Delta-Eddington solution expressions + ! alpha(w,uu,gg,e) = p75*w*uu*((c1 + gg*(c1-w))/(c1 - e*e*uu*uu)) + ! agamm(w,uu,gg,e) = p5*w*((c1 + c3*gg*(c1-w)*uu*uu)/(c1-e*e*uu*uu)) + ! alp = alpha(ws,mu_not,gs,lm) + ! gam = agamm(ws,mu_not,gs,lm) + alp = cp75*ws*mu_not*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu_not*mu_not)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu_not*mu_not)/(c1-lm*lm*mu_not*mu_not)) + apg = alp + gam + amg = alp - gam + + rdir(i) = apg*rdif_a(i) + amg*(tdif_a(i)*trnlay(i) - c1) + tdir(i) = apg*tdif_a(i) + (amg* rdif_a(i)-apg+c1)*trnlay(i) + + ! recalculate rdif,tdif using direct angular integration over rdir,tdir, + ! since Delta-Eddington rdif formula is not well-behaved (it is usually + ! biased low and can even be negative); USE ngmax angles and gaussian + ! integration for most accuracy: + R1 = rdif_a(i) ! USE R1 as temporary + T1 = tdif_a(i) ! USE T1 as temporary + swt = c0 + smr = c0 + smt = c0 + DO ng=1,ngmax + mu = difgauspt(ng) + gwt = difgauswt(ng) + swt = swt + mu*gwt + trn = max(exp_min, exp(-ts/mu)) + ! alp = alpha(ws,mu,gs,lm) + ! gam = agamm(ws,mu,gs,lm) + alp = cp75*ws*mu*((c1 + gs*(c1-ws))/(c1 - lm*lm*mu*mu)) + gam = cp5*ws*((c1 + c3*gs*(c1-ws)*mu*mu)/(c1-lm*lm*mu*mu)) + apg = alp + gam + amg = alp - gam + rdr = apg*R1 + amg*T1*trn - amg + tdr = apg*T1 + amg*R1*trn - apg*trn + trn + smr = smr + mu*rdr*gwt + smt = smt + mu*tdr*gwt + ENDDO ! ng + rdif_a(i) = smr/swt + tdif_a(i) = smt/swt + + ! homogeneous layer + rdif_b(i) = rdif_a(i) + tdif_b(i) = tdif_a(i) + + ENDIF ! trntdr(k) > trmin + + ! Calculate the solar beam transmission, total transmission, and + ! reflectivity for diffuse radiation from below at interface i, + ! the top of the current layer k: + ! + ! layers interface + ! + ! --------------------- i-1 + ! i-1 + ! --------------------- i + ! i + ! --------------------- + + trndir(i+1) = trndir(i)*trnlay(i) + refkm1 = c1/(c1 - rdndif(i)*rdif_a(i)) + tdrrdir = trndir(i)*rdir(i) + tdndif = trntdr(i) - trndir(i) + trntdr(i+1) = trndir(i)*tdir(i) + & + (tdndif + tdrrdir*rdndif(i))*refkm1*tdif_a(i) + rdndif(i+1) = rdif_b(i) + & + (tdif_b(i)*rdndif(i)*refkm1*tdif_a(i)) + trndif(i+1) = trndif(i)*refkm1*tdif_a(i) + + ENDDO ! END main level loop + + + ! compute reflectivity to direct and diffuse radiation for layers + ! below by adding succesive layers starting from the underlying + ! ground and working upwards: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- i+1 + ! i+1 + ! --------------------- + + ! set the underlying ground albedo == albedo of near-IR + ! unless bnd_idx == 1, for visible + rupdir(snl_btm_itf) = albsfc(2) + rupdif(snl_btm_itf) = albsfc(2) + IF (bnd_idx == 1) THEN + rupdir(snl_btm_itf) = albsfc(1) + rupdif(snl_btm_itf) = albsfc(1) + ENDIF + + DO i=snl_btm,snl_top,-1 + ! interface scattering + refkp1 = c1/( c1 - rdif_b(i)*rupdif(i+1)) + ! dir from top layer plus exp tran ref from lower layer, interface + ! scattered and tran thru top layer from below, plus diff tran ref + ! from lower layer with interface scattering tran thru top from below + rupdir(i) = rdir(i) & + + ( trnlay(i) *rupdir(i+1) & + + (tdir(i)-trnlay(i))*rupdif(i+1))*refkp1*tdif_b(i) + ! dif from top layer from above, plus dif tran upwards reflected and + ! interface scattered which tran top from below + rupdif(i) = rdif_a(i) + tdif_a(i)*rupdif(i+1)*refkp1*tdif_b(i) + ENDDO ! i + + ! net flux (down-up) at each layer interface from the + ! snow top (i = snl_top) to bottom interface above land (i = snl_btm_itf) + ! the interface reflectivities and transmissivities required + ! to evaluate interface fluxes are returned from solution_dEdd; + ! now compute up and down fluxes for each interface, using the + ! combined layer properties at each interface: + ! + ! layers interface + ! + ! --------------------- i + ! i + ! --------------------- + + DO i = snl_top, snl_btm_itf + ! interface scattering + refk = c1/(c1 - rdndif(i)*rupdif(i)) + ! dir tran ref from below times interface scattering, plus diff + ! tran and ref from below times interface scattering + ! fdirup(i) = (trndir(i)*rupdir(i) + & + ! (trntdr(i)-trndir(i)) & + ! *rupdif(i))*refk + ! dir tran plus total diff trans times interface scattering plus + ! dir tran with up dir ref and down dif ref times interface scattering + ! fdirdn(i) = trndir(i) + (trntdr(i) & + ! - trndir(i) + trndir(i) & + ! *rupdir(i)*rdndif(i))*refk + ! diffuse tran ref from below times interface scattering + ! fdifup(i) = trndif(i)*rupdif(i)*refk + ! diffuse tran times interface scattering + ! fdifdn(i) = trndif(i)*refk + + ! netflux, down - up + ! dfdir = fdirdn - fdirup + dfdir(i) = trndir(i) & + + (trntdr(i)-trndir(i)) * (c1 - rupdif(i)) * refk & + - trndir(i)*rupdir(i) * (c1 - rdndif(i)) * refk + IF (dfdir(i) < puny) dfdir(i) = c0 + ! dfdif = fdifdn - fdifup + dfdif(i) = trndif(i) * (c1 - rupdif(i)) * refk + IF (dfdif(i) < puny) dfdif(i) = c0 + ENDDO ! k + + ! SNICAR_AD_RT is called twice for direct and diffuse incident fluxes + ! direct incident + IF (flg_slr_in == 1) THEN + albedo = rupdir(snl_top) + dftmp = dfdir + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = (trndir(snl_top)*rupdir(snl_top) + & + (trntdr(snl_top)-trndir(snl_top)) & + *rupdif(snl_top))*refk + !diffuse incident + ELSE + albedo = rupdif(snl_top) + dftmp = dfdif + refk = c1/(c1 - rdndif(snl_top)*rupdif(snl_top)) + F_sfc_pls = trndif(snl_top)*rupdif(snl_top)*refk + ENDIF + + ! Absorbed flux in each layer + DO i=snl_top,snl_btm,1 + F_abs(i) = dftmp(i)-dftmp(i+1) + flx_abs_lcl(i,bnd_idx) = F_abs(i) + + ! ERROR check: negative absorption + IF (mpas_is_root) THEN + IF (flx_abs_lcl(i,bnd_idx) < -0.00001) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx) + write(iulog,*) "SNICAR_AD STATS: snw_rds(0)= ", snw_rds(0) + write(iulog,*) "SNICAR_AD STATS: L_snw(0)= ", L_snw(0) + write(iulog,*) "SNICAR_AD STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write(iulog,*) "SNICAR_AD STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1) + write(iulog,*) "SNICAR_AD STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2) + write(iulog,*) "SNICAR_AD STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3) + write(iulog,*) "SNICAR_AD STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4) + write(iulog,*) "SNICAR_AD STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5) + write(iulog,*) "SNICAR_AD STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) + CALL CoLM_stop('SNICAR-AD aerosol concentration is outside its valid range.') + ENDIF + ENDIF + ENDDO + + ! absobed flux by the underlying ground + F_btm_net = dftmp(snl_btm_itf) + + ! note here, snl_btm_itf = 1 by snow column set up in CLM + flx_abs_lcl(1,bnd_idx) = F_btm_net + + IF (flg_nosnl == 1) THEN + ! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer + !flx_abs_lcl(:,bnd_idx) = 0._r8 + !flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net + + ! changed on 20070408: + ! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation + ! handles the CASE of no snow layers. Then, IF a snow layer is addded between now and + ! SurfaceRadiation (called in CanopyHydrology), absorbed energy will be properly distributed. + flx_abs_lcl(0,bnd_idx) = F_abs(0) + flx_abs_lcl(1,bnd_idx) = F_btm_net + ENDIF + + !Underflow check (we've already tripped the error condition above) + DO i=snl_top,1,1 + IF (flx_abs_lcl(i,bnd_idx) < 0._r8) THEN + flx_abs_lcl(i,bnd_idx) = 0._r8 + ENDIF + ENDDO + + F_abs_sum = 0._r8 + DO i=snl_top,snl_btm,1 + F_abs_sum = F_abs_sum + F_abs(i) + ENDDO + + !ENDDO !ENDDO WHILE (flg_dover > 0) + + ! Energy conservation check: + ! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected) + energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls) + IF (mpas_is_root) THEN + IF (abs(energy_sum) > 0.00001_r8) THEN + write (iulog,"(a,e13.6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum + write(iulog,*) "F_abs_sum: ",F_abs_sum + write(iulog,*) "F_btm_net: ",F_btm_net + write(iulog,*) "F_sfc_pls: ",F_sfc_pls + write(iulog,*) "mu_not*pi*flx_slrd_lcl(bnd_idx): ", mu_not*pi*flx_slrd_lcl(bnd_idx) + write(iulog,*) "flx_slri_lcl(bnd_idx)", flx_slri_lcl(bnd_idx) + write(iulog,*) "bnd_idx", bnd_idx + write(iulog,*) "F_abs", F_abs + write(iulog,*) "albedo", albedo + CALL CoLM_stop('SNICAR-AD energy conservation check failed.') + ENDIF + ENDIF + + albout_lcl(bnd_idx) = albedo + ! Check that albedo is less than 1 + IF (mpas_is_root) THEN + IF (albout_lcl(bnd_idx) > 1.0) THEN + write (iulog,*) "SNICAR ERROR: Albedo > 1.0: " + write (iulog,*) "SNICAR STATS: bnd_idx= ",bnd_idx + write (iulog,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), & + " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx) + write (iulog,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl + write (iulog,*) "SNICAR STATS: coszen= ", coszen, " flg_slr= ", flg_slr_in + + write (iulog,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1) + write (iulog,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1) + write (iulog,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1) + write (iulog,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1) + write (iulog,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1) + + write (iulog,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4) + write (iulog,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3) + write (iulog,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2) + write (iulog,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1) + write (iulog,*) "SNICAR STATS: L_snw(0)= ", L_snw(0) + + write (iulog,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(-4) + write (iulog,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(-3) + write (iulog,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(-2) + write (iulog,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(-1) + write (iulog,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(0) + + CALL CoLM_stop('SNICAR-AD snow-grain radius is outside its valid range.') + ENDIF + ENDIF + + ENDDO ! loop over wvl bands + + + ! Weight output NIR albedo appropriately + albout(1) = albout_lcl(1) + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx) + ENDDO + albout(2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + + ! Weight output NIR absorbed layer fluxes (flx_abs) appropriately + flx_abs(:,1) = flx_abs_lcl(:,1) + DO i=snl_top,1,1 + flx_sum = 0._r8 + DO bnd_idx= nir_bnd_bgn,nir_bnd_end + flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx) + ENDDO + flx_abs(i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + ENDDO + + ! near-IR direct albedo/absorption adjustment for high solar zenith angles + ! solar zenith angle parameterization + ! calculate the scaling factor for NIR direct albedo IF SZA>75 degree + IF ((mu_not < mu_75) .and. (flg_slr_in == 1)) THEN + sza_c1 = sza_a0 + sza_a1 * mu_not + sza_a2 * mu_not**2 + sza_c0 = sza_b0 + sza_b1 * mu_not + sza_b2 * mu_not**2 + sza_factor = sza_c1 * (log10(snw_rds_lcl(snl_top) * c1) - c6) + sza_c0 + flx_sza_adjust = albout(2) * (sza_factor-c1) * sum(flx_wgt(nir_bnd_bgn:nir_bnd_end)) + albout(2) = albout(2) * sza_factor + flx_abs(snl_top,2) = flx_abs(snl_top,2) - flx_sza_adjust + ENDIF + + ! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo + ELSEIF ( (coszen > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) THEN + albout(1) = albsfc(1) + albout(2) = albsfc(2) + + ! There is either zero snow, or no sun + ELSE + albout(1) = 0._r8 + albout(2) = 0._r8 + ENDIF ! IF column has snow and coszen > 0 + + ! END associate + + END SUBROUTINE SNICAR_AD_RT + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_grain( dtime , snl , dz , & + qflx_snow_grnd , qflx_snwcp_ice , qflx_snofrz_lyr , & + do_capsnow , frac_sno , h2osno , & + h2osno_liq , h2osno_ice , & + t_soisno , t_grnd , & + forc_t , snw_rds ) + ! + ! !DESCRIPTION: + ! Updates the snow effective grain size (radius). + ! Contributions to grain size evolution are from: + ! 1. vapor redistribution (dry snow) + ! 2. liquid water redistribution (wet snow) + ! 3. re-freezing of liquid water + ! + ! Vapor redistribution: Method is to retrieve 3 best-bit parameters that + ! depend on snow temperature, temperature gradient, and density, + ! that are derived from the microphysical model described in: + ! Flanner and Zender (2006), Linking snowpack microphysics and albedo + ! evolution, J. Geophys. Res., 111, D12208, doi:10.1029/2005JD006834. + ! The parametric equation has the form: + ! dr/dt = drdt_0*(tau/(dr_fresh+tau))^(1/kappa), WHERE: + ! r is the effective radius, + ! tau and kappa are best-fit parameters, + ! drdt_0 is the initial rate of change of effective radius, and + ! dr_fresh is the difference between the current and fresh snow states + ! (r_current - r_fresh). + ! + ! Liquid water redistribution: Apply the grain growth FUNCTION from: + ! Brun, E. (1989), Investigation of wet-snow metamorphism in respect of + ! liquid-water content, Annals of Glaciology, 13, 22-26. + ! There are two parameters that describe the grain growth rate as + ! a FUNCTION of snow liquid water content (LWC). The "LWC=0" parameter + ! is zeroed here because we are accounting for dry snowing with a + ! different representation + ! + ! Re-freezing of liquid water: Assume that re-frozen liquid water clumps + ! into an arbitrarily large effective grain size (snw_rds_refrz). + ! The phenomenon is observed (Grenfell), but so far unquantified, as far as + ! I am aware. + ! + ! !USES: + ! + ! DAI, Dec. 29, 2022 + !----------------------------------------------------------------------- + ! !ARGUMENTS: + + IMPLICIT NONE + + real(r8) , intent(in) :: dtime ! land model time step [sec] + + integer , intent(in) :: snl ! negative number of snow layers (col) [nbr] + real(r8) , intent(in) :: dz ( maxsnl+1:1 ) ! layer thickness (col,lyr) [m] + + real(r8) , intent(in) :: qflx_snow_grnd ! snow on ground after interception (col) [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snwcp_ice ! excess precipitation due to snow capping [kg m-2 s-1] + real(r8) , intent(in) :: qflx_snofrz_lyr ( maxsnl+1:0 ) ! snow freezing rate (col,lyr) [kg m-2 s-1] + + logical , intent(in) :: do_capsnow ! true => DO snow capping + real(r8) , intent(in) :: frac_sno ! fraction of ground covered by snow (0 to 1) + real(r8) , intent(in) :: h2osno ! snow water (col) [mm H2O] + real(r8) , intent(in) :: h2osno_liq ( maxsnl+1:0 ) ! liquid water content (col,lyr) [kg m-2] + real(r8) , intent(in) :: h2osno_ice ( maxsnl+1:0 ) ! ice content (col,lyr) [kg m-2] + + real(r8) , intent(in) :: t_soisno ( maxsnl+1:1 ) ! soil and snow temperature (col,lyr) [K] + real(r8) , intent(in) :: t_grnd ! ground temperature (col) [K] + real(r8) , intent(in) :: forc_t ! Atmospheric temperature (col) [K] + + real(r8) , intent(inout) :: snw_rds ( maxsnl+1:0 ) ! effective grain radius (col,lyr) [microns, m-6] + + ! DAI, Dec. 29, 2022 + !----------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + integer :: snl_top ! top snow layer index [idx] + integer :: snl_btm ! bottom snow layer index [idx] + integer :: i ! layer index [idx] + ! integer :: c_idx ! column index [idx] + integer :: fc ! snow column filter index [idx] + integer :: T_idx ! snow aging lookup table temperature index [idx] + integer :: Tgrd_idx ! snow aging lookup table temperature gradient index [idx] + integer :: rhos_idx ! snow aging lookup table snow density index [idx] + real(r8) :: t_snotop ! temperature at upper layer boundary [K] + real(r8) :: t_snobtm ! temperature at lower layer boundary [K] + real(r8) :: dTdz(maxsnl:0) ! snow temperature gradient (col,lyr) [K m-1] + real(r8) :: bst_tau ! snow aging parameter retrieved from lookup table [hour] + real(r8) :: bst_kappa ! snow aging parameter retrieved from lookup table [unitless] + real(r8) :: bst_drdt0 ! snow aging parameter retrieved from lookup table [um hr-1] + real(r8) :: dr ! incremental change in snow effective radius [um] + real(r8) :: dr_wet ! incremental change in snow effective radius from wet growth [um] + real(r8) :: dr_fresh ! difference between fresh snow r_e and current r_e [um] + real(r8) :: newsnow ! fresh snowfall [kg m-2] + real(r8) :: refrzsnow ! re-frozen snow [kg m-2] + real(r8) :: frc_newsnow ! fraction of layer mass that is new snow [frc] + real(r8) :: frc_oldsnow ! fraction of layer mass that is old snow [frc] + real(r8) :: frc_refrz ! fraction of layer mass that is re-frozen snow [frc] + real(r8) :: frc_liq ! fraction of layer mass that is liquid water[frc] + real(r8) :: rhos ! snow density [kg m-3] + real(r8) :: h2osno_lyr ! liquid + solid H2O in snow layer [kg m-2] + real(r8) :: cdz(maxsnl+1:0) ! column average layer thickness [m] + real(r8) :: snw_rds_fresh ! fresh snow radius [microns] + + real(r8) :: snot_top ! temperature in top snow layer (col) [K] + real(r8) :: dTdz_top ! temperature gradient in top layer (col) [K m-1] + real(r8) :: snw_rds_top ! effective grain radius, top layer (col) [microns, m-6] + real(r8) :: sno_liq_top ! liquid water fraction (mass) in top snow layer (col) [frc] + + !--------------------------------------------------------------------------! + + ! associate( & + ! snl => col_pp%snl , & ! Input: [integer (:) ] negative number of snow layers (col) [nbr] + ! dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer thickness (col,lyr) [m] + + ! qflx_snow_grnd => col_wf%qflx_snow_grnd , & ! Input: [real(r8) (:) ] snow on ground after interception (col) [kg m-2 s-1] + ! qflx_snwcp_ice => col_wf%qflx_snwcp_ice , & ! Input: [real(r8) (:) ] excess precipitation due to snow capping [kg m-2 s-1] + ! qflx_snofrz_lyr => col_wf%qflx_snofrz_lyr , & ! Input: [real(r8) (:,:) ] snow freezing rate (col,lyr) [kg m-2 s-1] + + ! do_capsnow => col_ws%do_capsnow , & ! Input: [logical (:) ] true => DO snow capping + ! frac_sno => col_ws%frac_sno_eff , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + ! h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (col) [mm H2O] + ! h2osno_liq => col_ws%h2osno_liq , & ! Input: [real(r8) (:,:) ] liquid water content (col,lyr) [kg m-2] + ! h2osno_ice => col_ws%h2osno_ice , & ! Input: [real(r8) (:,:) ] ice content (col,lyr) [kg m-2] + ! snw_rds => col_ws%snw_rds , & ! Output: [real(r8) (:,:) ] effective grain radius (col,lyr) [microns, m-6] + ! snw_rds_top => col_ws%snw_rds_top , & ! Output: [real(r8) (:) ] effective grain radius, top layer (col) [microns, m-6] + ! sno_liq_top => col_ws%sno_liq_top , & ! Output: [real(r8) (:) ] liquid water fraction (mass) in top snow layer (col) [frc] + + ! t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil and snow temperature (col,lyr) [K] + ! t_grnd => col_es%t_grnd , & ! Input: [real(r8) (:) ] ground temperature (col) [K] + ! snot_top => col_es%snot_top , & ! Output: [real(r8) (:) ] temperature in top snow layer (col) [K] + ! dTdz_top => col_es%dTdz_top & ! Output: [real(r8) (:) ] temperature gradient in top layer (col) [K m-1] + ! ) + + + IF (snl < 0 .and. h2osno > 0._r8) THEN + + snl_btm = 0 + snl_top = snl + 1 + + cdz(snl_top:snl_btm)=frac_sno*dz(snl_top:snl_btm) + + ! loop over snow layers + DO i = snl_top, snl_btm, 1 + ! + !********** 1. DRY SNOW AGING *********** + ! + h2osno_lyr = h2osno_liq(i) + h2osno_ice(i) + + ! temperature gradient + IF (i == snl_top) THEN + ! top layer + t_snotop = t_soisno(snl_top) + t_snobtm = (t_soisno(i+1)*dz(i) & + + t_soisno(i)*dz(i+1)) & + / (dz(i)+dz(i+1)) + ELSE + t_snotop = (t_soisno(i-1)*dz(i) & + + t_soisno(i)*dz(i-1)) & + / (dz(i)+dz(i-1)) + t_snobtm = (t_soisno(i+1)*dz(i) & + + t_soisno(i)*dz(i+1)) & + / (dz(i)+dz(i+1)) + ENDIF + + dTdz(i) = abs((t_snotop - t_snobtm) / cdz(i)) + + ! snow density + rhos = (h2osno_liq(i)+h2osno_ice(i)) / cdz(i) + + ! make sure rhos doesn't drop below 50 (see rhos_idx below) + rhos=max(50._r8,rhos) + + ! best-fit table indecies + T_idx = nint((t_soisno(i)-223) / 5) + 1 + Tgrd_idx = nint(dTdz(i) / 10) + 1 + rhos_idx = nint((rhos-50) / 50) + 1 + + ! boundary check: + IF (T_idx < idx_T_min) THEN + T_idx = idx_T_min + ENDIF + IF (T_idx > idx_T_max) THEN + T_idx = idx_T_max + ENDIF + IF (Tgrd_idx < idx_Tgrd_min) THEN + Tgrd_idx = idx_Tgrd_min + ENDIF + IF (Tgrd_idx > idx_Tgrd_max) THEN + Tgrd_idx = idx_Tgrd_max + ENDIF + IF (rhos_idx < idx_rhos_min) THEN + rhos_idx = idx_rhos_min + ENDIF + IF (rhos_idx > idx_rhos_max) THEN + rhos_idx = idx_rhos_max + ENDIF + + ! best-fit parameters + bst_tau = snowage_tau(rhos_idx,Tgrd_idx,T_idx) + bst_kappa = snowage_kappa(rhos_idx,Tgrd_idx,T_idx) + bst_drdt0 = snowage_drdt0(rhos_idx,Tgrd_idx,T_idx) + + ! change in snow effective radius, using best-fit parameters + ! added checks suggested by mgf. --HW 10/15/2015 + dr_fresh = snw_rds(i)-snw_rds_min + +#ifdef MODAL_AER + IF ( abs(dr_fresh) < 1.0e-8_r8 ) THEN + dr_fresh = 0.0_r8 + ELSEIF ( dr_fresh < 0.0_r8 ) THEN + IF (mpas_is_root) THEN + write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min + CALL CoLM_stop('SNICAR snow-grain growth is negative.') + ENDIF + ENDIF + + dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1._r8/bst_kappa)) * (dtime/3600._r8) +#else + dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1/bst_kappa)) * (dtime/3600) +#endif + ! + !********** 2. WET SNOW AGING *********** + ! + ! We are assuming wet and dry evolution occur simultaneously, and + ! the contributions from both can be summed. + ! This is justified by setting the linear offset constant C1_liq_Brun89 to zero [Brun, 1989] + + ! liquid water faction + frc_liq = min(0.1_r8, (h2osno_liq(i) / (h2osno_liq(i)+h2osno_ice(i)))) + + !dr_wet = 1E6_r8*(dtime*(C1_liq_Brun89 + C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*(snw_rds(i)/1E6)**(2))) + !simplified, units of microns: + dr_wet = 1E18_r8*(dtime*(C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*snw_rds(i)**(2))) + + dr = dr + dr_wet + + ! + !********** 3. SNOWAGE SCALING (TURNED OFF BY DEFAULT) ************* + ! + ! Multiply rate of change of effective radius by some constant, xdrdt + IF (flg_snoage_scl) THEN + dr = dr*xdrdt + ENDIF + + ! + !********** 4. INCREMENT EFFECTIVE RADIUS, ACCOUNTING FOR: *********** + ! DRY AGING + ! WET AGING + ! FRESH SNOW + ! RE-FREEZING + ! + ! new snowfall [kg/m2] + IF (do_capsnow .and. .not. use_extrasnowlayers) THEN + newsnow = max(0._r8, (qflx_snwcp_ice*dtime)) + ELSE + newsnow = max(0._r8, (qflx_snow_grnd*dtime)) + ENDIF + + ! snow that has re-frozen [kg/m2] + refrzsnow = max(0._r8, (qflx_snofrz_lyr(i)*dtime)) + + ! fraction of layer mass that is re-frozen + frc_refrz = refrzsnow / h2osno_lyr + + ! fraction of layer mass that is new snow + IF (i == snl_top) THEN + frc_newsnow = newsnow / h2osno_lyr + ELSE + frc_newsnow = 0._r8 + ENDIF + + IF ((frc_refrz + frc_newsnow) > 1._r8) THEN + frc_refrz = frc_refrz / (frc_refrz + frc_newsnow) + frc_newsnow = 1._r8 - frc_refrz + frc_oldsnow = 0._r8 + ELSE + frc_oldsnow = 1._r8 - frc_refrz - frc_newsnow + ENDIF + + ! temperature dependent fresh grain size + snw_rds_fresh = FreshSnowRadius (forc_t) + + ! mass-weighted mean of fresh snow, old snow, and re-frozen snow effective radius + snw_rds(i) = (snw_rds(i)+dr)*frc_oldsnow + snw_rds_fresh*frc_newsnow + snw_rds_refrz*frc_refrz + ! + !********** 5. CHECK BOUNDARIES *********** + ! + ! boundary check + IF (snw_rds(i) < snw_rds_min) THEN + snw_rds(i) = snw_rds_min + ENDIF + + IF (snw_rds(i) > snw_rds_max) THEN + snw_rds(i) = snw_rds_max + ENDIF + + ! set top layer variables for history files + IF (i == snl_top) THEN + snot_top = t_soisno(i) + dTdz_top = dTdz(i) + snw_rds_top = snw_rds(i) + sno_liq_top = h2osno_liq(i) / (h2osno_liq(i)+h2osno_ice(i)) + ENDIF + + ENDDO + ENDIF ! ENDIF (snl < 0 ) + + ! Special CASE: snow on ground, but not enough to have defined a snow layer: + ! set snw_rds to fresh snow grain size: + + IF (snl >= 0 .and. h2osno > 0._r8) THEN + snw_rds(0) = snw_rds_min + ENDIF + + ! END associate + + END SUBROUTINE SnowAge_grain + !----------------------------------------------------------------------- + + + SUBROUTINE SnowOptics_init( fsnowoptics ) + + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=256), intent(in) :: fsnowoptics ! snow optical properties file name + character(len= 32) :: subname = 'SnowOptics_init' ! SUBROUTINE name + integer :: atm_type_index ! index for atmospheric type + + logical :: readvar ! determine IF variable was read from NetCDF file + !----------------------------------------------------------------------- + + readvar = .true. + + atm_type_index = atm_type_default + ! Define atmospheric type + IF (trim(snicar_atm_type) == 'default') THEN + atm_type_index = atm_type_default + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_winter') THEN + atm_type_index = atm_type_mid_latitude_winter + ELSEIF (trim(snicar_atm_type) == 'mid-latitude_summer') THEN + atm_type_index = atm_type_mid_latitude_summer + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_winter') THEN + atm_type_index = atm_type_sub_Arctic_winter + ELSEIF (trim(snicar_atm_type) == 'sub-Arctic_summer') THEN + atm_type_index = atm_type_sub_Arctic_summer + ELSEIF (trim(snicar_atm_type) == 'summit_Greenland') THEN + atm_type_index = atm_type_summit_Greenland + ELSEIF (trim(snicar_atm_type) == 'high_mountain') THEN + atm_type_index = atm_type_high_mountain + ELSE + IF (mpas_is_root) THEN + write(iulog,*) "snicar_atm_type = ", snicar_atm_type + CALL CoLM_stop('SNICAR-AD received an unsupported atmospheric profile.') + ENDIF + ENDIF + + ! + ! Open optics file: + IF (mpas_is_root) THEN + write(iulog,*) 'Attempting to read snow optical properties .....' + write(iulog,*) subname,trim(fsnowoptics) + ENDIF + + ! direct-beam snow Mie parameters: + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ice_drc', ss_alb_snw_drc) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ice_drc', asm_prm_snw_drc) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ice_drc', ext_cff_mss_snw_drc) + + ! diffuse snow Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ice_dfs', ss_alb_snw_dfs) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ice_dfs', asm_prm_snw_dfs) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ice_dfs', ext_cff_mss_snw_dfs) + + !!! Direct and diffuse flux under different atmospheric conditions + ! Direct-beam incident spectral flux: + CALL ncio_read_bcast_serial (fsnowoptics, 'flx_wgt_dir', flx_wgt_dir) + + ! Diffuse incident spectral flux: + CALL ncio_read_bcast_serial (fsnowoptics, 'flx_wgt_dif', flx_wgt_dif) + +#ifdef MODAL_AER + ! size-dependent BC parameters and BC enhancement factors + IF (mpas_is_root) THEN + write(iulog,*) 'Attempting to read optical properties for within-ice BC (modal aerosol treatment) ...' + ENDIF + ! + ! BC species 1 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc1) + ! + ! BC species 2 Mie parameters (identical, before enhancement factors applied) + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bc_mam', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bc_mam', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bc_mam', ext_cff_mss_bc2) + ! + ! size-dependent BC absorption enhancement factors for within-ice BC + CALL ncio_read_bcast_serial (fsnowoptics, 'bcint_enh_mam', bcenh) + ! +#else + ! bulk aerosol treatment + ! BC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphil', ss_alb_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphil', asm_prm_bc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphil', ext_cff_mss_bc1) + + ! + ! BC species 2 Mie parameters + ! + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_bcphob', ss_alb_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_bcphob', asm_prm_bc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_bcphob', ext_cff_mss_bc2) + ! +#endif + ! + ! OC species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphil', ss_alb_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphil', asm_prm_oc1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphil', ext_cff_mss_oc1) + ! + ! OC species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_ocphob', ss_alb_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_ocphob', asm_prm_oc2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_ocphob', ext_cff_mss_oc2) + ! + ! dust species 1 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust01', ss_alb_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust01', asm_prm_dst1) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust01', ext_cff_mss_dst1) + ! + ! dust species 2 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust02', ss_alb_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust02', asm_prm_dst2) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust02', ext_cff_mss_dst2) + ! + ! dust species 3 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust03', ss_alb_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust03', asm_prm_dst3) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust03', ext_cff_mss_dst3) + ! + ! dust species 4 Mie parameters + CALL ncio_read_bcast_serial (fsnowoptics, 'ss_alb_dust04', ss_alb_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'asm_prm_dust04', asm_prm_dst4) + CALL ncio_read_bcast_serial (fsnowoptics, 'ext_cff_mss_dust04', ext_cff_mss_dst4) + ! + ! + + IF (mpas_is_root) THEN + write(iulog,*) 'Successfully read snow optical properties' + ENDIF + + + ! print some diagnostics: + IF (mpas_is_root) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for direct-beam ice, rds=100um: ', & + ss_alb_snw_drc(71,1), ss_alb_snw_drc(71,2), ss_alb_snw_drc(71,3), & + ss_alb_snw_drc(71,4), ss_alb_snw_drc(71,5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for diffuse ice, rds=100um: ', & + ss_alb_snw_dfs(71,1), ss_alb_snw_dfs(71,2), ss_alb_snw_dfs(71,3), & + ss_alb_snw_dfs(71,4), ss_alb_snw_dfs(71,5) + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Including OC aerosols from snow radiative transfer calculations' + ELSE + write (iulog,*) 'SNICAR: Excluding OC aerosols from snow radiative transfer calculations' + ENDIF + ENDIF + ! +#ifdef MODAL_AER + IF (mpas_is_root) THEN + ! unique dimensionality for modal aerosol optical properties + write (iulog,*) 'SNICAR: Subset of Mie single scatter albedos for BC: ', & + ss_alb_bc1(1,1), ss_alb_bc1(1,2), ss_alb_bc1(2,1), ss_alb_bc1(5,1), ss_alb_bc1(1,10), ss_alb_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of Mie mass extinction coefficients for BC: ', & + ext_cff_mss_bc2(1,1), ext_cff_mss_bc2(1,2), ext_cff_mss_bc2(2,1), ext_cff_mss_bc2(5,1), ext_cff_mss_bc2(1,10),& + ext_cff_mss_bc1(1,10) + write (iulog,*) 'SNICAR: Subset of Mie asymmetry parameters for BC: ', & + asm_prm_bc1(1,1), asm_prm_bc1(1,2), asm_prm_bc1(2,1), asm_prm_bc1(5,1), asm_prm_bc1(1,10), asm_prm_bc2(1,10) + write (iulog,*) 'SNICAR: Subset of BC absorption enhancement factors: ', & + bcenh(1,1,1), bcenh(1,2,1), bcenh(1,1,2), bcenh(2,1,1), bcenh(5,10,1), bcenh(5,1,8), bcenh(5,10,8) + ENDIF +#else + IF (mpas_is_root) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic BC: ', & + ss_alb_bc1(1), ss_alb_bc1(2), ss_alb_bc1(3), ss_alb_bc1(4), ss_alb_bc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic BC: ', & + ss_alb_bc2(1), ss_alb_bc2(2), ss_alb_bc2(3), ss_alb_bc2(4), ss_alb_bc2(5) + ENDIF +#endif + + IF (mpas_is_root) THEN + IF (DO_SNO_OC) THEN + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophillic OC: ', & + ss_alb_oc1(1), ss_alb_oc1(2), ss_alb_oc1(3), ss_alb_oc1(4), ss_alb_oc1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for hydrophobic OC: ', & + ss_alb_oc2(1), ss_alb_oc2(2), ss_alb_oc2(3), ss_alb_oc2(4), ss_alb_oc2(5) + ENDIF + + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 1: ', & + ss_alb_dst1(1), ss_alb_dst1(2), ss_alb_dst1(3), ss_alb_dst1(4), ss_alb_dst1(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 2: ', & + ss_alb_dst2(1), ss_alb_dst2(2), ss_alb_dst2(3), ss_alb_dst2(4), ss_alb_dst2(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 3: ', & + ss_alb_dst3(1), ss_alb_dst3(2), ss_alb_dst3(3), ss_alb_dst3(4), ss_alb_dst3(5) + write (iulog,*) 'SNICAR: Mie single scatter albedos for dust species 4: ', & + ss_alb_dst4(1), ss_alb_dst4(2), ss_alb_dst4(3), ss_alb_dst4(4), ss_alb_dst4(5) + write(iulog,*) + ENDIF + + END SUBROUTINE SnowOptics_init + !----------------------------------------------------------------------- + + + SUBROUTINE SnowAge_init( fsnowaging ) + + USE MOD_NetCDFSerial + + IMPLICIT NONE + + character(len=256), intent(in) :: fsnowaging ! snow aging parameters file name + character(len= 32) :: subname = 'SnowAge_init' ! SUBROUTINE name + ! + ! Open snow aging (effective radius evolution) file: + IF (mpas_is_root) THEN + write(iulog,*) 'Attempting to read snow aging parameters .....' + write(iulog,*) subname,trim(fsnowaging) + ENDIF + + ! + ! SNOW aging parameters + ! + CALL ncio_read_bcast_serial (fsnowaging, 'tau', snowage_tau) + CALL ncio_read_bcast_serial (fsnowaging, 'kappa', snowage_kappa) + CALL ncio_read_bcast_serial (fsnowaging, 'drdsdt0', snowage_drdt0) + + ! + IF (mpas_is_root) THEN + write(iulog,*) 'Successfully read snow aging properties' + ENDIF + ! + ! print some diagnostics: + IF (mpas_is_root) THEN + write (iulog,*) 'SNICAR: snowage tau for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_tau(3,11,9) + write (iulog,*) 'SNICAR: snowage kappa for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_kappa(3,11,9) + write (iulog,*) 'SNICAR: snowage dr/dt_0 for T=263K, dTdz = 100 K/m, rhos = 150 kg/m3: ', snowage_drdt0(3,11,9) + ENDIF + + END SUBROUTINE SnowAge_init + !----------------------------------------------------------------------- + + + real(r8) FUNCTION FreshSnowRadius (forc_t) + ! + ! !DESCRIPTION: + ! Returns fresh snow grain radius, which is linearly dependent on temperature. + ! This is implemented to remedy an outstanding bias that SNICAR has in initial + ! grain size. See e.g. Sandells et al, 2017 for a discussion (10.5194/tc-11-229-2017). + ! + ! Yang et al. (2017), 10.1016/j.jqsrt.2016.03.033 + ! discusses grain size observations, which suggest a temperature dependence. + ! + ! !REVISION HISTORY: + ! Author: Leo VanKampenhout + ! + ! !USES: + USE MOD_Const_Physical, only: tfrz + USE MOD_Aerosol, only: fresh_snw_rds_max + + ! !ARGUMENTS: + real(r8), intent(in) :: forc_t ! atmospheric temperature (Kelvin) + ! + ! !LOCAL VARIABLES: + !----------------------------------------------------------------------- + real(r8), parameter :: tmin = tfrz - 30._r8 ! start of linear ramp + real(r8), parameter :: tmax = tfrz - 0._r8 ! END of linear ramp + real(r8), parameter :: gs_min = snw_rds_min ! minimum value + real(r8) :: gs_max ! maximum value + + IF ( fresh_snw_rds_max <= snw_rds_min )THEN + FreshSnowRadius = snw_rds_min + ELSE + gs_max = fresh_snw_rds_max + + IF (forc_t < tmin) THEN + FreshSnowRadius = gs_min + ELSEIF (forc_t > tmax) THEN + FreshSnowRadius = gs_max + ELSE + FreshSnowRadius = (tmax-forc_t)/(tmax-tmin)*gs_min + & + (forc_t-tmin)/(tmax-tmin)*gs_max + ENDIF + ENDIF + + END FUNCTION FreshSnowRadius + +END MODULE MOD_SnowSnicar_HiRes diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 new file mode 100644 index 0000000000..372873169a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSnowHydrology.F90 @@ -0,0 +1,2327 @@ +#include + +MODULE MOD_SoilSnowHydrology + +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_SNICAR, & + DEF_URBAN_RUN, DEF_USE_IRRIGATION, & + DEF_SPLIT_SOILSNOW, DEF_Runoff_SCHEME, & + DEF_DA_TWS_GRACE, DEF_Optimize_Baseflow, & + DEF_USE_Dynamic_Wetland + USE MOD_LandPatch, only: landpatch + USE MOD_Runoff + USE MOD_Hydro_VIC + USE MOD_Hydro_VIC_Variables + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: WATER_2014 + PUBLIC :: WATER_VSF + PUBLIC :: snowwater + PUBLIC :: soilwater + PUBLIC :: snowwater_snicar + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: groundwater + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + + SUBROUTINE WATER_2014 (ipatch,patchtype,lb ,nl_soil ,deltim ,& + z_soisno ,dz_soisno ,zi_soisno ,bsw ,porsl ,& + psi0 ,hksati ,theta_r ,fsatmax ,fsatdcf ,& + elvstd ,BVIC ,rootr ,rootflux ,t_soisno ,& + wliq_soisno ,wice_soisno ,smp ,hk ,pg_rain ,& + sm ,etr ,qseva ,qsdew ,qsubl ,& + qfros ,qseva_soil ,qsdew_soil ,qsubl_soil ,qfros_soil ,& + qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,fsno ,& + rsur ,rnof ,qinfl ,pondmx ,ssi ,& + wimp ,smpmin ,zwt ,wdsrf ,wa ,& + qcharge ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy ) + +!======================================================================= +! this is the main SUBROUTINE to execute the calculation of +! hydrological processes +! +! Original author: Yongjiu Dai, /09/1999/, /08/2002/, /04/2014/ +! +! FLOW DIAGRAM FOR WATER_2014.F90 +! +! WATER_2014 ===> snowwater +! SurfaceRunoff_TOPMOD +! soilwater +! SubsurfaceRunoff_TOPMOD +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_Vars_TimeInvariants, only: vic_b_infilt, vic_Dsmax, vic_Ds, vic_Ws, vic_c + USE MOD_Vars_1DFluxes, only: fevpg +#ifdef CROP + USE MOD_Vars_Global, only : irrig_method_paddy, pondmxc + use MOD_LandPFT, only : patch_pft_s, patch_pft_e + use MOD_Vars_PFTimeVariables, only: irrig_method_p +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ,&! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=land water bodies, 99=ocean + + integer, intent(in) :: & + lb ,&! lower bound of array + nl_soil ! upper bound of array + + real(r8), intent(in) :: & + deltim ,&! time step (s) + ! wtfact ,&! (updated to gridded 'fsatmax' data) fraction of model area with high water table + pondmx ,&! ponding depth (mm) + ssi ,&! irreducible water saturation of snow + wimp ,&! water impermeable if porosity less than wimp + smpmin ,&! restriction for min of soil poten. (mm) + elvstd ,&! standard deviation of elevation (m) + BVIC ,&! + + z_soisno (lb:nl_soil) ,&! layer depth (m) + dz_soisno(lb:nl_soil) ,&! layer thickness (m) + zi_soisno(lb-1:nl_soil) ,&! interface level below a "z" level (m) + + bsw(1:nl_soil) ,&! Clapp-Hornberger "B" + porsl(1:nl_soil) ,&! saturated volumetric soil water content(porosity) + psi0(1:nl_soil) ,&! saturated soil suction (mm) (NEGATIVE) + hksati(1:nl_soil) ,&! hydraulic conductivity at saturation (mm h2o/s) + theta_r(1:nl_soil) ,&! residual moisture content [-] + fsatmax ,&! maximum saturated area fraction [-] + fsatdcf ,&! decay factor in calculation of saturated area fraction [1/m] + rootr(1:nl_soil) ,&! water uptake fraction from different layers, all layers add to 1.0 + rootflux(1:nl_soil) ,&! root uptake from different layer, all layers add to transpiration + + t_soisno(lb:nl_soil) ,&! soil/snow skin temperature (K) + pg_rain ,&! rainfall after removal of interception (mm h2o/s) + sm ,&! snow melt (mm h2o/s) + etr ,&! actual transpiration (mm h2o/s) + qseva ,&! ground surface evaporation rate (mm h2o/s) + qsdew ,&! ground surface dew formation (mm h2o /s) [+] + qsubl ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros ,&! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil ,&! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil ,&! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil ,&! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow ,&! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow ,&! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow ,&! surface dew added to snow pack (mm h2o /s) [+] + fsno ! snow fractional cover + + real(r8), intent(inout) :: & + wice_soisno(lb:nl_soil) ,&! ice lens (kg/m2) + wliq_soisno(lb:nl_soil) ! liquid water (kg/m2) + + real(r8), intent(out) :: & + smp(1:nl_soil) ,&! soil matrix potential [mm] + hk (1:nl_soil) ! hydraulic conductivity [mm h2o/m] + + real(r8), intent(inout) :: & + zwt ,&! the depth from ground (soil) surface to water table [m] + wdsrf ,&! depth of surface water [mm] + wa ! water storage in aquifer [mm] + + real(r8), intent(out) :: & + rsur ,&! surface runoff (mm h2o/s) + rnof ,&! total runoff (mm h2o/s) + qinfl ,&! infiltration rate (mm h2o/s) + qcharge ! groundwater recharge (positive to aquifer) [mm/s] + +! SNICAR model variables +! Aerosol Fluxes (Jan. 07, 2023) + real(r8), intent(in) :: forc_aer ( 14 ) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + + real(r8), intent(inout) :: & + mss_bcpho (lb:0) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lb:0) ,&! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lb:0) ,&! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lb:0) ,&! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lb:0) ,&! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lb:0) ,&! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lb:0) ,&! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lb:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) +! END SNICAR model variables + +! irrigation variable + real(r8), intent(in) :: & + qflx_irrig_drip , &! irrigation flux from drip irrigation [mm/s] + qflx_irrig_flood , &! irrigation flux from flood irrigation [mm/s] + qflx_irrig_paddy ! irrigation flux from paddy irrigation [mm/s] + +!-------------------------- Local Variables ---------------------------- + + integer j ! loop counter + + real(r8) :: & + eff_porosity(1:nl_soil) ,&! effective porosity = porosity - vol_ice + dwat(1:nl_soil) ,&! change in soil water + gwat ,&! net water input from top (mm/s) + rsubst ,&! subsurface runoff (mm h2o/s) + vol_liq(1:nl_soil) ,&! partial volume of liquid water in layer + vol_ice(1:nl_soil) ,&! partial volume of ice lens in layer + icefrac(1:nl_soil) ,&! ice fraction (-) + zmm (1:nl_soil) ,&! layer depth (mm) + dzmm(1:nl_soil) ,&! layer thickness (mm) + zimm(0:nl_soil) ! interface level below a "z" level (mm) + + real(r8) :: err_solver, w_sum + real(r8) :: gwat_prev + integer :: ps, pe, m + + real(r8) :: wliq_soisno_tmp(1:nl_soil) + +!======================================================================= +! [1] update the liquid water within snow layer and the water onto soil +!======================================================================= + + +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva + ELSE + IF ((.not.DEF_USE_SNICAR) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + ENDIF + +ELSE + + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva_soil + ELSE + IF (.not. DEF_USE_SNICAR) THEN + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + gwat = gwat + pg_rain*(1-fsno) - qseva_soil + ENDIF +ENDIF + +#ifdef CROP + IF(DEF_USE_IRRIGATION)THEN + gwat = gwat + qflx_irrig_drip + qflx_irrig_flood + qflx_irrig_paddy + gwat = gwat + wdsrf/deltim + ENDIF +#endif + +!======================================================================= +! [2] surface runoff and infiltration +!======================================================================= + +IF(patchtype<=1)THEN ! soil ground only + + ! For water balance check, the sum of water in soil column before the calculation + w_sum = sum(wliq_soisno(1:)) + sum(wice_soisno(1:)) + wa + + ! porosity of soil, partial volume of ice and liquid + DO j = 1, nl_soil + vol_ice(j) = min(porsl(j), wice_soisno(j)/(dz_soisno(j)*denice)) + eff_porosity(j) = max(0.01, porsl(j)-vol_ice(j)) + vol_liq(j) = min(eff_porosity(j), wliq_soisno(j)/(dz_soisno(j)*denh2o)) + IF(porsl(j) < 1.e-6)THEN + icefrac(j) = 0. + ELSE + icefrac(j) = min(1.,vol_ice(j)/porsl(j)) + ENDIF + ENDDO + + ! surface runoff including water table and surface saturated area + + rsur = 0. + rsubst = 0. + + IF (DEF_Runoff_SCHEME == 0) THEN + ! 0: runoff scheme from TOPMODEL + + IF (gwat > 0.) THEN + CALL SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,fsatmax,fsatdcf,& + z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& + eff_porosity,icefrac,zwt,gwat,rsur) + ELSE + rsur = 0. + ENDIF + + ELSEIF (DEF_Runoff_SCHEME == 1) THEN + ! 1: runoff scheme from VIC model + + wliq_soisno_tmp(:) = 0 + CALL Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & + wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg(ipatch), rootflux, gwat, & + vic_b_infilt(ipatch), vic_Dsmax(ipatch), vic_Ds(ipatch), vic_Ws(ipatch), vic_c(ipatch),& + rsur, rsubst, wliq_soisno_tmp(1:nl_soil)) + + ELSEIF (DEF_Runoff_SCHEME == 2) THEN + ! 2: runoff scheme from XinAnJiang model + + CALL Runoff_XinAnJiang (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + elvstd, gwat, deltim, rsur, rsubst) + + ELSEIF (DEF_Runoff_SCHEME == 3) THEN + ! 3: runoff scheme from Simple VIC model + CALL Runoff_SimpleVIC (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + BVIC, gwat, deltim, rsur, rsubst) + + ENDIF +#ifdef CROP + IF(patchtype==0)THEN + IF(DEF_USE_IRRIGATION)THEN + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + DO m = ps, pe + IF(irrig_method_p(m) == irrig_method_paddy)THEN + wdsrf = rsur*deltim + rsur = 0. + IF(wdsrf.gt.pondmxc)THEN + wdsrf = pondmxc + rsur = rsur + (wdsrf - pondmxc)/deltim + ENDIF + ENDIF + ENDDO + ENDIF + ENDIF +#endif + ! infiltration into surface soil layer + qinfl = gwat - rsur - wdsrf/deltim + +!======================================================================= +! [3] determine the change of soil water +!======================================================================= + + ! convert length units from m to mm + zmm(1:) = z_soisno(1:)*1000. + dzmm(1:) = dz_soisno(1:)*1000. + zimm(0:) = zi_soisno(0:)*1000. + + CALL soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& + qinfl,etr,z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& + t_soisno(1:),vol_liq,vol_ice,smp,hk,icefrac,eff_porosity,& + porsl,hksati,bsw,psi0,rootr,rootflux,& + zwt,dwat,qcharge) + + ! update the mass of liquid water + DO j= 1, nl_soil + wliq_soisno(j) = wliq_soisno(j)+dwat(j)*dzmm(j) + ENDDO + + +!======================================================================= +! [4] subsurface runoff and the corrections +!======================================================================= + + CALL groundwater (nl_soil,deltim,pondmx,& + eff_porosity,icefrac,dz_soisno(1:),zi_soisno(0:),& + wice_soisno(1:),wliq_soisno(1:),& + porsl,psi0,bsw,zwt,wa,& + qcharge,rsubst) + + ! total runoff (mm/s) + rnof = rsubst + rsur + ! Renew the ice and liquid mass due to condensation +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + IF(lb >= 1)THEN + ! make consistent with how evap_grnd removed in infiltration + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros-qsubl) * deltim) + ENDIF + + err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & + - (gwat-etr-rnof)*deltim + + IF(lb >= 1)THEN + err_solver = err_solver-(qsdew+qfros-qsubl)*deltim + ENDIF + +ELSE + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew_soil * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros_soil-qsubl_soil) * deltim) + + err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & + - (gwat-etr-rnof)*deltim + + err_solver = err_solver-(qsdew_soil+qfros_soil-qsubl_soil)*deltim +ENDIF + +#if (defined CoLMDEBUG) + IF(abs(err_solver) > 1.e-3)THEN + write(6,*) 'Warning: water balance violation after all soilwater calculation', err_solver + ENDIF +#endif + + +!======================================================================= +! [6] assumed hydrological scheme for the wetland and glacier +!======================================================================= + +ELSE + IF(patchtype==2)THEN ! WETLAND + ! 09/20/2019, by Chaoqun Li: a potential bug below + ! surface runoff could > total runoff + ! original CoLM: rusr=0., qinfl=gwat, rsubst=0., rnof=0. + ! i.e., all water to be infiltration + qinfl = 0. + rsur = max(0.,gwat) + rsubst = 0. + rnof = 0. + DO j = 1, nl_soil + IF(t_soisno(j)>tfrz)THEN + wice_soisno(j) = 0.0 + wliq_soisno(j) = porsl(j)*dz_soisno(j)*1000. + ENDIF + ENDDO + ENDIF + IF(patchtype==3)THEN ! LAND ICE + rsur = max(0.0,gwat) + qinfl = 0. + rsubst = 0. + rnof = rsur + wice_soisno(1:nl_soil) = dz_soisno(1:nl_soil)*1000. + wliq_soisno(1:nl_soil) = 0.0 + ENDIF + + wa = 4800. + zwt = 0. + qcharge = 0. + +ENDIF + + END SUBROUTINE WATER_2014 + +!----------------------------------------------------------------------- + SUBROUTINE WATER_VSF (ipatch, patchtype,is_dry_lake, lb, nl_soil, deltim ,& + z_soisno ,dz_soisno ,zi_soisno ,bsw ,theta_r ,& + fsatmax ,fsatdcf ,topoweti ,alp_twi ,chi_twi ,& + mu_twi ,elvstd ,BVIC ,& +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm ,n_vgm ,L_vgm ,sc_vgm ,fc_vgm ,& +#endif + porsl ,psi0 ,hksati ,rootr ,rootflux ,& + t_soisno ,wliq_soisno ,wice_soisno ,smp ,hk ,& + pg_rain ,sm ,etr ,qseva ,qsdew ,& + qsubl ,qfros ,qseva_soil ,qsdew_soil ,qsubl_soil ,& + qfros_soil ,qseva_snow ,qsdew_snow ,qsubl_snow ,qfros_snow ,& + fsno ,frcsat ,rsur ,rsur_se ,rsur_ie ,& + rsubst ,rnof ,qinfl ,qlayer ,ssi ,& + pondmx ,wimp ,zwt ,wdsrf ,wa ,& + wetwat ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! irrigation variable + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy ) + +!=================================================================================== +! this is the main SUBROUTINE to execute the calculation of soil water processes +! +! Original author: Yongjiu Dai, /09/1999/, /08/2002/, /04/2014/ +! +! Modified by Shupeng Zhang /07/2023/ to USE Variably Saturated Flow algorithm +! Reference : +! Dai, Y., Zhang, S., Yuan, H., & Wei, N. (2019). +! Modeling Variably Saturated Flow in Stratified Soils +! With Explicit Tracking of Wetting Front and Water Table Locations. +! Water Resources Research. doi:10.1029/2019wr025368 +! +!=================================================================================== + + USE MOD_Precision + USE MOD_Hydro_SoilWater + USE MOD_Vars_TimeInvariants, only: wetwatmax + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_Vars_TimeInvariants, only: vic_b_infilt, vic_Dsmax, vic_Ds, vic_Ws, vic_c + USE MOD_Vars_1DFluxes, only: fevpg + USE MOD_Opt_Baseflow, only: scale_baseflow +#ifdef DataAssimilation + USE MOD_DA_TWS, only: fslp_k +#endif +#ifdef CROP + USE MOD_Vars_Global, only : irrig_method_paddy, pondmxc + use MOD_LandPFT, only : patch_pft_s, patch_pft_e + use MOD_Vars_PFTimeVariables, only: irrig_method_p +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ,& ! patch index + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=land water bodies, 99=ocean + logical, intent(in) :: is_dry_lake + + integer, intent(in) :: & + lb , &! lower bound of array + nl_soil ! upper bound of array + + real(r8), intent(in) :: & + deltim , &! time step (s) + ! wtfact , &! (updated to gridded 'fsatmax' data) fraction of model area with high water table + ssi , &! irreducible water saturation of snow + pondmx , &! ponding depth (mm) + wimp , &! water impermeable IF porosity less than wimp + elvstd , &! standard deviation of elevation (m) + BVIC , &! + z_soisno (lb:nl_soil) , &! layer depth (m) + dz_soisno(lb:nl_soil) , &! layer thickness (m) + zi_soisno(lb-1:nl_soil) , &! interface level below a "z" level (m) + bsw (1:nl_soil), & ! clapp and hornberger "b" parameter [-] + theta_r (1:nl_soil), & ! residual moisture content [-] + fsatmax , & ! maximum saturated area fraction [-] + fsatdcf , & ! decay factor in calculation of saturated area fraction [1/m] + topoweti , & ! mean topographic wetness index + alp_twi , & ! alpha in three parameter gamma distribution of twi + chi_twi , & ! chi in three parameter gamma distribution of twi + mu_twi , & ! mu in three parameter gamma distribution of twi +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm(1:nl_soil), & ! a parameter corresponding approximately to the inverse of the air-entry value + n_vgm (1:nl_soil), & ! a shape parameter [dimensionless] + L_vgm (1:nl_soil), & ! pore-connectivity parameter [dimensionless] + sc_vgm (1:nl_soil), & ! saturation at the air entry value in the classical vanGenuchten model [-] + fc_vgm (1:nl_soil), & ! a scaling factor by using air entry value in the Mualem model [-] +#endif + porsl(1:nl_soil) , &! saturated volumetric soil water content(porosity) + psi0(1:nl_soil) , &! saturated soil suction (mm) (NEGATIVE) + hksati(1:nl_soil), &! hydraulic conductivity at saturation (mm h2o/s) + rootr(1:nl_soil) , &! water uptake fraction from different layers, all layers add to 1.0 + rootflux(1:nl_soil),&! root uptake from different layer, all layers add to transpiration + + t_soisno(lb:nl_soil), &! soil/snow skin temperature (K) + pg_rain , &! rainfall after removal of interception (mm h2o/s) + sm , &! snow melt (mm h2o/s) + etr , &! actual transpiration (mm h2o/s) + qseva , &! ground surface evaporation rate (mm h2o/s) + qsdew , &! ground surface dew formation (mm h2o /s) [+] + qsubl , &! sublimation rate from snow pack (mm h2o /s) [+] + qfros , &! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil , &! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil , &! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil , &! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil , &! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow , &! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow , &! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow , &! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow , &! surface dew added to snow pack (mm h2o /s) [+] + fsno ! snow fractional cover + real(r8), intent(inout) :: & + wice_soisno(lb:nl_soil) , &! ice lens (kg/m2) + wliq_soisno(lb:nl_soil) ! liquid water (kg/m2) + + real(r8), intent(out) :: & + smp(1:nl_soil) , &! soil matrix potential [mm] + hk (1:nl_soil) ! hydraulic conductivity [mm h2o/s] + + real(r8), intent(inout) :: & + zwt , &! the depth from ground (soil) surface to water table [m] + wdsrf , &! depth of surface water [mm] + wa , &! water storage in aquifer [mm] + wetwat ! water storage in wetland [mm] + + real(r8), intent(out) :: & + frcsat , &! fraction of saturation area + rsur , &! surface runoff (mm h2o/s) + rsur_se , &! saturation excess surface runoff (mm h2o/s) + rsur_ie , &! infiltration excess surface runoff (mm h2o/s) + rsubst , &! subsurface runoff (mm h2o/s) + rnof , &! total runoff (mm h2o/s) + qinfl , &! infiltration rate (mm h2o/s) + qlayer(0:nl_soil) ! water flux between soil layer [mm h2o/s] + + + +! SNICAR model variables +! Aerosol Fluxes (Jan. 07, 2023) + real(r8), intent(in) :: forc_aer ( 14 ) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + + real(r8), intent(inout) :: & + mss_bcpho (lb:0), &! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lb:0), &! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lb:0), &! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lb:0), &! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lb:0), &! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lb:0), &! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lb:0), &! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lb:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) +! END SNICAR model variables + +! irrigation variable + real(r8), intent(in) :: & + qflx_irrig_drip , &! irrigation flux from drip irrigation [mm/s] + qflx_irrig_flood , &! irrigation flux from flood irrigation [mm/s] + qflx_irrig_paddy ! irrigation flux from paddy irrigation [mm/s] + +!-------------------------- Local Variables ---------------------------- + + integer j ! loop counter + + real(r8) :: & + eff_porosity(1:nl_soil), &! effective porosity = porosity - vol_ice + gwat , &! net water input from top (mm/s) + drainmax , &! drainage max (mm h2o/s) + vol_liq(1:nl_soil), &! partial volume of liquid water in layer + vol_ice(1:nl_soil), &! partial volume of ice lens in layer + icefrac(1:nl_soil) ! ice fraction (-) + + real(r8) :: eta + + real(r8) :: err_solver, w_sum, wresi(1:nl_soil) + real(r8) :: qgtop + + real(r8) :: zwtmm + real(r8) :: sp_zc(1:nl_soil), sp_zi(0:nl_soil), sp_dz(1:nl_soil) ! in mm + logical :: is_permeable(1:nl_soil) + real(r8) :: dzsum, dz + real(r8) :: icefracsum, fracice_rsub, imped + real(r8) :: wblc + +#ifdef Campbell_SOIL_MODEL + integer, parameter :: nprms = 1 +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + integer, parameter :: nprms = 5 +#endif + real(r8) :: prms(nprms, 1:nl_soil) + type(soil_con_struct ) :: soil_con + type(cell_data_struct) :: cell + real(r8) :: wliq_soisno_tmp(1:nl_soil) + + real(r8), parameter :: e_ice=6.0 !soil ice impedance factor + + integer :: ps, pe, m + + +#ifdef Campbell_SOIL_MODEL + prms(1,:) = bsw(1:nl_soil) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + prms(1,1:nl_soil) = alpha_vgm(1:nl_soil) + prms(2,1:nl_soil) = n_vgm (1:nl_soil) + prms(3,1:nl_soil) = L_vgm (1:nl_soil) + prms(4,1:nl_soil) = sc_vgm (1:nl_soil) + prms(5,1:nl_soil) = fc_vgm (1:nl_soil) +#endif + +!======================================================================= +! [1] update the liquid water within snow layer and the water onto soil +!======================================================================= + +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva + ELSE + + IF ((.not.DEF_USE_SNICAR) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain,qseva,qsdew,qsubl,qfros,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + ENDIF + +ELSE + + IF (lb>=1)THEN + gwat = pg_rain + sm - qseva_soil + ELSE + IF (.not. DEF_USE_SNICAR) THEN + CALL snowwater (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat) + ELSE + CALL snowwater_snicar (lb,deltim,ssi,wimp,& + pg_rain*fsno,qseva_snow,qsdew_snow,qsubl_snow,qfros_snow,& + dz_soisno(lb:0),wice_soisno(lb:0),wliq_soisno(lb:0),gwat,& + forc_aer,& + mss_bcpho(lb:0), mss_bcphi(lb:0), mss_ocpho(lb:0), mss_ocphi(lb:0),& + mss_dst1(lb:0), mss_dst2(lb:0), mss_dst3(lb:0), mss_dst4(lb:0) ) + ENDIF + gwat = gwat + pg_rain*(1-fsno) - qseva_soil + ENDIF +ENDIF + + +#ifdef CROP + IF(DEF_USE_IRRIGATION)THEN + gwat = gwat + qflx_irrig_drip + qflx_irrig_flood + qflx_irrig_paddy + ENDIF +#endif + +!======================================================================= +! [2] surface runoff and infiltration +!======================================================================= + +IF((patchtype<=1) .or. is_dry_lake & + .or. (DEF_USE_Dynamic_Wetland .and. (patchtype==2)))THEN ! soil ground only + + ! For water balance check, the sum of water in soil column before the calculation + w_sum = sum(wliq_soisno(1:nl_soil)) + sum(wice_soisno(1:nl_soil)) + wa + wdsrf + + ! Due to the increase in volume after freezing, the total volume of water and + ! ice may exceed the porosity of the soil. This excess water is temporarily + ! stored in "wresi". After calculating the movement of soil water, "wresi" + ! is added back to "wliq_soisno". + wresi(1:nl_soil) = 0. + ! porosity of soil, partial volume of ice and liquid + DO j = 1, nl_soil + vol_ice(j) = min(porsl(j), wice_soisno(j)/(dz_soisno(j)*denice)) + IF(porsl(j) < 1.e-6)THEN + icefrac(j) = 0. + ELSE + icefrac(j) = min(1.,vol_ice(j)/porsl(j)) + ENDIF + + eff_porosity(j) = max(wimp, porsl(j)-vol_ice(j)) + is_permeable(j) = eff_porosity(j) > max(wimp, theta_r(j)) + IF (is_permeable(j)) THEN + vol_liq(j) = wliq_soisno(j)/(dz_soisno(j)*denh2o) + vol_liq(j) = min(eff_porosity(j), max(0., vol_liq(j))) + wresi(j) = wliq_soisno(j) - dz_soisno(j) * denh2o * vol_liq(j) + ELSE + vol_liq(j) = 0. + ENDIF + ENDDO + + ! surface runoff including water table and surface saturated area + + rsur = 0. + rsubst = 0. + rsur_ie = 0. + rsur_se = 0. + +#ifndef CatchLateralFlow + IF (patchtype <= 1) THEN + + IF (DEF_Runoff_SCHEME == 0) THEN + + CALL SurfaceRunoff_TOPMOD (nl_soil,wimp,porsl,psi0,hksati,fsatmax,fsatdcf,& + z_soisno(1:),dz_soisno(1:),zi_soisno(0:),& + eff_porosity,icefrac,zwt,gwat,rsur,rsur_se,rsur_ie,topoweti,alp_twi,chi_twi,mu_twi,frcsat,eta) + + CALL SubsurfaceRunoff_TOPMOD (nl_soil, icefrac, dz_soisno(1:), zi_soisno(0:), & + zwt, rsubst, hksati, topoweti, eta) + + ELSEIF (DEF_Runoff_SCHEME == 1) THEN + ! 1: runoff scheme from VIC model + + CALL Runoff_VIC(deltim, porsl, theta_r, hksati, bsw, & + wice_soisno(1:nl_soil), wliq_soisno(1:nl_soil), fevpg(ipatch), rootflux, gwat, & + vic_b_infilt(ipatch), vic_Dsmax(ipatch), vic_Ds(ipatch), vic_Ws(ipatch), vic_c(ipatch),& + rsur, rsubst, wliq_soisno_tmp) + + rsur_se = rsur + rsur_ie = 0. + + ELSEIF (DEF_Runoff_SCHEME == 2) THEN + ! 2: runoff scheme from XinAnJiang model + + CALL Runoff_XinAnJiang (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + elvstd, gwat, deltim, rsur, rsubst, frcsat) + + rsur_se = rsur + rsur_ie = 0. + + ELSEIF (DEF_Runoff_SCHEME == 3) THEN + ! 3: runoff scheme from simplified VIC model + + CALL Runoff_SimpleVIC (& + nl_soil, dz_soisno(1:nl_soil), eff_porosity(1:nl_soil), vol_liq(1:nl_soil), & + BVIC, gwat, deltim, rsur, rsubst, frcsat) + + ! CALL SubsurfaceRunoff_SimpleVIC ( & + ! nl_soil, z_soisno(1:nl_soil), dz_soisno(1:nl_soil), wice_soisno(1:nl_soil), & + ! porsl(1:nl_soil), psi0(1:nl_soil), hksati(1:nl_soil), theta_r(1:nl_soil), & + ! nprms, prms(:,1:nl_soil), zwt, rsubst) + + rsur_se = rsur + rsur_ie = 0. + + ENDIF + + rsubst = rsubst * scale_baseflow(ipatch) + +#ifdef DataAssimilation + IF (DEF_DA_TWS_GRACE) THEN + rsur = max(min(rsur * fslp_k(ipatch), gwat), 0.) + rsubst = rsubst * fslp_k(ipatch) + ENDIF +#endif + +#ifdef CROP + IF(patchtype.eq.0 .AND. DEF_USE_IRRIGATION)THEN + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + DO m = ps, pe + IF(irrig_method_p(m).eq.irrig_method_paddy)THEN + rsur = 0 + ENDIF + ENDDO + ENDIF +#endif + ENDIF +#else + ! for catchment based lateral flow, + ! "rsur" is calculated in HYDRO/MOD_Catch_HillslopeFlow.F90 + ! "rsub" is calculated in HYDRO/MOD_Catch_SubsurfaceFlow.F90 +#endif + + ! infiltration into surface soil layer + qgtop = gwat - rsur + +!======================================================================= +! [3] determine the change of soil water +!======================================================================= + + ! convert length units from m to mm + zwtmm = zwt * 1000.0 + sp_zc(1:nl_soil) = z_soisno (1:nl_soil) * 1000.0 ! from meter to mm + sp_zi(0:nl_soil) = zi_soisno(0:nl_soil) * 1000.0 ! from meter to mm + + ! check consistency between water table location and liquid water content + IF (wa < 0.) THEN + IF (zwtmm <= sp_zi(nl_soil)) THEN + CALL get_zwt_from_wa ( & + porsl(nl_soil), theta_r(nl_soil), psi0(nl_soil), hksati(nl_soil), & + nprms, prms(:,nl_soil), 1.e-5, 1.e-8, wa, sp_zi(nl_soil), zwtmm) + ENDIF + ELSE + DO j = 1, nl_soil + IF ((vol_liq(j) < eff_porosity(j)-1.e-8) .and. (zwtmm <= sp_zi(j-1))) THEN + zwtmm = sp_zi(j) + ENDIF + ENDDO + ENDIF + + ! update "vol_liq" in the level containing water table + ! "vol_liq" in this level refers to volume content in unsaturated part + IF (zwtmm < sp_zi(nl_soil)) THEN + DO j = nl_soil, 1, -1 + IF ((zwtmm >= sp_zi(j-1)) .and. (zwtmm < sp_zi(j))) THEN + + IF ((zwtmm > sp_zi(j-1)) .and. (is_permeable(j))) THEN + vol_liq(j) = (wliq_soisno(j)*1000.0/denh2o - eff_porosity(j)*(sp_zi(j)-zwtmm)) & + / (zwtmm - sp_zi(j-1)) + IF (vol_liq(j) < 0.) THEN + zwtmm = sp_zi(j) + vol_liq(j) = wliq_soisno(j)*1000.0/denh2o / (sp_zi(j) - sp_zi(j-1)) + ENDIF + + vol_liq(j) = max(0., min(eff_porosity(j), vol_liq(j))) + wresi(j) = wliq_soisno(j)*1000.0/denh2o - eff_porosity(j)*(sp_zi(j)-zwtmm) & + - vol_liq(j) * (zwtmm - sp_zi(j-1)) + ENDIF + + EXIT + ENDIF + ENDDO + ENDIF + + wdsrf = max(0., wdsrf) + + IF ((.not. is_permeable(1)) .and. (qgtop < 0.)) THEN + IF (wdsrf > 0) THEN + wdsrf = wdsrf + qgtop * deltim + IF (wdsrf < 0) THEN + wliq_soisno(1) = max(0., wliq_soisno(1) + wdsrf) + wdsrf = 0 + ENDIF + ELSE + wliq_soisno(1) = max(0., wliq_soisno(1) + qgtop * deltim) + ENDIF + + qgtop = 0. + + ENDIF + + CALL soil_water_vertical_movement ( & + nl_soil, deltim, sp_zc(1:nl_soil), sp_zi(0:nl_soil), & + is_permeable(1:nl_soil), eff_porosity(1:nl_soil), theta_r(1:nl_soil), psi0(1:nl_soil), & + hksati(1:nl_soil), nprms, prms(:,1:nl_soil), porsl(nl_soil), qgtop, & + etr, rootr(1:nl_soil), rootflux(1:nl_soil), rsubst, & + qinfl, wdsrf, zwtmm, wa, & + vol_liq(1:nl_soil), smp(1:nl_soil), hk(1:nl_soil), qlayer(0:nl_soil),& + 1.e-3, wblc) + + ! update the mass of liquid water + DO j = nl_soil, 1, -1 + IF (is_permeable(j)) THEN + IF (zwtmm < sp_zi(j)) THEN + IF (zwtmm >= sp_zi(j-1)) THEN + wliq_soisno(j) = denh2o * ((eff_porosity(j)*(sp_zi(j)-zwtmm)) & + + vol_liq(j) * (zwtmm - sp_zi(j-1)))/1000.0 + ELSE + wliq_soisno(j) = denh2o * (eff_porosity(j)*(sp_zi(j)-sp_zi(j-1)))/1000.0 + ENDIF + ELSE + wliq_soisno(j) = denh2o * (vol_liq(j)*(sp_zi(j)-sp_zi(j-1)))/1000.0 + ENDIF + + wliq_soisno(j) = wliq_soisno(j) + wresi(j) + ENDIF + ENDDO + + zwt = zwtmm/1000.0 + + ! Renew the ice and liquid mass due to condensation +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + IF(lb >= 1)THEN + ! make consistent with how evap_grnd removed in infiltration + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros-qsubl) * deltim) + ENDIF +ELSE + wliq_soisno(1) = max(0., wliq_soisno(1) + qsdew_soil * deltim) + wice_soisno(1) = max(0., wice_soisno(1) + (qfros_soil-qsubl_soil) * deltim) +ENDIF + + ! water imbalance mainly due to insufficient liquid water for evapotranspiration + IF (wblc > 0.) THEN + DO j = 1, nl_soil + IF (wice_soisno(j) > wblc) THEN + wice_soisno(j) = wice_soisno(j) - wblc + wblc = 0. + EXIT + ELSE + wblc = wblc - wice_soisno(j) + wice_soisno(j) = 0. + ENDIF + ENDDO + ENDIF + +#ifndef CatchLateralFlow +#ifdef CROP + IF(patchtype.eq.0 .AND. DEF_USE_IRRIGATION)THEN + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + DO m = ps, pe + IF(irrig_method_p(m).eq.irrig_method_paddy .AND. wdsrf.gt.pondmxc)THEN + rsur = rsur + (wdsrf - pondmxc)/deltim + rsur_ie = rsur_ie + (wdsrf - pondmxc) / deltim + wdsrf = pondmxc + ELSEIF(irrig_method_p(m).ne.irrig_method_paddy .AND. wdsrf.gt.pondmx)THEN + rsur = rsur + (wdsrf - pondmx) / deltim + rsur_ie = rsur_ie + (wdsrf - pondmx) / deltim + wdsrf = pondmx + ENDIF + ENDDO + + IF (zwt <= 0.) THEN + rsur_ie = 0. + rsur_se = rsur + ENDIF + ! total runoff (mm/s) + rnof = rsubst + rsur + ELSE +#endif + IF (patchtype <= 1) THEN + IF (wdsrf > pondmx) THEN + rsur = rsur + (wdsrf - pondmx) / deltim + rsur_ie = rsur_ie + (wdsrf - pondmx) / deltim + wdsrf = pondmx + ENDIF + + IF (zwt <= 0.) THEN + rsur_ie = 0. + rsur_se = rsur + ENDIF + + ! total runoff (mm/s) + rnof = rsubst + rsur + ELSEIF (patchtype == 2) THEN ! for wetland + IF (wdsrf > wetwatmax) THEN + rsur_se = (wdsrf - wetwatmax) / deltim + wdsrf = wetwatmax + ENDIF + + rsur = rsur_se + ! total runoff (mm/s) + rnof = rsur + ELSE ! for dry lake + rnof = 0. + ENDIF +#ifdef CROP + ENDIF +#endif +#endif + + DO j = 1, nl_soil + IF(t_soisno(j) <= tfrz) THEN + ! consider impedance factor + vol_ice(j) = max(min(porsl(j), wice_soisno(j)/(dz_soisno(j)*denice)), 0.) + icefrac(j) = vol_ice(j)/porsl(j) + imped = 10.**(-e_ice*icefrac(j)) + hk(j) = imped * hk(j) + ENDIF + ENDDO + +#ifndef CatchLateralFlow + err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & + - (gwat-etr-rsur-rsubst)*deltim +#else + err_solver = (sum(wliq_soisno(1:))+sum(wice_soisno(1:))+wa+wdsrf) - w_sum & + - (gwat-etr)*deltim +#endif + +IF ((.not.DEF_SPLIT_SOILSNOW) .or. (patchtype==1 .and. DEF_URBAN_RUN)) THEN + IF(lb >= 1)THEN + err_solver = err_solver - (qsdew+qfros-qsubl)*deltim + ENDIF +ELSE + err_solver = err_solver-(qsdew_soil+qfros_soil-qsubl_soil)*deltim +ENDIF + +#if (defined CoLMDEBUG) + IF(abs(err_solver) > 1.e-3)THEN + write(6,'(A,E20.5,A,I0)') 'Warning (WATER_VSF): water balance violation', err_solver, & + ' in element ', landpatch%eindex(ipatch) + ENDIF + IF (any(wliq_soisno < -1.e-3)) THEN + write(6,'(A,10E20.5)') 'Warning (WATER_VSF): negative soil water', wliq_soisno(1:nl_soil) + ENDIF +#endif + +!======================================================================= +! [6] assumed hydrological scheme for the wetland +!======================================================================= + +ELSE + IF(patchtype==2)THEN ! WETLAND + qinfl = 0. + zwt = 0. + + + IF (.not.DEF_SPLIT_SOILSNOW) THEN + IF (lb >= 1) THEN + wetwat = wdsrf + wa + wetwat + (gwat - etr + qsdew + qfros - qsubl) * deltim + ELSE + wetwat = wdsrf + wa + wetwat + (gwat - etr) * deltim + ENDIF + ELSE + wetwat = wdsrf + wa + wetwat + (gwat - etr + qsdew_soil + qfros_soil - qsubl_soil) * deltim + ENDIF + + wresi(:) = 0. + DO j = 1, nl_soil + IF(t_soisno(j)>tfrz)THEN + wresi(j) = max(wliq_soisno(j) - porsl(j)*dz_soisno(j)*1000., 0.) + wliq_soisno(j) = wliq_soisno(j) - wresi(j) + ENDIF + ENDDO + + wetwat = wetwat + sum(wresi) + + IF (wetwat > wetwatmax) THEN + wdsrf = wetwat - wetwatmax + wetwat = wetwatmax + wa = 0. + ELSEIF (wetwat < 0) THEN + wa = wetwat + wdsrf = 0. + wetwat = 0. + ELSE + wdsrf = 0. + wa = 0. + ENDIF + + frcsat = 1. + +#ifndef CatchLateralFlow + IF (wdsrf > pondmx) THEN + rsur = (wdsrf - pondmx) / deltim + wdsrf = pondmx + ELSE + rsur = 0. + ENDIF + rnof = rsur + rsur_se = rsur + rsur_ie = 0. +#endif + ENDIF + +ENDIF + + END SUBROUTINE WATER_VSF + + + SUBROUTINE snowwater (lb,deltim,ssi,wimp, & + pg_rain,qseva,qsdew,qsubl,qfros, & + dz_soisno,wice_soisno,wliq_soisno,qout_snowb) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, /09/1999; /04/2014 +! +! Water flow within snow is computed by an explicit and non-physical based +! scheme, which permits a part of liquid water over the holding capacity (a +! tentative value is used, i.e., equal to 0.033*porosity) to percolate into the +! underlying layer, except the case of that the porosity of one of the two +! neighboring layers is less than 0.05, the zero flow is assumed. The water +! flow out of the bottom snow pack will participate as the input of the soil +! water and runoff. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o ! physical constant + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + lb ! lower bound of array + + real(r8), intent(in) :: & + deltim, &! seconds in a time step (s) + ssi, &! irreducible water saturation of snow + wimp, &! water impermeable if porosity less than wimp + dz_soisno(lb:0), &! layer thickness (m) + + pg_rain, &! rainfall after removal of interception (mm h2o/s) + qseva, &! ground surface evaporation rate (mm h2o/s) + qsdew, &! ground surface dew formation (mm h2o /s) [+] + qsubl, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros ! surface dew added to snow pack (mm h2o /s) [+] + + real(r8), intent(inout) :: & + wice_soisno(lb:0),&! ice lens (kg/m2) + wliq_soisno(lb:0) ! liquid water (kg/m2) + + real(r8), intent(out) :: & + qout_snowb ! rate of water out of snow bottom (mm/s) + +!-------------------------- Local Variables ---------------------------- + integer j ! k do loop/array indices + + real(r8) :: & + qin, &! water flow into the element (mm/s) + qout, &! water flow out of the element (mm/s) + zwice, &! the sum of ice mass of snow cover (kg/m2) + wgdif, &! ice mass after minus sublimation + vol_liq(lb:0), &! partial volume of liquid water in layer + vol_ice(lb:0), &! partial volume of ice lens in layer + eff_porosity(lb:0) ! effective porosity = porosity - vol_ice + +!======================================================================= +! renew the mass of ice lens (wice_soisno) and liquid (wliq_soisno) in the +! surface snow layer, resulted by sublimation (frost) / evaporation (condense) + + wgdif = wice_soisno(lb) + (qfros - qsubl)*deltim + wice_soisno(lb) = wgdif + IF(wgdif < 0.)THEN + wice_soisno(lb) = 0. + wliq_soisno(lb) = wliq_soisno(lb) + wgdif + ENDIF + + wliq_soisno(lb) = wliq_soisno(lb) + (pg_rain + qsdew - qseva)*deltim + IF (wliq_soisno(lb) < 0.) THEN + wice_soisno(lb) = wice_soisno(lb) + wliq_soisno(lb) + wice_soisno(lb) = max(wice_soisno(lb), 0.) + wliq_soisno(lb) = 0. + ENDIF + +! Porosity and partial volume + DO j = lb, 0 + vol_ice(j) = min(1., wice_soisno(j)/(dz_soisno(j)*denice)) + eff_porosity(j) = max(0.01, 1. - vol_ice(j)) + vol_liq(j) = min(eff_porosity(j), wliq_soisno(j)/(dz_soisno(j)*denh2o)) + ENDDO + +! Capillary force within snow could be two or more orders of magnitude less +! than those of gravity, this term may be ignored. Here we could keep the +! gravity term only. The general expression for water flow is "K * ss**3", +! however, no effective parameterization for "K". Thus, a very simple treatment +! (not physical based) is introduced: when the liquid water of layer exceeds +! the layer's holding capacity, the excess meltwater adds to the underlying +! neighbor layer. + + qin = 0. + DO j= lb, 0 + wliq_soisno(j) = wliq_soisno(j) + qin + + IF(j <= -1)THEN + ! no runoff over snow surface, just ponding on surface + IF(eff_porosity(j) mss_bcphi(j)) THEN + qout_bc_phi = mss_bcphi(j) + ENDIF + mss_bcphi(j) = mss_bcphi(j) - qout_bc_phi + qin_bc_phi = qout_bc_phi + + ! BCPHO: + ! 1. flux with meltwater: + qout_bc_pho = qout*scvng_fct_mlt_bcpho*(mss_bcpho(j)/mss_liqice(j)) + IF (qout_bc_pho > mss_bcpho(j)) THEN + qout_bc_pho = mss_bcpho(j) + ENDIF + mss_bcpho(j) = mss_bcpho(j) - qout_bc_pho + qin_bc_pho = qout_bc_pho + + ! OCPHI: + ! 1. flux with meltwater: + qout_oc_phi = qout*scvng_fct_mlt_ocphi*(mss_ocphi(j)/mss_liqice(j)) + IF (qout_oc_phi > mss_ocphi(j)) THEN + qout_oc_phi = mss_ocphi(j) + ENDIF + mss_ocphi(j) = mss_ocphi(j) - qout_oc_phi + qin_oc_phi = qout_oc_phi + + ! OCPHO: + ! 1. flux with meltwater: + qout_oc_pho = qout*scvng_fct_mlt_ocpho*(mss_ocpho(j)/mss_liqice(j)) + IF (qout_oc_pho > mss_ocpho(j)) THEN + qout_oc_pho = mss_ocpho(j) + ENDIF + mss_ocpho(j) = mss_ocpho(j) - qout_oc_pho + qin_oc_pho = qout_oc_pho + + ! DUST 1: + ! 1. flux with meltwater: + qout_dst1 = qout*scvng_fct_mlt_dst1*(mss_dst1(j)/mss_liqice(j)) + IF (qout_dst1 > mss_dst1(j)) THEN + qout_dst1 = mss_dst1(j) + ENDIF + mss_dst1(j) = mss_dst1(j) - qout_dst1 + qin_dst1 = qout_dst1 + + ! DUST 2: + ! 1. flux with meltwater: + qout_dst2 = qout*scvng_fct_mlt_dst2*(mss_dst2(j)/mss_liqice(j)) + IF (qout_dst2 > mss_dst2(j)) THEN + qout_dst2 = mss_dst2(j) + ENDIF + mss_dst2(j) = mss_dst2(j) - qout_dst2 + qin_dst2 = qout_dst2 + + ! DUST 3: + ! 1. flux with meltwater: + qout_dst3 = qout*scvng_fct_mlt_dst3*(mss_dst3(j)/mss_liqice(j)) + IF (qout_dst3 > mss_dst3(j)) THEN + qout_dst3 = mss_dst3(j) + ENDIF + mss_dst3(j) = mss_dst3(j) - qout_dst3 + qin_dst3 = qout_dst3 + + ! DUST 4: + ! 1. flux with meltwater: + qout_dst4 = qout*scvng_fct_mlt_dst4*(mss_dst4(j)/mss_liqice(j)) + IF (qout_dst4 > mss_dst4(j)) THEN + qout_dst4 = mss_dst4(j) + ENDIF + mss_dst4(j) = mss_dst4(j) - qout_dst4 + qin_dst4 = qout_dst4 +! Aerosol Fluxes (Jan. 07, 2023) + + ENDDO + + qout_snowb = qout/deltim + + +! Aerosol Fluxes (Jan. 07, 2023) +! Compute aerosol fluxes through snowpack and aerosol deposition fluxes into top layere +!----------------------------------------------------------------------- +! set aerosol deposition fluxes from forcing array +! The forcing array is either set from an external file +! or from fluxes received from the atmosphere model +#ifdef MODAL_AER + ! Mapping for modal aerosol scheme where within-hydrometeor and + ! interstitial aerosol fluxes are differentiated. Here, "phi" + ! flavors of BC and OC correspond to within-hydrometeor + ! (cloud-borne) aerosol, and "pho" flavors are interstitial + ! aerosol. "wet" and "dry" fluxes of BC and OC specified here are + ! purely diagnostic + ! + ! NOTE: right now the macro 'MODAL_AER' is not defined anywhere, i.e., + ! the below (modal aerosol scheme) is not available and can not be + ! active either. It depends on the specific input aerosol deposition + ! data which is suitable for modal scheme. [06/15/2023, Hua Yuan] + + flx_bc_dep_phi = forc_aer(3) + flx_bc_dep_pho = forc_aer(1) + forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(6) + flx_oc_dep_pho = forc_aer(4) + forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) +#else + ! Original mapping for bulk aerosol deposition. phi and pho BC/OC + ! species are distinguished in model, other fluxes (e.g., dry and + ! wet BC/OC) are purely diagnostic. + + flx_bc_dep_phi = forc_aer(1) + forc_aer(3) + flx_bc_dep_pho = forc_aer(2) + flx_bc_dep = forc_aer(1) + forc_aer(2) + forc_aer(3) + + flx_oc_dep_phi = forc_aer(4) + forc_aer(6) + flx_oc_dep_pho = forc_aer(5) + flx_oc_dep = forc_aer(4) + forc_aer(5) + forc_aer(6) + + flx_dst_dep_wet1 = forc_aer(7) + flx_dst_dep_dry1 = forc_aer(8) + flx_dst_dep_wet2 = forc_aer(9) + flx_dst_dep_dry2 = forc_aer(10) + flx_dst_dep_wet3 = forc_aer(11) + flx_dst_dep_dry3 = forc_aer(12) + flx_dst_dep_wet4 = forc_aer(13) + flx_dst_dep_dry4 = forc_aer(14) + flx_dst_dep = forc_aer(7) + forc_aer(8) + forc_aer(9) + & + forc_aer(10) + forc_aer(11) + forc_aer(12) + & + forc_aer(13) + forc_aer(14) +#endif + + ! aerosol deposition fluxes into top layer + ! This is done after the inter-layer fluxes so that some aerosol + ! is in the top layer after deposition, and is not immediately + ! washed out before radiative calculations are done + + mss_bcphi(lb) = mss_bcphi(lb) + (flx_bc_dep_phi*deltim) + mss_bcpho(lb) = mss_bcpho(lb) + (flx_bc_dep_pho*deltim) + mss_ocphi(lb) = mss_ocphi(lb) + (flx_oc_dep_phi*deltim) + mss_ocpho(lb) = mss_ocpho(lb) + (flx_oc_dep_pho*deltim) + + mss_dst1(lb) = mss_dst1(lb) + (flx_dst_dep_dry1 + flx_dst_dep_wet1)*deltim + mss_dst2(lb) = mss_dst2(lb) + (flx_dst_dep_dry2 + flx_dst_dep_wet2)*deltim + mss_dst3(lb) = mss_dst3(lb) + (flx_dst_dep_dry3 + flx_dst_dep_wet3)*deltim + mss_dst4(lb) = mss_dst4(lb) + (flx_dst_dep_dry4 + flx_dst_dep_wet4)*deltim + +#ifdef MODAL_AER + ! + ! Transfer BC and OC from the within-ice state to the external + ! state based on snow sublimation and re-freezing of liquid water. + ! Re-freezing effect is inactived by default because of + ! uncertainty in how this process operates. + + DO j= lb, 0 + IF (j >= lb) THEN + IF (j == lb) THEN + ! snow that has sublimated [kg/m2] (top layer only) + subsnow = max(0._r8, (qsubl*deltim)) + + ! fraction of layer mass that has sublimated: + IF ((wliq_soisno(j) + wice_soisno(j)) > 0._r8) THEN + frc_sub = subsnow / (wliq_soisno(j) + wice_soisno(j)) + ELSE + frc_sub = 0._r8 + ENDIF + ELSE + ! prohibit sublimation effect to operate on sub-surface layers: + frc_sub = 0._r8 + ENDIF + + ! fraction of layer mass transformed (sublimation only) + frc_transfer = frc_sub + + ! cap the fraction at 1 + IF (frc_transfer > 1._r8) THEN + frc_transfer = 1._r8 + ENDIF + + ! transfer proportionate mass of BC and OC: + dm_int = mss_bcphi(j)*frc_transfer + mss_bcphi(j) = mss_bcphi(j) - dm_int + mss_bcpho(j) = mss_bcpho(j) + dm_int + + dm_int = mss_ocphi(j)*frc_transfer + mss_ocphi(j) = mss_ocphi(j) - dm_int + mss_ocpho(j) = mss_ocpho(j) + dm_int + + ENDIF + ENDDO +#endif +! Aerosol Fluxes (Jan. 7, 2023) + + END SUBROUTINE SnowWater_snicar + + + SUBROUTINE soilwater(patchtype,nl_soil,deltim,wimp,smpmin,& + qinfl,etr,z_soisno,dz_soisno,zi_soisno,& + t_soisno,vol_liq,vol_ice,smp,hk,icefrac,eff_porosity,& + porsl,hksati,bsw,psi0,rootr,rootflux,& + zwt,dwat,qcharge) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, 09/1999, 04/2014, 07/2014 +! +! some new parameterization are added, which are based on CLM4.5 +! +! Soil moisture is predicted from a 10-layer model (as with soil +! temperature), in which the vertical soil moisture transport is governed +! by infiltration, runoff, gradient diffusion, gravity, and root +! extraction through canopy transpiration. The net water applied to the +! surface layer is the snowmelt plus precipitation plus the throughfall +! of canopy dew minus surface runoff and evaporation. +! +! The vertical water flow in an unsaturated porous media is described by +! Darcy's law, and the hydraulic conductivity and the soil negative +! potential vary with soil water content and soil texture based on the work +! of Clapp and Hornberger (1978) and Cosby et al. (1984). The equation is +! integrated over the layer thickness, in which the time rate of change in +! water mass must equal the net flow across the bounding interface, plus the +! rate of internal source or sink. The terms of water flow across the layer +! interfaces are linearly expanded by using first-order Taylor expansion. +! The equations result in a tridiagonal system equation. +! +! Note: length units here are all millimeter +! (in temperature SUBROUTINE uses same soil layer +! structure required but lengths are m) +! +! Richards equation: +! +! d wat d d psi +! ----- = -- [ k(----- - 1) ] + S +! dt dz dz +! +! where: wat = volume of water per volume of soil (mm**3/mm**3) +! psi = soil matrix potential (mm) +! dt = time step (s) +! z = depth (mm) (positive downward) +! dz = thickness (mm) +! qin = inflow at top (mm h2o /s) +! qout= outflow at bottom (mm h2o /s) +! s = source/sink flux (mm h2o /s) +! k = hydraulic conductivity (mm h2o /s) +! +! d qin d qin +! qin[n+1] = qin[n] + -------- d wat(j-1) + --------- d wat(j) +! d wat(j-1) d wat(j) +! ==================|================= +! < qin +! +! d wat(j)/dt * dz = qin[n+1] - qout[n+1] + S(j) +! +! > qout +! ==================|================= +! d qout d qout +! qout[n+1] = qout[n] + --------- d wat(j) + --------- d wat(j+1) +! d wat(j) d wat(j+1) +! +! +! Solution: linearize k and psi about d wat and use tridiagonal +! system of equations to solve for d wat, +! where for layer j +! +! +! r_j = a_j [d wat_j-1] + b_j [d wat_j] + c_j [d wat_j+1] +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical, only: grav,hfus,tfrz,denh2o,denice + USE MOD_Utils + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: patchtype ! land patch type + integer , intent(in) :: nl_soil ! number of soil layers + real(r8), intent(in) :: deltim ! land model time step (sec) + real(r8), intent(in) :: wimp ! water impermeable if porosity less than wimp + real(r8), intent(in) :: smpmin ! restriction for min of soil potential (mm) + + real(r8), intent(in) :: qinfl ! infiltration (mm H2O /s) + real(r8), intent(in) :: etr ! vegetation transpiration (mm H2O/s) (+ = to atm) + + real(r8), intent(in) :: z_soisno (1:nl_soil) ! layer depth (m) + real(r8), intent(in) :: dz_soisno(1:nl_soil) ! layer thickness (m) + real(r8), intent(in) :: zi_soisno(0:nl_soil) ! interface level below a "z" level (m) + + real(r8), intent(in) :: t_soisno (1:nl_soil) ! soil temperature (Kelvin) + real(r8), intent(in) :: vol_liq (1:nl_soil) ! liquid volumetric water content + real(r8), intent(in) :: vol_ice (1:nl_soil) ! ice volumetric water content + real(r8), intent(in) :: icefrac (1:nl_soil) + real(r8), intent(in) :: eff_porosity(1:nl_soil) ! effective porosity = porosity - vol_ice + + real(r8), intent(in) :: porsl (1:nl_soil) ! volumetric soil water at saturation (porosity) + real(r8), intent(in) :: hksati (1:nl_soil) ! hydraulic conductivity at saturation (mm H2O /s) + real(r8), intent(in) :: bsw (1:nl_soil) ! Clapp and Hornberger "b" + real(r8), intent(in) :: psi0 (1:nl_soil) ! minimum soil suction (mm) [-] + real(r8), intent(in) :: rootr (1:nl_soil) ! effective fraction of roots in each soil layer + real(r8), intent(in) :: rootflux(1:nl_soil)! root uptake from different layers, all layers add to transpiration + real(r8), intent(in) :: zwt ! the depth from ground (soil) surface to water table [m] + + real(r8), intent(out) :: dwat(1:nl_soil) ! change of soil water [m3/m3] + real(r8), intent(out) :: qcharge ! aquifer recharge rate (positive to aquifer) (mm/s) + real(r8), intent(out) :: smp(1:nl_soil) ! soil matrix potential [mm] + real(r8), intent(out) :: hk (1:nl_soil) ! hydraulic conductivity [mm h2o/s] + +!-------------------------- Local Variables ---------------------------- + + integer :: j ! do loop indices + real(r8) :: amx(1:nl_soil) ! "a" left off diagonal of tridiagonal matrix + real(r8) :: bmx(1:nl_soil) ! "b" diagonal column for tridiagonal matrix + real(r8) :: cmx(1:nl_soil) ! "c" right off diagonal tridiagonal matrix + real(r8) :: rmx(1:nl_soil) ! "r" forcing term of tridiagonal matrix + real(r8) :: zmm(1:nl_soil) ! layer depth [mm] + real(r8) :: dzmm(1:nl_soil) ! layer thickness [mm] + real(r8) :: zimm(0:nl_soil) ! layer interface depth [mm] + real(r8) :: den(1:nl_soil) ! used in calculating qin, qout + real(r8) :: alpha(1:nl_soil) ! used in calculating qin, qout + real(r8) :: qin(1:nl_soil) ! flux of water into soil layer [mm h2o/s] + real(r8) :: qout(1:nl_soil) ! flux of water out of soil layer [mm h2o/s] + real(r8) :: dqidw0(1:nl_soil) ! d(qin)/d(vol_liq(j-1)) + real(r8) :: dqidw1(1:nl_soil) ! d(qin)/d(vol_liq(j)) + real(r8) :: dqodw1(1:nl_soil) ! d(qout)/d(vol_liq(j)) + real(r8) :: dqodw2(1:nl_soil) ! d(qout)/d(vol_liq(j+1)) + real(r8) :: dsmpdw(1:nl_soil) ! d(smp)/d(vol_liq) + real(r8) :: s_node ! soil wetness + real(r8) :: s1 ! "s" at interface of layer + real(r8) :: s2 ! k*s**(2b+2) + real(r8) :: dhkdw1(1:nl_soil) ! d(hk)/d(vol_liq(j)) + real(r8) :: dhkdw2(1:nl_soil) ! d(hk)/d(vol_liq(j+1)) + real(r8) :: imped(1:nl_soil) ! + real(r8) :: errorw ! mass balance error for this time step + + integer :: jwt ! index of the soil layer right above the water table (-) + + real(r8), parameter :: e_ice=6.0 !soil ice impedance factor +!----------------------------------------------------------------------- + + !compute jwt index + ! The layer index of the first unsaturated layer, + ! i.e., the layer right above the water table + + jwt = nl_soil + ! allow jwt to equal zero when zwt is in top layer + DO j = 1, nl_soil + IF(zwt <= zi_soisno(j)) THEN + jwt = j-1 + EXIT + ENDIF + ENDDO + + ! Because the depths in this routine are in mm, use local + ! variable arrays instead of pointers + DO j = 1, nl_soil + zmm(j) = z_soisno(j)*1000. + dzmm(j) = dz_soisno(j)*1000. + zimm(j) = zi_soisno(j)*1000. + ENDDO + + zimm(0) = 0.0 + + ! Compute matric potential and derivative based on liquid water content only + DO j = 1, nl_soil + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + IF(t_soisno(j)>=tfrz) THEN + IF(porsl(j)<1.e-6)THEN ! bed rock + s_node = 0.001 + smp(j) = psi0(j) + dsmpdw(j) = 0. + ELSE + s_node = max(vol_liq(j)/porsl(j),0.01) + s_node = min(1.0,s_node) + smp(j) = psi0(j)*s_node**(-bsw(j)) + smp(j) = max(smpmin,smp(j)) + dsmpdw(j) = -bsw(j)*smp(j)/(s_node*porsl(j)) + ENDIF + ELSE + ! when ice is present, the matric potential is only related to temperature + ! by (Fuchs et al., 1978: Soil Sci. Soc. Amer. J. 42(3):379-385) + ! Unit 1 Joule = 1 (kg m2/s2), J/kg /(m/s2) ==> m ==> 1e3 mm + smp(j) = 1.e3 * 0.3336e6/9.80616*(t_soisno(j)-tfrz)/t_soisno(j) + smp(j) = max(smpmin, smp(j)) ! Limit soil suction + dsmpdw(j) = 0. + ENDIF + ELSE + IF(t_soisno(j)>=tfrz) THEN + IF(porsl(j)<1.e-6)THEN ! bed rock + s_node = 0.001 + smp(j) = psi0(j) + dsmpdw(j) = 0. + ELSE + s_node = max(vol_liq(j)/porsl(j),0.01) + s_node = min(1.0,s_node) + smp(j) = psi0(j)*s_node**(-bsw(j)) + smp(j) = max(smpmin,smp(j)) + dsmpdw(j) = -bsw(j)*smp(j)/(s_node*porsl(j)) + ENDIF + ELSE + ! when ice is present, the matric potential is only related to temperature + ! by (Fuchs et al., 1978: Soil Sci. Soc. Amer. J. 42(3):379-385) + ! Unit 1 Joule = 1 (kg m2/s2), J/kg /(m/s2) ==> m ==> 1e3 mm + smp(j) = 1.e3 * 0.3336e6/9.80616*(t_soisno(j)-tfrz)/t_soisno(j) + smp(j) = max(smpmin, smp(j)) ! Limit soil suction + dsmpdw(j) = 0. + ENDIF + ENDIF + ENDDO + + ! Hydraulic conductivity and soil matric potential and their derivatives + DO j = 1, nl_soil + + IF(j < nl_soil)THEN + den(j) = (zmm(j+1)-zmm(j)) + alpha(j) = (smp(j+1)-smp(j))/den(j) - 1. + ELSE + den(j) = 0. ! not used + alpha(j) = 0. ! not used + ENDIF + + IF((eff_porosity(j) < wimp) .or. (eff_porosity(min(nl_soil,j+1)) < wimp) & + .or. (vol_liq(j) <= 1.e-3))THEN + imped(j) = 0. + hk(j) = 0. + dhkdw1(j) = 0. + dhkdw2(j) = 0. + ELSE + ! The average conductivity between two heterogeneous medium layers (j and j + 1), + ! are computed using different methods + IF(j < nl_soil)THEN +! Method I: UPSTREAM MEAN + IF(alpha(j) <= 0.)THEN + hk(j) = hksati(j) * (vol_liq(j)/porsl(j))**(2.*bsw(j)+3.) + dhkdw1(j) = hksati(j) * (2.*bsw(j)+3.)*(vol_liq(j)/porsl(j))**(2.*bsw(j)+2.)/porsl(j) + dhkdw2(j) = 0. + ELSE + hk(j) = hksati(j+1) * (vol_liq(j+1)/porsl(j+1))**(2.*bsw(j+1)+3.) + dhkdw1(j) = 0. + dhkdw2(j) = hksati(j+1) * (2.*bsw(j+1)+3.)*(vol_liq(j+1)/porsl(j+1))**(2.*bsw(j+1)+2.)/porsl(j+1) + ENDIF +! Method II: + ! ! The harmonic averaging of the saturated conductivities + ! hksat_interface = (zmm(j+1)-zmm(j))/((zimm(j)-zmm(j))/hksati(j)+(zmm(j+1)-zimm(j))/hksati(j+1)) + ! s1 = (vol_liq(j)*(zimm(j)-zmm(j)) + vol_liq(j+1)*(zmm(j+1)-zimm(j))) & + ! / (porsl(j)*(zimm(j)-zmm(j)) + porsl(j+1)*(zmm(j+1)-zimm(j))) + ! s1 = min(1.,s1) + ! s2 = hksat_interface*s1**(2.*bsw(j)+2.) + ! hk(j) = s1*s2 + ! dhkdw1(j) = (2.*bsw(j)+3.)*s2*(zimm(j)-zmm(j))/(porsl(j)*(zimm(j)-zmm(j))+porsl(j+1)*(zmm(j+1)-zimm(j))) + ! dhkdw2(j) = (2.*bsw(j)+3.)*s2*(zmm(j+1)-zimm(j))/(porsl(j)*(zimm(j)-zmm(j))+porsl(j+1)*(zmm(j+1)-zimm(j))) + + ELSE + hk(j) = hksati(j) * (vol_liq(j)/porsl(j))**(2.*bsw(j)+3.) + dhkdw1(j) = hksati(j) * (2.*bsw(j)+3.)*(vol_liq(j)/porsl(j))**(2.*bsw(j)+2.)/porsl(j) + dhkdw2(j) = 0. + ENDIF + + ! replace fracice with impedance factor + imped(j)=10.**(-e_ice*(0.5*(icefrac(j)+icefrac(min(nl_soil,j+1))))) + hk(j) = imped(j) * hk(j) + dhkdw1(j) = imped(j) * dhkdw1(j) + dhkdw2(j) = imped(j) * dhkdw2(j) + ENDIF + ENDDO + + + ! Set up r, a, b, and c vectors for tridiagonal solution + + ! Node j=1 (top) + + j = 1 + qin(j) = qinfl + + qout(j) = -hk(j)*alpha(j) + dqodw1(j) = -(alpha(j)*dhkdw1(j) - hk(j)*dsmpdw(j)/den(j)) + dqodw2(j) = -(alpha(j)*dhkdw2(j) + hk(j)*dsmpdw(j+1)/den(j)) + + amx(j) = 0. + bmx(j) = dzmm(j)/deltim + dqodw1(j) + cmx(j) = dqodw2(j) + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + rmx(j) = qin(j) - qout(j) - rootflux(j) + ELSE + rmx(j) = qin(j) - qout(j) - etr*rootr(j) + ENDIF + + ! Nodes j=2 to j=nl_soil-1 + + DO j = 2, nl_soil - 1 + qin(j) = -hk(j-1)*alpha(j-1) + dqidw0(j) = -(alpha(j-1)*dhkdw1(j-1) - hk(j-1)*dsmpdw(j-1)/den(j-1)) + dqidw1(j) = -(alpha(j-1)*dhkdw2(j-1) + hk(j-1)*dsmpdw(j)/den(j-1)) + + qout(j) = -hk(j)*alpha(j) + dqodw1(j) = -(alpha(j)*dhkdw1(j) - hk(j)*dsmpdw(j)/den(j)) + dqodw2(j) = -(alpha(j)*dhkdw2(j) + hk(j)*dsmpdw(j+1)/den(j)) + + amx(j) = -dqidw0(j) + bmx(j) = dzmm(j)/deltim - dqidw1(j) + dqodw1(j) + cmx(j) = dqodw2(j) + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + rmx(j) = qin(j) - qout(j) - rootflux(j) + ELSE + rmx(j) = qin(j) - qout(j) - etr*rootr(j) + ENDIF + ENDDO + + ! Node j=nl_soil (bottom) + + j = nl_soil + qin(j) = -hk(j-1)*alpha(j-1) + dqidw0(j) = -(alpha(j-1)*dhkdw1(j-1) - hk(j-1)*dsmpdw(j-1)/den(j-1)) + dqidw1(j) = -(alpha(j-1)*dhkdw2(j-1) + hk(j-1)*dsmpdw(j)/den(j-1)) + + ! IF(j > jwt) THEN ! water table is in soil column + ! qout(j) = 0. + ! dqodw1(j) = 0. + ! dqodw2(j) = 0. + ! ELSE + qout(j) = hk(j) + dqodw1(j) = dhkdw1(j) + dqodw2(j) = 0. + ! ENDIF + + amx(j) = -dqidw0(j) + bmx(j) = dzmm(j)/deltim - dqidw1(j) + dqodw1(j) + cmx(j) = dqodw2(j) + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + rmx(j) = qin(j) - qout(j) - rootflux(j) + ELSE + rmx(j) = qin(j) - qout(j) - etr*rootr(j) + ENDIF + + ! Solve for dwat + + CALL tridia (nl_soil, amx, bmx, cmx, rmx, dwat ) + +#if (defined CoLMDEBUG) + ! The mass balance error (mm) for this time step is + errorw = -deltim*(qin(1)-qout(nl_soil)-dqodw1(nl_soil)*dwat(nl_soil)) + DO j = 1, nl_soil + IF(DEF_USE_PLANTHYDRAULICS .and. (patchtype/=1 .or. (.not.DEF_URBAN_RUN)))THEN + errorw = errorw+dwat(j)*dzmm(j)+rootflux(j)*deltim + ELSE + errorw = errorw+dwat(j)*dzmm(j)+etr*rootr(j)*deltim + ENDIF + ENDDO + + IF(abs(errorw) > 1.e-3)THEN + write(6,*) 'mass balance error in time step =',errorw + ENDIF +#endif + + ! Recharge rate qcharge to groundwater (positive to aquifer) + qcharge = qout(nl_soil) + dqodw1(nl_soil)*dwat(nl_soil) + + + END SUBROUTINE soilwater + + + SUBROUTINE groundwater (nl_soil,deltim,pondmx,& + eff_porosity,icefrac,& + dz_soisno,zi_soisno,wice_soisno,wliq_soisno,& + porsl,psi0,bsw,zwt,wa,& + qcharge,rsubst) + +! ------------------------------------------------------------------------- + + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: nl_soil ! + real(r8), intent(in) :: deltim ! land model time step (sec) + real(r8), intent(in) :: pondmx ! + + real(r8), intent(in) :: eff_porosity(1:nl_soil) ! effective porosity = porosity - vol_ice + real(r8), intent(in) :: icefrac(1:nl_soil) ! ice fraction (-) + + real(r8), intent(in) :: dz_soisno (1:nl_soil) ! layer depth (m) + real(r8), intent(in) :: zi_soisno (0:nl_soil) ! interface level below a "z" level (m) + real(r8), intent(inout) :: wice_soisno(1:nl_soil) ! ice lens (kg/m2) + real(r8), intent(inout) :: wliq_soisno(1:nl_soil) ! liquid water (kg/m2) + + real(r8), intent(in) :: porsl(1:nl_soil) ! volumetric soil water at saturation (porosity) + real(r8), intent(in) :: psi0(1:nl_soil) ! minimum soil suction (mm) [-] + real(r8), intent(in) :: bsw(1:nl_soil) ! Clapp and Hornberger "b" + + real(r8), intent(inout) :: zwt ! the depth from ground (soil) surface to water table [m] + real(r8), intent(inout) :: wa ! water in the unconfined aquifer (mm) + real(r8), intent(in) :: qcharge ! aquifer recharge rate (positive to aquifer) (mm/s) + real(r8), intent(inout) :: rsubst ! subsurface runoff (positive = out of soil column) (mm H2O /s) + +!-------------------------- Local Variables ---------------------------- + integer :: j ! indices + integer :: jwt ! index of the soil layer right above the water table (-) + real(r8) :: xs ! water needed to bring soil moisture to watmin (mm) + real(r8) :: dzmm(1:nl_soil) ! layer thickness (mm) + real(r8) :: xsi ! excess soil water above saturation at layer i (mm) + real(r8) :: xsia ! available pore space at layer i (mm) + real(r8) :: xs1 ! excess soil water above saturation at layer 1 (mm) + real(r8) :: ws ! summation of pore space of layers below water table (mm) + real(r8) :: s_node ! soil wetness (-) + real(r8) :: available_wliq_soisno ! available soil liquid water in a layer + real(r8) :: qcharge_tot ! + real(r8) :: qcharge_layer ! + real(r8) :: drainage ! + real(r8) :: drainage_tot ! + real(r8) :: drainage_layer ! + real(r8) :: s_y ! + real(r8) :: rous ! specific yield [-] + + real(r8) :: wt + real(r8) :: wtsub + real(r8) :: dzsum + real(r8) :: icefracsum + real(r8) :: fracice_rsub + real(r8) :: imped + + + real(r8), parameter :: watmin = 0.01 ! Limit irreducible wrapping liquid water + ! a tunable constant + real(r8), parameter :: rsbmx = 5.0 ! baseflow coefficient [mm/s] + real(r8), parameter :: timean = 10.5 ! global mean topographic index + +! ------------------------------------------------------------------------- + +! ! Convert layer thicknesses from m to mm + + DO j = 1,nl_soil + dzmm(j) = dz_soisno(j)*1000. + ENDDO + +! ! The layer index of the first unsaturated layer, +! ! i.e., the layer right above the water table + + jwt = nl_soil + ! allow jwt to equal zero when zwt is in top layer + DO j = 1, nl_soil + IF(zwt <= zi_soisno(j)) THEN + jwt = j-1 + EXIT + ENDIF + ENDDO + +!============================== QCHARGE ========================================= +! Water table changes due to qcharge +! use analytical expression for aquifer specific yield + rous = porsl(nl_soil)*(1.-(1.-1.e3*zwt/psi0(nl_soil))**(-1./bsw(nl_soil))) + rous = max(rous,0.02) + + wa = wa + qcharge*deltim +! +!--------------------------------------- + ! water table is below the soil column + IF(jwt == nl_soil) THEN + zwt = max(0.,zwt - (qcharge*deltim)/1000./rous) + ELSE + ! water table within soil layers 1-9 + ! try to raise water table to account for qcharge + + qcharge_tot = qcharge * deltim + + IF(qcharge_tot > 0.) THEN ! rising water table + DO j = jwt+1, 1,-1 + ! use analytical expression for specific yield + + s_y = porsl(j) * (1.-(1.-1.e3*zwt/psi0(j))**(-1./bsw(j))) + s_y=max(s_y,0.02) + + qcharge_layer = min(qcharge_tot,(s_y*(zwt-zi_soisno(j-1))*1.e3)) + qcharge_layer = max(qcharge_layer,0.) + + zwt = max(0.,zwt - qcharge_layer/s_y/1000.) + + qcharge_tot = qcharge_tot - qcharge_layer + IF (qcharge_tot <= 0.) EXIT + ENDDO + ELSE ! deepening water table (negative qcharge) + DO j = jwt+1, nl_soil + ! use analytical expression for specific yield + s_y = porsl(j) * (1.-(1.-1.e3*zwt/psi0(j))**(-1./bsw(j))) + s_y=max(s_y,0.02) + qcharge_layer = max(qcharge_tot,-(s_y*(zi_soisno(j) - zwt)*1.e3)) + qcharge_layer = min(qcharge_layer,0.) + qcharge_tot = qcharge_tot - qcharge_layer + + IF (qcharge_tot >= 0.) THEN + zwt = max(0.,zwt - qcharge_layer/s_y/1000.) + EXIT + ELSE + zwt = zi_soisno(j) + ENDIF + ENDDO + IF (qcharge_tot > 0.) zwt = max(0.,zwt - qcharge_tot/1000./rous) + ENDIF + ENDIF + +!-- Topographic runoff ---------------------------------------------------------- + IF (DEF_Runoff_SCHEME == 0) THEN + CALL SubsurfaceRunoff_TOPMOD (nl_soil, icefrac, dz_soisno, zi_soisno, zwt, rsubst) + ENDIF + + drainage = rsubst + + ! dzsum = 0. + ! icefracsum = 0. + ! DO j = max(jwt,1), nl_soil + ! dzsum = dzsum + dzmm(j) + ! icefracsum = icefracsum + icefrac(j) * dzmm(j) + ! ENDDO + ! ! add ice impedance factor to baseflow + ! fracice_rsub = max(0.,exp(-3.*(1.-(icefracsum/dzsum)))-exp(-3.))/(1.0-exp(-3.)) + ! imped = max(0.,1.-fracice_rsub) + ! drainage = imped * 5.5e-3 * exp(-2.5*zwt) ! drainage (positive = out of soil column) + +!-- Water table is below the soil column ---------------------------------------- + IF(jwt == nl_soil) THEN + wa = wa - drainage * deltim + zwt = max(0.,zwt + (drainage * deltim)/1000./rous) + wliq_soisno(nl_soil) = wliq_soisno(nl_soil) + max(0.,(wa-5000.)) + wa = min(wa, 5000.) + ELSE +!-- Water table within soil layers 1-9 ------------------------------------------ +!============================== RSUB_TOP ========================================= + !-- Now remove water via drainage + drainage_tot = - drainage * deltim + DO j = jwt+1, nl_soil + ! use analytical expression for specific yield + s_y = porsl(j) * ( 1. - (1.-1.e3*zwt/psi0(j))**(-1./bsw(j))) + s_y = max(s_y,0.02) + + drainage_layer = max(drainage_tot, -(s_y*(zi_soisno(j)-zwt)*1.e3)) + drainage_layer = min(drainage_layer,0.) + wliq_soisno(j) = wliq_soisno(j) + drainage_layer + + drainage_tot = drainage_tot - drainage_layer + + IF(drainage_tot >= 0.)THEN + zwt = max(0.,zwt - drainage_layer/s_y/1000.) + EXIT + ELSE + zwt = zi_soisno(j) + ENDIF + ENDDO + +!-- Remove residual drainage ------------------------------------------------ + zwt = max(0.,zwt - drainage_tot/1000./rous) + wa = wa + drainage_tot + +!-- Recompute jwt --------------------------------------------------------------- + ! allow jwt to equal zero when zwt is in top layer + jwt = nl_soil + DO j = 1, nl_soil + IF(zwt <= zi_soisno(j)) THEN + jwt = j-1 + EXIT + ENDIF + ENDDO + + ENDIF ! end of jwt IF construct + + zwt = max(0.0,zwt) + zwt = min(80.,zwt) + + rsubst = drainage + + + ! Correction [1] + ! NON-physically based correction on wliq_soisno + ! excessive water above saturation added to the above unsaturated layer like a bucket + ! IF column over saturated, excess water goes to runoff + + DO j = nl_soil,2,-1 + xsi = max(wliq_soisno(j)-eff_porosity(j)*dzmm(j),0.) + wliq_soisno(j) = min(eff_porosity(j)*dzmm(j), wliq_soisno(j)) + wliq_soisno(j-1) = wliq_soisno(j-1) + xsi + ENDDO + + ! 12/2022, note by yuan: a potential bug below which needs check, + ! if wice_soisno(1) > pondmx + porsl*dzmm, so xs1>0, in that case, + ! wliq_soisno(1) will be nagtive, and xs1 is positive. + xs1 = wliq_soisno(1) - (pondmx+porsl(1)*dzmm(1)-wice_soisno(1)) + IF(xs1 > 0.)THEN + wliq_soisno(1) = pondmx+porsl(1)*dzmm(1)-wice_soisno(1) + ELSE + xs1 = 0. + ENDIF + + rsubst = rsubst + xs1 / deltim + + + ! Correction [2] + ! NON-physically based correction on wliq_soisno + ! Limit wliq_soisno to be greater than or equal to watmin. + ! Get water needed to bring wliq_soisno equal watmin from lower layer. + ! If insufficient water in soil layers, get from aquifer water + + xs = 0. + DO j = 1, nl_soil + IF (wliq_soisno(j) < 0.) THEN + xs = xs + wliq_soisno(j) + wliq_soisno(j) = 0. + ENDIF + ENDDO + + ! Sub-surface runoff and drainage + rsubst = rsubst + xs/deltim + IF (rsubst < 0.) THEN + wa = wa + rsubst*deltim + rsubst = 0. + ENDIF + +! DO j = 1, nl_soil-1 +! IF (wice_soisno(j)*wice_soisno(j+1) < 1.e-6)THEN +! IF (wliq_soisno(j) < watmin) THEN +! xs = watmin - wliq_soisno(j) +! ! deepen water table IF water is passed from below zwt layer +! IF(j == jwt) THEN +! zwt = max(0.,zwt + xs/eff_porosity(j)/1000.) +! ENDIF +! ELSE +! xs = 0. +! ENDIF +! wliq_soisno(j ) = wliq_soisno(j ) + xs +! wliq_soisno(j+1) = wliq_soisno(j+1) - xs +! ENDIF +! ENDDO + +! ! Get water for bottom layer from layers above if possible +! IF(wliq_soisno(nl_soil) < watmin)THEN +! xs = watmin-wliq_soisno(nl_soil) +! DO j = nl_soil-1, 1, -1 +! available_wliq_soisno = max(wliq_soisno(j)-watmin-xs,0.) +! IF(available_wliq_soisno >= xs)THEN +! wliq_soisno(nl_soil) = wliq_soisno(nl_soil) + xs +! wliq_soisno(j ) = wliq_soisno(j ) - xs +! xs = 0. +! EXIT +! ELSE +! wliq_soisno(nl_soil) = wliq_soisno(nl_soil) + available_wliq_soisno +! wliq_soisno(j ) = wliq_soisno(j ) - available_wliq_soisno +! xs = xs - available_wliq_soisno +! ENDIF +! ENDDO +! ELSE +! xs = 0. +! ENDIF + +! ! Needed in case there is no water to be found +! wliq_soisno(nl_soil) = wliq_soisno(nl_soil) + xs + +! ! Sub-surface runoff and drainage +! rsubst = rsubst - xs/deltim + + END SUBROUTINE groundwater + + +END MODULE MOD_SoilSnowHydrology +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSurfaceResistance.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSurfaceResistance.F90 new file mode 100644 index 0000000000..2807042e88 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilSurfaceResistance.F90 @@ -0,0 +1,319 @@ +#include + +MODULE MOD_SoilSurfaceResistance +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate the soil surface resistance with multiple parameterization +! schemes +! +! Created by Zhuo Liu and Hua Yuan, 06/2023 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- +! !USE + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: SoilSurfaceResistance + + ! soil-gas diffusivity schemes: + ! 1: BBC (Buckingham-Burdine-Campbell Model), Moldrup et al., 1999. + ! 2: P_WLR (Penman Water Linear Reduction Model), Moldrup et al., 2000 + ! 3: MI_WLR (Millington Water Linear Reduction Model), Moldrup et al., 2000 + ! 4: MA_WLR (Marshal Water Linear Reduction Model), Moldrup et al., 2000 + ! 5: M_Q, Millington and Quirk, 1961 + ! 6: 3POE (Three-Porosity-Encased), Moldrup et al., 2005 +#ifdef Campbell_SOIL_MODEL + integer, parameter :: soil_gas_diffusivity_scheme = 1 +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + integer, parameter :: soil_gas_diffusivity_scheme = 6 +#endif + + +CONTAINS +!----------------------------------------------------------------------- + + SUBROUTINE SoilSurfaceResistance (nl_soil,forc_rhoair,hksati,porsl,psi0, & +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + dz_soisno,t_soisno,wliq_soisno,wice_soisno,fsno,qg,rss) + +!======================================================================= +! !DESCRIPTION: +! Main SUBROUTINE to CALL soil resistance model +! - Options for soil surface resistance schemes +! 1: SL14, Swenson and Lawrence (2014) +! 2: SZ09, Sakaguchi and Zeng (2009) +! 3: TR13, Tang and Riley (2013) +! 4: LP92, Lee and Pielke (1992) +! 5: S92, Sellers et al (1992) +! +! NOTE: Support for both Campbell and VG soil parameters. +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: denice, denh2o + USE MOD_Namelist, only: DEF_RSS_SCHEME + USE MOD_Hydro_SoilFunction + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + nl_soil ! upper bound of array + + real(r8), intent(in) :: & + forc_rhoair, &! density air [kg/m**3] + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + porsl (1:nl_soil), &! soil porosity [-] + psi0 (1:nl_soil), &! saturated soil suction [mm] (NEGATIVE) +#ifdef Campbell_SOIL_MODEL + bsw (1:nl_soil), &! clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r (1:nl_soil), &! residual moisture content [-] + ! a parameter corresponding approximately to the inverse of the air-entry value + alpha_vgm (1:nl_soil), & + n_vgm (1:nl_soil), &! pore-connectivity parameter [dimensionless] + L_vgm (1:nl_soil), &! a shape parameter [dimensionless] + ! saturation at the air entry value in the classical vanGenuchten model [-] + sc_vgm (1:nl_soil), & + ! a scaling factor by using air entry value in the Mualem model [-] + fc_vgm (1:nl_soil), & +#endif + dz_soisno (1:nl_soil), &! layer thickness [m] + t_soisno (1:nl_soil), &! soil/snow skin temperature [K] + wliq_soisno (1:nl_soil), &! liquid water [kg/m2] + wice_soisno (1:nl_soil), &! ice lens [kg/m2] + fsno, &! fractional snow cover [-] + qg ! ground specific humidity [kg/kg] + + real(r8), intent(out) :: & + rss ! soil surface resistance [s/m] + +!-------------------------- Local Variables ---------------------------- + + REAL(r8) :: & + wx, &! partial volume of ice and water of surface layer + vol_liq, &! water content by volume [m3/m3] + s_node, &! vol_liq/porosity + smp_node, &! matrix potential [m] + eff_porosity, &! effective porosity = porosity - vol_ice + aird, &! “air-dry” soil moisture value + d0, &! water vapor diffusivity in open air [m2/s] + eps, &! air filled pore space + dg, &! gaseous diffusivity [m2/s] + dsl, &! soil dry surface layer thickness [m] + dw, &! aqueous diffusivity [m2/s] + hk, &! hydraulic conductivity [m h2o/s] + m_vgm, &! pore-connectivity related parameter [dimensionless] + S, &! Van Genuchten relative saturation [-] + wfc, &! field capacity of the first layer soil + rg_1, &! inverse of vapor diffusion resistance [m/s] + rw_1, &! inverse of volatilization resistance [m/s] + rss_1, &! inverse of soil surface resistance [m/s] + tao, &! tortuosity of the vapor flow paths through the soil matrix + eps100, &! air-filled porosity at −1000 mm of water matric potential + fac, &! temporal variable for calculating wx/porsl + fac_fc, &! temporal variable for calculating wx/wfc + B ! bunsen solubility coefficient + +!----------------------------------------------------------------------- + + ! calculate the top soil volumetric water content (m3/m3), soil matrix potential + ! and soil hydraulic conductivity + vol_liq = max(wliq_soisno(1),1.0e-6_r8)/(denh2o*dz_soisno(1)) + s_node = min(1., vol_liq/porsl(1)) + + ! calculate effective soil porosity + eff_porosity = max(0.01_r8,porsl(1)-min(porsl(1), wice_soisno(1)/(dz_soisno(1)*denice))) + + +#ifdef Campbell_SOIL_MODEL + smp_node = (psi0(1)/1000.)*s_node**(-bsw(1)) + hk = (hksati(1)/1000.)*(vol_liq/porsl(1))**(2.*bsw(1)+3.) + + ! calculate air free pore space + aird = porsl(1)*(psi0(1)/-1.e7_r8)**(1./bsw(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + smp_node = soil_psi_from_vliq (s_node*(porsl(1)-theta_r(1)) + theta_r(1), & + porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) + hk = soil_hk_from_psi (smp_node, psi0(1), hksati(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) + + smp_node = smp_node/1000. + hk = hk/1000. + + ! calculate air free pore space + aird = soil_vliq_from_psi (-1.e7_r8, porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + + ! D0 : 2.12e-5 unit: m2 s-1 + ! ref1: CLM5 Documentation formula (5.81) + ! ref2: Sakaguchi and Zeng, 2009 + ! ref3: Tang and Riley, 2013. Figure 2, 3, 4, and 5. + d0 = 2.12e-5*(t_soisno(1)/273.15)**1.75 + eps = porsl(1) - aird + + + SELECTCASE (soil_gas_diffusivity_scheme) + + ! 1: BBC + CASE (1) +#ifdef Campbell_SOIL_MODEL + tao = eps*eps*(eps/porsl(1))**(3._r8/max(3._r8,bsw(1))) +#endif + + ! 2: P_WLR + CASE (2) + tao = 0.66*eps*(eps/porsl(1)) + + ! 3: MI_WLR + CASE (3) + tao = eps**(4._r8/3._r8)*(eps/porsl(1)) + + ! 4: MA_WLR + CASE (4) + tao = eps**(3./2.)*(eps/porsl(1)) + + ! 5: M_Q + CASE (5) + tao = eps**(4._r8/3._r8)*(eps/porsl(1))**(2.0_r8) + + ! 6: 3POE + CASE (6) +#ifdef Campbell_SOIL_MODEL + eps100 = porsl(1) - porsl(1)*(psi0(1)/-1000.)**(1./bsw(1)) +#endif + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + eps100 = porsl(1) - soil_vliq_from_psi (-1000., porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + tao = porsl(1)*porsl(1)*(eps/porsl(1))**(2.+log(eps100**0.25_r8)/log(eps100/porsl(1))) + + ENDSELECT + + + ! calculate gas and water diffusivity (dg and dw) + dg = d0*tao + + !NOTE: dw is only for TR13 scheme +#ifdef Campbell_SOIL_MODEL + ! TR13, Eq.(A5): + dw = -hk*bsw(1)*smp_node/vol_liq +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + ! TR13, Eqs. (A2), (A7), (A8) and (A10): + ! dw = -hk*(m-1)/(k*m*(theta_s-theta_r))*S**(-1/m)*(1-S**(1/m))**(-m) + ! where k=alpha_vgm, S=(1+(-k*smp_node)**(n))**(-m), m=m_vgm=1-1/n_vgm + m_vgm = 1. - 1./n_vgm(1) + S = (1. + (- alpha_vgm(1)*smp_node)**(n_vgm(1)))**(-m_vgm) + dw = -hk*(m_vgm-1.)/(alpha_vgm(1)*m_vgm*(porsl(1)-theta_r(1))) & + * S**(-1./m_vgm)*(1.-S**(1./m_vgm))**(-m_vgm) +#endif + + SELECTCASE (DEF_RSS_SCHEME) + +!----------------------------------------------------------------------- + ! calculate rss by SL14 + CASE (1) + dsl = dz_soisno(1)*max(1.e-6_r8,(0.8*eff_porosity - vol_liq)) & + /max(1.e-6_r8,(0.8*porsl(1)- aird)) + + dsl = max(dsl,0._r8) + dsl = min(dsl,0.2_r8) + + rss = dsl/dg + +!----------------------------------------------------------------------- + ! calculate rss by SZ09 + CASE (2) + dsl = dz_soisno(1)*(exp((1._r8 - vol_liq/porsl(1))**5) - 1._r8)/ (exp(1._r8) - 1._r8) + dsl = min(dsl,0.2_r8) + dsl = max(dsl,0._r8) + + rss = dsl/dg + +!----------------------------------------------------------------------- + ! calculate rss by TR13 + CASE (3) + ! TR13, Eq. (11) and Eq. (12): + B = denh2o/(qg*forc_rhoair) + ! TR13, Eq. (13): + rg_1 = 2.0_r8*dg*eps/dz_soisno(1) + rw_1 = 2.0_r8*dw*B*vol_liq/dz_soisno(1) + rss_1 = rg_1 + rw_1 + rss = 1.0/rss_1 + +!----------------------------------------------------------------------- + ! LP92 beta scheme + CASE (4) + wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) + fac = min(1._r8, wx/porsl(1)) + fac = max(fac , 0.001_r8) +#ifdef Campbell_SOIL_MODEL + wfc = porsl(1)*(0.1/(86400.*hksati(1)))**(1./(2.*bsw(1)+3.)) + !NOTE: CoLM wfc = (-339.9/soil_psi_s_l(ipatch))**(-1.0*soil_lambda_l(ipatch)) + ! * soil_theta_s_l(ipatch) + !wfc = porsl(1)*(-3399._r8/psi0(1))**(-1./bsw(1)) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + wfc = theta_r(1)+(porsl(1)-theta_r(1))*(1+(alpha_vgm(1)*339.9)**n_vgm(1))**(1.0/n_vgm(1)-1) +#endif + + ! Lee and Pielke 1992 beta + IF (wx < wfc ) THEN !when water content of ths top layer is less than that at F.C. + fac_fc = min(1._r8, wx/wfc) + fac_fc = max(fac_fc,0.001_r8) + rss = 0.25_r8*(1._r8 - cos(fac_fc*3.1415926))**2._r8 + ELSE !when water content of ths top layer is more than that at F.C. + rss = 1._r8 + ENDIF + +!----------------------------------------------------------------------- + ! Sellers, 1992 + CASE (5) + wx = (max(wliq_soisno(1),1.e-6)/denh2o+wice_soisno(1)/denice)/dz_soisno(1) + fac = min(1._r8, wx/porsl(1)) + fac = max(fac , 0.001_r8) + !rss = exp(8.206-4.255*fac) !original Sellers (1992) + rss = exp(8.206-6.0*fac) !adjusted Sellers (1992) to decrease rss + !for wet soil according to Noah-MP v5 + ENDSELECT + +!----------------------------------------------------------------------- + ! account for snow fractional cover for rss + IF (DEF_RSS_SCHEME .ne. 4) THEN + ! with 1/rss = fsno/rss_snow + (1-fsno)/rss_soil, + ! assuming rss_snow = 1, so rss is calibrated as: + IF (1.-fsno+fsno*rss > 0.) THEN + rss = rss / (1.-fsno+fsno*rss) + ELSE + rss = 0. + ENDIF + rss = min(1.e6_r8,rss) + ENDIF + + ! account for snow fractional cover for LP92 beta scheme + !NOTE: rss here is for soil beta value + IF (DEF_RSS_SCHEME .eq. 4) THEN + ! modify soil beta by snow cover, assuming soil beta for snow surface is 1. + rss = (1.-fsno)*rss + fsno + ENDIF + + END Subroutine SoilSurfaceResistance + +END MODULE MOD_SoilSurfaceResistance +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilThermalParameters.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilThermalParameters.F90 new file mode 100644 index 0000000000..980ae7db1e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_SoilThermalParameters.F90 @@ -0,0 +1,524 @@ +#include + +MODULE MOD_SoilThermalParameters + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: hCapacity + PUBLIC :: hConductivity + PUBLIC :: soil_hcap_cond + + +! PRIVATE MEMBER FUNCTIONS: + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE hCapacity (patchtype,lb,nl_soil,csol,porsl,wice_soisno,wliq_soisno,scv,dz_soisno,cv) + + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of heat capacities of snow / soil layers the volumetric +! heat capacity is calculated as a linear combination in terms of the +! volumetric fraction of the constituent phases. Only used in urban +! model. TODO: merge with SUBROUTINE soil_hcap_cond +! +! !REVISIONS: +! 07/19/2014, Yongjiu Dai: treat the wetland as soil column instead of +! water body. +! 08/16/2014, Nan Wei: recalculate the heat capacity of soil layers +! underneath the lake +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: cpice,cpliq + IMPLICIT NONE + + integer, intent(in) :: lb ! lower bound of array + integer, intent(in) :: nl_soil ! upper bound of array + integer, intent(in) :: patchtype ! land patch type (0=soil, 1=urban, 2=wetland, + real(r8), intent(in) :: csol(1:nl_soil) ! heat capacity of soil soilds [J/(m3 K)] + real(r8), intent(in) :: porsl(1:nl_soil) ! soil porosity + real(r8), intent(in) :: wice_soisno(lb:nl_soil) ! ice lens [kg/m2] + real(r8), intent(in) :: wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] + real(r8), intent(in) :: dz_soisno(lb:nl_soil) ! layer thickness [m] + real(r8), intent(in) :: scv ! snow water equivalent [mm] + real(r8), intent(out) :: cv(lb:nl_soil) ! heat capacity [J/(m2 K)] + +!----------------------------------------------------------------------- +! Soil heat capacity, which from de Vires (1963) + + IF(patchtype<=2 .or. patchtype==4)THEN ! soil ground and wetland and lake + cv(1:) = csol(1:)*(1.-porsl(1:))*dz_soisno(1:) & + + wice_soisno(1:)*cpice + wliq_soisno(1:)*cpliq + ELSE ! glacier/ice sheet + cv(1:) = wice_soisno(1:)*cpice + wliq_soisno(1:)*cpliq + ENDIF + IF(lb==1 .and. scv>0.) cv(1) = cv(1) + cpice*scv + +! Snow heat capacity + IF(lb<=0)THEN + cv(:0) = cpliq*wliq_soisno(:0) + cpice*wice_soisno(:0) + ENDIF + + END SUBROUTINE hCapacity + + + SUBROUTINE hConductivity (patchtype,lb,nl_soil,& + dkdry,dksatu,porsl,dz_soisno,z_soisno,zi_soisno,& + t_soisno,wice_soisno,wliq_soisno,tk,tktopsoil) + +!----------------------------------------------------------------------- +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of thermal conductivities of snow / soil layers The +! thermal conductivity of soil is computed from the algorithm of +! Johansen (as reported by Farouki 1981), and of snow is from the +! formulation used in SNTHERM (Jordan 1991). +! +! The thermal conductivities at the interfaces between two neighbor +! layers (j, j+1) are derived from an assumption that the flux across +! the interface is equal to that from the node j to the interface and +! the flux from the interface to the node j+1. +! +! Only used in urban model. TODO: merge with subroutine soil_hcap_cond +! +! !REVISIONS: +! 07/19/2014, Yongjiu Dai: treat the wetland as soil column instead of +! water body. +! 08/16/2014, Nan Wei: recalculate the heat conductivity of soil layers +! underneath the lake +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: denh2o,denice,tfrz,tkwat,tkice,tkair + IMPLICIT NONE + + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: nl_soil !upper bound of array + integer, intent(in) :: patchtype !land patch type (0=soil, 1=urban, 2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + real(r8), intent(in) :: dkdry(1:nl_soil) !thermal conductivity for dry soil [W/m-K] + real(r8), intent(in) :: dksatu(1:nl_soil) !Thermal conductivity of saturated soil [W/m-K] + real(r8), intent(in) :: porsl(1:nl_soil) !fractional volume between soil grains=1.-dmvol + real(r8), intent(in) :: dz_soisno(lb:nl_soil) !layer thickness [m] + real(r8), intent(in) :: z_soisno(lb:nl_soil) !node depth [m] + real(r8), intent(in) :: zi_soisno(lb-1:nl_soil) !interface depth [m] + real(r8), intent(in) :: t_soisno(lb:nl_soil) !Nodal temperature [K] + real(r8), intent(in) :: wice_soisno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(in) :: wliq_soisno(lb:nl_soil) !liquid water [kg/m2] + + real(r8), intent(out) :: tk(lb:nl_soil) !thermal conductivity [W/(m K)] + real(r8), optional, intent(out) :: tktopsoil + +! local + real(r8) rhosnow ! partial density of water (ice + liquid) + real(r8) dksat ! thermal conductivity for saturated soil (j/(k s m)) + real(r8) dke ! kersten number + real(r8) fl ! fraction of liquid or unfrozen water to total water + real(r8) satw ! relative total water content of soil. + real(r8) thk(lb:nl_soil) ! thermal conductivity of layer + real(r8) xicevol + + integer i + +!----------------------------------------------------------------------- +! Thermal conductivity of soil from Farouki (1981), + DO i = 1, nl_soil + + IF(patchtype<=2 .or. patchtype==4)THEN !soil ground, wetland and lake + thk(i) = dkdry(i) !rock or dry soil + + IF(porsl(i)>1.e-05 .and. (wice_soisno(i)+wliq_soisno(i)) > 0.0)THEN + satw = (wliq_soisno(i)/denh2o+wice_soisno(i)/denice)/(dz_soisno(i)*porsl(i)) + satw = min(1., satw) + IF(satw>.1e-6)THEN + IF (patchtype==4) satw = 1. + fl = wliq_soisno(i)/(wice_soisno(i)+wliq_soisno(i)) + IF(t_soisno(i) >= tfrz) THEN ! Unfrozen soil + dke = log10(satw) + 1.0 + dke = max(dke, 0.) + dksat = dksatu(i) + ELSE ! Frozen soil + dke = satw + dksat = dksatu(i)*(2.29/0.57)**((1.-fl)*porsl(i)) + ENDIF + thk(i) = dke*dksat + (1.-dke)*dkdry(i) + IF (patchtype==4) THEN + satw = (wliq_soisno(i)/denh2o+wice_soisno(i)/denice)/(dz_soisno(i)*porsl(i)) + IF(satw > 1.0)THEN + xicevol = (satw-1.0)*porsl(i) + thk(i) = (thk(i) + xicevol*tkice)/(1.0 + xicevol)/(1.0 + xicevol) + ENDIF + ENDIF + ENDIF + ENDIF + IF(present(tktopsoil))tktopsoil = thk(1) + ELSEIF (patchtype == 3)THEN ! glacier + thk(i) = tkwat + IF(t_soisno(i)=lb) THEN + tk(i) = thk(i) + ENDIF + ENDIF +! - END - + ENDDO + tk(nl_soil) = 0. + + END SUBROUTINE hConductivity + + SUBROUTINE soil_hcap_cond(vf_gravels_s,vf_om_s,vf_sand_s,vf_pores_s,& + wf_gravels_s,wf_sand_s,k_solids,& + csol,kdry,ksat_u,ksat_f,& + BA_alpha,BA_beta,& + temperature,vf_water,vf_ice,hcap,thk) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Calculate bulk soil heat capacity and soil thermal conductivity with +! 8 optional schemes The default soil thermal conductivity scheme is +! the fourth one (Balland V. and P. A. Arp, 2005) +! +! !REFERENCES: +! Dai et al.,2019: Evaluation of Soil Thermal Conductivity Schemes for +! Use in Land Surface Modeling J. of Advances in Modeling Earth +! Systems, DOI: 10.1029/2019MS001723 +! +! !Original author: Yongjiu Dai, 02/2018/ +! +! !REVISIONS: +! 06/2018, Nan Wei: add to CoLM/main +! 09/2022, Nan Wei: add soil thermal conductivity of Hailong He (Yan & +! He et al., 2019) +! ----------------------------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Const_Physical,only:tfrz + USE MOD_Namelist + + IMPLICIT NONE + real(r8), intent(in) :: vf_gravels_s ! volumetric fraction of gravels within soil solids + real(r8), intent(in) :: vf_om_s ! volumetric fraction of organic matter within soil solids + real(r8), intent(in) :: vf_sand_s ! volumetric fraction of sand within soil soilds + real(r8), intent(in) :: vf_pores_s ! volumetric pore space of the soil + + real(r8), intent(in) :: wf_gravels_s ! gravimetric fraction of gravels + real(r8), intent(in) :: wf_sand_s ! gravimetric fraction of sand within soil soilds + real(r8), intent(in) :: k_solids ! thermal conductivity of soil solids + + real(r8), intent(in) :: temperature ! + real(r8), intent(in) :: vf_water ! + real(r8), intent(in) :: vf_ice ! + + real(r8), intent(in) :: csol ! heat capacity of dry soil [J/(m3 K)] + real(r8), intent(in) :: kdry ! thermal conductivity for dry soil [W/m/K] + real(r8), intent(in) :: ksat_u ! thermal conductivity of unfrozen saturated soil [W/m/K] + real(r8), intent(in) :: ksat_f ! thermal conductivity of frozen saturated soil [W/m/K] + real(r8), intent(in) :: BA_alpha ! alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), intent(in) :: BA_beta ! beta in Balland and Arp(2005) thermal conductivity scheme + + real(r8), intent(out) :: hcap ! J/(m3 K) + real(r8), intent(out) :: thk ! W/(m K) + + real(r8) c_water, c_ice + real(r8) a, kappa, alpha, beta + real(r8) aa,aaa,nwm,nw_nwm,x,ga,gc + integer i + + real(r8) sr ! wetness or degree of saturation = (vf_water+vf_ice)/vf_pores_s + real(r8) ke ! Kersten number or normalized thermal conductivity + real(r8) k_air,k_water,k_ice + +! ========================================================================================= +! The heat capacity and thermal conductivity [J(m3 K)] +! ========================================================================================= +!* c_water = 4.18e6 ! J/(m3 K) +!* c_ice = 1.88e6 ! J/(m3 K) + c_water = 4.188e6 ! J/(m3 K) = 4188[J/(kg K)]*1000(kg/m3) + c_ice = 1.94153e6 ! J/(m3 K) = 2117.27[J/(kg K)]*917(kg/m3) + + hcap = csol + vf_water*c_water + vf_ice*c_ice + +! ----------------------------------------------------------------------------------------- +! Setting +! ----------------------------------------------------------------------------------------- + k_air = 0.024 ! (W/m/K) + k_water = 0.57 ! (W/m/K) + k_ice = 2.29 ! (W/m/K) + + a = vf_gravels_s + vf_sand_s + + sr = (vf_water+vf_ice)/vf_pores_s +! sr = max(1.0e-6, sr) + sr = min(1.0, sr) + + IF(sr >= 1.0e-10) THEN + select CASE (DEF_THERMAL_CONDUCTIVITY_SCHEME) + CASE (1) +! ----------------------------------------------------------------------------------------- +! [1] Oleson et al., 2013: Technical Description of version 4.5 of the Community Land Model +! (CLM). NCAR/TN-503+STR (Section 6.3: Soil and Snow Thermal Properties) +! ----------------------------------------------------------------------------------------- + IF(temperature > tfrz)THEN ! Unfrozen soil + ke = log10(sr) + 1.0 + ELSE ! Fozen or partially frozen soils + ke = sr + ENDIF + + CASE (2) +! ----------------------------------------------------------------------------------------- +! [2] Johansen O (1975): Thermal conductivity of soils. PhD Thesis. Trondheim, Norway: +! University of Trondheim. US army Crops of Engineerings, +! CRREL English Translation 637. +! ----------------------------------------------------------------------------------------- + IF(temperature > tfrz)THEN ! Unfrozen soils + IF(a > 0.4)THEN ! coarse-grained + ke = 0.7*log10(max(sr,0.05)) + 1.0 + ELSE ! Fine-grained + ke = log10(max(sr,0.1)) + 1.0 + ENDIF + ELSE ! Frozen or partially frozen soils + ke = sr + ENDIF + + CASE (3) +! ----------------------------------------------------------------------------------------- +! [3] Cote, J., and J.-M. Konrad (2005), A generalized thermal conductivity model for soils +! and construction materials. Canadian Geotechnical Journal, 42(2): 443-458. +! ----------------------------------------------------------------------------------------- + IF(temperature > tfrz)THEN ! Unfrozen soils +! kappa = Unfrozen +! /gravels and coarse sand /4.60/ +! /medium and fine sands /3.55/ +! /silty and clayey soils /1.90/ +! /organic fibrous soils (peat)/0.60/ + IF(a > 0.40)THEN + kappa = 4.60 + ELSEIF(a > 0.25)THEN + kappa = 3.55 + ELSEIF(a > 0.01)THEN + kappa = 1.90 + ELSE + kappa = 0.60 + ENDIF + + ELSE ! Frozen or partially frozen soils +! kappa = Frozen +! /gravels and coarse sand /1.70/ +! /medium and fine sands /0.95/ +! /silty and clayey soils /0.85/ +! /organic fibrous soils (peat)/0.25/ + IF(a > 0.40)THEN + kappa = 1.70 + ELSEIF(a > 0.25)THEN + kappa = 0.95 + ELSEIF(a > 0.01)THEN + kappa = 0.85 + ELSE + kappa = 0.25 + ENDIF + ENDIF + ke = kappa*sr/(1.0+(kappa-1.0)*sr) + + CASE (4) +! ----------------------------------------------------------------------------------------- +! [4] Balland V. and P. A. Arp, 2005: Modeling soil thermal conductivities over a wide +! range of conditions. J. Environ. Eng. Sci. 4: 549-558. +! be careful in specifying all k affecting fractions as VOLUME FRACTION, +! whether these fractions are part of the bulk volume, the pore space, or the solid space. +! ----------------------------------------------------------------------------------------- + IF(temperature > tfrz)THEN ! Unfrozen soil +! alpha = 0.24 ! adjustable parameter +! beta = 18.1 ! adjustable parameter + + ke = sr**(0.5*(1.0+vf_om_s-BA_alpha*vf_sand_s-vf_gravels_s)) & + * ((1.0/(1.0+exp(-BA_beta*sr)))**3-((1.0-sr)/2.0)**3)**(1.0-vf_om_s) + ELSE ! Frozen or partially frozen soils + ke = sr**(1.0+vf_om_s) + ENDIF + + CASE (5) +! ----------------------------------------------------------------------------------------- +! [5] Lu et al., 2007: An improved model for predicting soil thermal conductivity from +! water content at room temperature. Soil Sci. Soc. Am. J. 71:8-14 +! ----------------------------------------------------------------------------------------- + IF(a > 0.4)THEN ! Coarse-textured soils = soils with sand fractions >40 (%) + alpha = 0.728 + beta = 1.165 + ELSE ! Fine-textured soils = soils with sand fractions <40 (%) + alpha = 0.37 + beta = 1.29 + ENDIF + + IF(temperature > tfrz)THEN ! Unfrozen soils + ke = exp(alpha*(1.0-sr**(alpha-beta))) + ELSE ! Frozen or partially frozen soils + ke = sr + ENDIF + END select + ELSE + ke = 0.0 + ENDIF + + IF (DEF_THERMAL_CONDUCTIVITY_SCHEME >= 1 .and. DEF_THERMAL_CONDUCTIVITY_SCHEME <=5) THEN + ke = max(ke, 0.0) + ke = min(ke, 1.0) + IF(temperature > tfrz)THEN ! Unfrozen soil + thk = (ksat_u-kdry)*ke + kdry + ELSE ! Frozen or partially frozen soils + thk = (ksat_f-kdry)*ke + kdry + ENDIF + ENDIF + + IF(DEF_THERMAL_CONDUCTIVITY_SCHEME == 6) THEN +! ----------------------------------------------------------------------------------------- +! [6] Series-Parallel Models (Tarnawski and Leong, 2012) +! ----------------------------------------------------------------------------------------- + a = wf_gravels_s+wf_sand_s + +! a fitting parameter of the soil solid uniform passage + aa = 0.0237 - 0.0175*a**3 + +! a fitting parameter of a minuscule portion of soil water (nw) +! plus a minuscule portion of soil air (na) + nwm = 0.088 - 0.037*a**3 + +! the degree of saturation of the minuscle pore space + x = 0.6 - 0.3*a**3 + IF(sr < 1.0e-6)THEN + nw_nwm = 0.0 + ELSE + nw_nwm = exp(1.0-sr**(-x)) + ENDIF + + IF(temperature > tfrz)THEN ! Unfrozen soil + thk = k_solids*aa + (1.0-vf_pores_s-aa+nwm)**2 & + / ((1.0-vf_pores_s-aa)/k_solids+nwm/(k_water*nw_nwm+k_air*(1.0-nw_nwm))) & + + k_water*(vf_pores_s*sr-nwm*nw_nwm) & + + k_air*(vf_pores_s*(1.0-sr)-nwm*(1.0-nw_nwm)) + ELSE + thk = k_solids*aa + (1.0-vf_pores_s-aa+nwm)**2 & + / ((1.0-vf_pores_s-aa)/k_solids+nwm/(k_ice*nw_nwm+k_air*(1.0-nw_nwm))) & + + k_ice*(vf_pores_s*sr-nwm*nw_nwm) & + + k_air*(vf_pores_s*(1.0-sr)-nwm*(1.0-nw_nwm)) + ENDIF + ENDIF + + IF(DEF_THERMAL_CONDUCTIVITY_SCHEME == 7) THEN +! ----------------------------------------------------------------------------------------- +! [7] Thermal properties of soils, in Physics of Plant Environment, +! ed. by W.R. van Wijk (North-Holland, Amsterdam, 1963), pp. 210-235 +! ----------------------------------------------------------------------------------------- + IF(sr*vf_pores_s <= 0.09)THEN + ga = 0.013+0.944*sr*vf_pores_s + ELSE + ga = 0.333 - (1.-sr)*vf_pores_s/vf_pores_s*(0.333-0.035) + ENDIF + gc = 1.0-2.0*ga + + IF(temperature > tfrz)THEN ! Unfrozen soil + aa = (2.0/(1.0+(k_air/k_water-1.0)*ga) & ! the shape factor + + 1.0/(1.0+(k_air/k_water-1.0)*gc))/3.0 + aaa = (2.0/(1.0+(k_solids/k_water-1.0)*0.125) & ! the shape factor + + 1.0/(1.0+(k_solids/k_water-1.0)*(1.0-2.0*0.125)))/3.0 + + thk = (sr*vf_pores_s*k_water + (1.-sr)*vf_pores_s*aa*k_air + & + (1.-vf_pores_s)*aaa*k_solids) & + / (sr*vf_pores_s + (1.-sr)*vf_pores_s*aa + (1.-vf_pores_s)*aaa) + ELSE + aa = (2.0/(1.0+(k_air/k_ice-1.0)*ga) & ! the shape factor + + 1.0/(1.0+(k_air/k_ice-1.0)*gc))/3.0 + aaa = (2.0/(1.0+(k_solids/k_ice-1.0)*0.125) & ! the shape factor + + 1.0/(1.0+(k_solids/k_ice-1.0)*(1.0-2.0*0.125)))/3.0 + + thk = (sr*vf_pores_s*k_ice + (1.-sr)*vf_pores_s*aa*k_air + & + (1.-vf_pores_s)*aaa*k_solids) & + / (sr*vf_pores_s + (1.-sr)*vf_pores_s*aa + (1.-vf_pores_s)*aaa) + ENDIF + ENDIF + + IF(DEF_THERMAL_CONDUCTIVITY_SCHEME == 8) THEN +! ----------------------------------------------------------------------------------------- +! [8] Yan & He et al., 2019: A generalized model for estimating effective soil thermal conductivity +! based on the Kasubuchi algorithm, Geoderma, Vol 353, 227-242 +! ----------------------------------------------------------------------------------------- + beta = -0.303*ksat_u - 0.201*wf_sand_s + 1.532 + IF(vf_water > 0.01)THEN + ke = (1+(vf_pores_s/beta)**(-1.0*beta))/(1+(vf_water/beta)**(-1.0*beta)) + ELSE + ke = 0.0 + ENDIF + + ke = max(ke, 0.0) + ke = min(ke, 1.0) + + IF(temperature > tfrz)THEN ! Unfrozen soil + thk = (ksat_u-kdry)*ke + kdry + ELSE ! Frozen or partially frozen soils + thk = (ksat_f-kdry)*ke + kdry + ENDIF + ENDIF + + END SUBROUTINE soil_hcap_cond + +END MODULE MOD_SoilThermalParameters +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 new file mode 100644 index 0000000000..3c0e6246a0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Thermal.F90 @@ -0,0 +1,1392 @@ +#include + +MODULE MOD_Thermal + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: THERMAL + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE THERMAL (ipatch ,patchtype,is_dry_lake,lb ,deltim ,& + trsmx0 ,zlnd ,zsno ,csoilc ,& + dewmx ,capr ,cnfac ,vf_quartz ,& + vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& + wf_sand ,csol ,porsl ,psi0 ,& +#ifdef Campbell_SOIL_MODEL + bsw ,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r ,alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm , & +#endif + k_solids ,dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,lai ,laisun ,& + laisha ,sai ,htop ,hbot ,& + sqrtdi ,rootfr ,rstfacsun_out ,rstfacsha_out ,& + rss ,gssun_out ,gssha_out ,assimsun_out ,& + etrsun_out ,assimsha_out ,etrsha_out ,& +!photosynthesis and plant hydraulic variables + effcon ,vmax25 ,c3c4 ,hksati ,smp ,hk ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,& + psi50_sun ,psi50_sha ,psi50_xyl ,psi50_root ,& + ck ,vegwp ,gs0sun ,gs0sha ,& +!Ozone stress variables + o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha ,& + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& +!end ozone stress variables +!Ozone WUE stomata model parameter + lambda ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + slti ,hlti ,shti ,hhti ,& + trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,& + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_rhoair ,& + forc_psrf ,forc_pco2m ,forc_hpbl ,forc_po2m ,& + coszen ,parsun ,parsha ,sabvsun ,& + sabvsha ,sabg ,sabg_soil ,sabg_snow ,& + frl ,extkb ,extkd ,thermk ,& + fsno ,sigf ,dz_soisno ,z_soisno ,& + zi_soisno ,tleaf ,t_soisno ,wice_soisno ,& + wliq_soisno ,ldew ,ldew_rain ,ldew_snow ,& + fwet_snow ,scv ,snowdp ,imelt ,& + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + rootr ,rootflux ,qseva ,qsdew ,& + qsubl ,qfros ,qseva_soil ,qsdew_soil ,& + qsubl_soil ,qfros_soil ,qseva_snow ,qsdew_snow ,& + qsubl_snow ,qfros_snow ,sm ,tref ,& + qref ,trad ,rst ,assim ,& + respc ,errore ,emis ,z0m ,& + zol ,rib ,ustar ,qstar ,& + tstar ,fm ,fh ,fq ,& + pg_rain ,pg_snow ,t_precip ,qintr_rain ,& + qintr_snow ,snofrz ,sabg_snow_lyr ) + +!======================================================================= +! this is the main subroutine to execute the calculation +! of thermal processes and surface fluxes +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002 +! +! FLOW DIAGRAM FOR THERMAL.F90 +! +! THERMAL ===> qsadv +! GroundFluxes +! eroot |dewfraction +! LeafTemperature | |qsadv +! LeafTemperaturePC | ----------> |moninobukini +! |moninobuk +! |MOD_AssimStomataConductance +! +! GroundTemperature ----------> meltf +! +! +! !REVISIONS: +! 08/2019, Hua Yuan: added initial codes for PFT and Plant Community +! (PC) vegetation classification processes +! +! 01/2021, Nan Wei: added variables passing of plant hydraulics and +! precipitation sensible heat with canopy and ground for PFT +! and Plant Community (PC) +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_PFT + USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& + stefnc,denice,tfrz,vonkar,grav,cpliq,cpice + USE MOD_FrictionVelocity + USE MOD_Eroot + USE MOD_GroundFluxes + USE MOD_LeafTemperature + USE MOD_LeafTemperaturePC + USE MOD_GroundTemperature + USE MOD_Qsadv + USE MOD_SoilSurfaceResistance + USE MOD_Vars_TimeVariables, only: qsfc +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_LandPFT, only: patch_pft_s, patch_pft_e + USE MOD_Vars_TimeInvariants, only: patchclass + USE MOD_Vars_TimeVariables, only: & + lai_enftemp, lai_enfboreal, lai_dnfboreal, lai_ebftrop, lai_ebftemp, lai_dbftrop, lai_dbftemp, & + lai_dbfboreal, lai_ebstemp, lai_dbstemp, lai_dbsboreal, lai_c3arcgrass, lai_c3grass, lai_c4grass + USE MOD_Vars_PFTimeInvariants + USE MOD_Vars_PFTimeVariables + USE MOD_Vars_1DPFTFluxes +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq +#endif + USE MOD_MPAS_MPI + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_RSS_SCHEME, DEF_SPLIT_SOILSNOW, & + DEF_USE_LCT,DEF_USE_PFT,DEF_USE_PC,DEF_PC_CROP_SPLIT + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + integer, intent(in) :: & + ipatch, &! patch index + lb, &! lower bound of array + patchtype ! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=glacier/ice sheet, 4=land water bodies) + logical, intent(in) :: is_dry_lake + + real(r8), intent(inout) :: & + sai ! stem area index [-] + real(r8), intent(in) :: & + deltim, &! model time step [second] + trsmx0, &! max transpiration for moist soil+100% veg. [mm/s] + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + csoilc, &! drag coefficient for soil under canopy [-] + dewmx, &! maximum dew + capr, &! tuning factor to turn first layer T into surface T + cnfac, &! Crank Nicholson factor between 0 and 1 + + ! soil physical parameters + vf_quartz (1:nl_soil), &! volumetric fraction of quartz within mineral soil + vf_gravels(1:nl_soil), &! volumetric fraction of gravels + vf_om (1:nl_soil), &! volumetric fraction of organic matter + vf_sand (1:nl_soil), &! volumetric fraction of sand + wf_gravels(1:nl_soil), &! gravimetric fraction of gravels + wf_sand (1:nl_soil), &! gravimetric fraction of sand + csol (1:nl_soil), &! heat capacity of soil solids [J/(m3 K)] + porsl (1:nl_soil), &! soil porosity [-] + psi0 (1:nl_soil), &! soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + bsw(1:nl_soil), &! clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r (1:nl_soil), &! residual moisture content [-] + alpha_vgm (1:nl_soil), &! a parameter corresponding approximately to the inverse of the air-entry value + n_vgm (1:nl_soil), &! pore-connectivity parameter [dimensionless] + L_vgm (1:nl_soil), &! a shape parameter [dimensionless] + sc_vgm (1:nl_soil), &! saturation at the air entry value in the classical vanGenuchten model [-] + fc_vgm (1:nl_soil), &! a scaling factor by using air entry value in the Mualem model [-] +#endif + k_solids (1:nl_soil), &! thermal conductivity of minerals soil [W/m-K] + dkdry (1:nl_soil), &! thermal conductivity of dry soil [W/m-K] + dksatu (1:nl_soil), &! thermal conductivity of saturated unfrozen soil [W/m-K] + dksatf (1:nl_soil), &! thermal conductivity of saturated frozen soil [W/m-K] + hksati (1:nl_soil), &! hydraulic conductivity at saturation [mm h2o/s] + BA_alpha (1:nl_soil), &! alpha in Balland and Arp(2005) thermal conductivity scheme + BA_beta (1:nl_soil), &! beta in Balland and Arp(2005) thermal conductivity scheme + + ! vegetation parameters + lai, &! adjusted leaf area index for seasonal variation [-] + htop, &! canopy crown top height [m] + hbot, &! canopy crown bottom height [m] + sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] + rootfr(1:nl_soil), &! root fraction + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + kmax_sun, &! Plant Hydraulics Parameters + kmax_sha, &! Plant Hydraulics Parameters + kmax_xyl, &! Plant Hydraulics Parameters + kmax_root, &! Plant Hydraulics Parameters + psi50_sun, &! water potential at 50% loss of sunlit leaf tissue conductance (mmH2O) + psi50_sha, &! water potential at 50% loss of shaded leaf tissue conductance (mmH2O) + psi50_xyl, &! water potential at 50% loss of xylem tissue conductance (mmH2O) + psi50_root, &! water potential at 50% loss of root tissue conductance (mmH2O) + ck, &! shape-fitting parameter for vulnerability curve (-) + slti, &! slope of low temperature inhibition function [s3] + hlti, &! 1/2 point of low temperature inhibition function [s4] + shti, &! slope of high temperature inhibition function [s1] + hhti, &! 1/2 point of high temperature inhibition function [s2] + trda, &! temperature coefficient in gs-a model [s5] + trdm, &! temperature coefficient in gs-a model [s6] + trop, &! temperature coefficient in gs-a model + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + extkn, &! coefficient of leaf nitrogen allocation + + ! atmospherical variables and observational height + forc_hgt_u, &! observational height of wind [m] + forc_hgt_t, &! observational height of temperature [m] + forc_hgt_q, &! observational height of humidity [m] + forc_us, &! wind component in eastward direction [m/s] + forc_vs, &! wind component in northward direction [m/s] + forc_t, &! temperature at agcm reference height [kelvin] + forc_q, &! specific humidity at agcm reference height [kg/kg] + forc_rhoair, &! density air [kg/m3] + forc_psrf, &! atmosphere pressure at the surface [pa] + forc_pco2m, &! CO2 concentration in atmos. (pascals) + forc_po2m, &! O2 concentration in atmos. (pascals) + forc_hpbl, &! atmospheric boundary layer height [m] + pg_rain, &! rainfall onto ground including canopy runoff [kg/(m2 s)] + pg_snow, &! snowfall onto ground including canopy runoff [kg/(m2 s)] + t_precip, &! snowfall/rainfall temperature [kelvin] + qintr_rain, &! rainfall interception (mm h2o/s) + qintr_snow, &! snowfall interception (mm h2o/s) + + ! radiative fluxes + coszen, &! cosine of the solar zenith angle + parsun, &! photosynthetic active radiation by sunlit leaves (W m-2) + parsha, &! photosynthetic active radiation by shaded leaves (W m-2) + sabvsun, &! solar radiation absorbed by vegetation [W/m2] + sabvsha, &! solar radiation absorbed by vegetation [W/m2] + sabg, &! solar radiation absorbed by ground [W/m2] + sabg_soil, &! solar radiation absorbed by ground soil [W/m2] + sabg_snow, &! solar radiation absorbed by ground snow [W/m2] + frl, &! atmospheric infrared (longwave) radiation [W/m2] + extkb, &! (k, g(mu)/mu) direct solar extinction coefficient + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + thermk, &! canopy gap fraction for tir radiation + + ! state variable (1) + fsno, &! fraction of ground covered by snow + sigf, &! fraction of veg cover, excluding snow-covered veg [-] + dz_soisno(lb:nl_soil), &! layer thickness [m] + z_soisno (lb:nl_soil), &! node depth [m] + zi_soisno(lb-1:nl_soil) ! interface depth [m] + + integer , intent(in) :: & + c3c4 ! C3/C4 plant type + + real(r8), intent(in) :: & + sabg_snow_lyr(lb:1) ! snow layer absorption + + ! state variables (2) + real(r8), intent(inout) :: & + vegwp(1:nvegwcs), &! vegetation water potential + gs0sun, &! working copy of sunlit stomata conductance + gs0sha, &! working copy of shaded stomata conductance +!Ozone stress variables + lai_old , &! lai in last time step + o3uptakesun, &! Ozone does, sunlit leaf (mmol O3/m^2) + o3uptakesha, &! Ozone does, shaded leaf (mmol O3/m^2) + forc_ozone , &! Ozone +!end ozone stress variables + +!Ozone WUE stomata model parameter + lambda, &! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + + tleaf, &! shaded leaf temperature [K] + t_soisno(lb:nl_soil), &! soil temperature [K] + wice_soisno(lb:nl_soil), &! ice lens [kg/m2] + wliq_soisno(lb:nl_soil) ! liquid water [kg/m2] + + real(r8), intent(in) :: & + smp(1:nl_soil) , &! soil matrix potential [mm] + hk(1:nl_soil) ! hydraulic conductivity [mm h2o/s] + + real(r8), intent(inout) :: & + ldew, &! depth of water on foliage [kg/(m2 s)] + ldew_rain, &! depth of rain on foliage [kg/(m2 s)] + ldew_snow, &! depth of rain on foliage [kg/(m2 s)] + fwet_snow, &! vegetation canopy snow fractional cover [-] + scv, &! snow cover, water equivalent [mm, kg/m2] + snowdp ! snow depth [m] + + real(r8), intent(out) :: & + snofrz (lb:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + + integer, intent(out) :: & + imelt(lb:nl_soil) ! flag for melting or freezing [-] + + real(r8), intent(out) :: & + laisun, &! sunlit leaf area index + laisha, &! shaded leaf area index + gssun_out, &! sunlit stomata conductance + gssha_out, &! shaded stomata conductance + rstfacsun_out, &! factor of soil water stress on sunlit leaf + rstfacsha_out ! factor of soil water stress on shaded leaf + + real(r8), intent(out) :: & + assimsun_out , &! diagnostic sunlit leaf assim value for output + etrsun_out , &! diagnostic sunlit leaf etr value for output + assimsha_out , &! diagnostic shaded leaf assim for output + etrsha_out ! diagnostic shaded leaf etr for output + + ! Output fluxes + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsena, &! sensible heat from canopy height to atmosphere [W/m2] + fevpa, &! evapotranspiration from canopy height to atmosphere [mm/s] + lfevpa, &! latent heat flux from canopy height to atmosphere [W/m2] + fsenl, &! sensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + fseng, &! sensible heat flux from ground [W/m2] + fevpg, &! evaporation heat flux from ground [mm/s] + olrg, &! outgoing long-wave radiation from ground+canopy + fgrnd, &! ground heat flux [W/m2] + rootr(1:nl_soil), &! water uptake fraction from different layers, all layers add to 1.0 + rootflux(1:nl_soil), &! root uptake from different layer, all layers add to transpiration + + qseva, &! ground surface evaporation rate (mm h2o/s) + qsdew, &! ground surface dew formation (mm h2o /s) [+] + qsubl, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros, &! surface dew added to snow pack (mm h2o /s) [+] + qseva_soil, &! ground soil surface evaporation rate (mm h2o/s) + qsdew_soil, &! ground soil surface dew formation (mm h2o /s) [+] + qsubl_soil, &! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_soil, &! surface dew added to soil ice pack (mm h2o /s) [+] + qseva_snow, &! ground snow surface evaporation rate (mm h2o/s) + qsdew_snow, &! ground snow surface dew formation (mm h2o /s) [+] + qsubl_snow, &! sublimation rate from snow pack (mm h2o /s) [+] + qfros_snow, &! surface dew added to snow pack (mm h2o /s) [+] + + sm, &! rate of snowmelt [kg/(m2 s)] + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air specific humidity + trad, &! radiative temperature [K] + rss, &! bare soil resistance for evaporation [s/m] + rst, &! stomatal resistance (s m-1) + assim, &! assimilation + respc, &! respiration + + ! additional variables required by coupling with WRF or RSM model + emis, &! averaged bulk surface emissivity + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! u* in similarity theory [m/s] + qstar, &! q* in similarity theory [kg/kg] + tstar, &! t* in similarity theory [K] + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + +!Ozone stress variables + real(r8),intent(inout) :: & + o3coefv_sun,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefv_sha,&! Ozone stress factor for photosynthesis on sunlit leaf + o3coefg_sun,&! Ozone stress factor for stomata on shaded leaf + o3coefg_sha ! Ozone stress factor for stomata on shaded leaf +!end ozone stress variables + + +!-------------------------- Local Variables ---------------------------- + + integer i,j + + real(r8) :: & + fseng_soil, &! sensible heat flux from soil fraction + fseng_snow, &! sensible heat flux from snow fraction + fevpg_soil, &! latent heat flux from soil fraction + fevpg_snow, &! latent heat flux from snow fraction + + cgrnd, &! deriv. of soil energy flux wrt to soil temp [w/m2/k] + cgrndl, &! deriv, of soil sensible heat flux wrt soil temp [w/m2/k] + cgrnds, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + degdT, &! d(eg)/dT + dqgdT, &! d(qg)/dT + dlrad, &! downward longwave radiation blow the canopy [W/m2] + eg, &! water vapor pressure at temperature T [pa] + egsmax, &! max. evaporation which soil can provide at one time step + egidif, &! the excess of evaporation over "egsmax" + emg, &! ground emissivity (0.97 for snow, + ! glaciers and water surface; 0.96 for soil and wetland) + errore, &! energy balnce error [w/m2] + etrc, &! maximum possible transpiration rate [mm/s] + fac, &! soil wetness of surface layer + fact(lb:nl_soil), &! used in computing tridiagonal matrix + fsun, &! fraction of sunlit canopy + hr, &! relative humidity + htvp, &! latent heat of vapor of water (or sublimation) [j/kg] + olru, &! olrg excluding dwonwelling reflection [W/m2] + olrb, &! olrg assuming blackbody emission [W/m2] + psit, &! negative potential of soil + qg, &! ground specific humidity [kg/kg] +! 03/07/2020, yuan: + q_soil, &! ground soil specific humidity [kg/kg] + q_snow, &! ground snow specific humidity [kg/kg] + qsatg, &! saturated humidity [kg/kg] + qsatgdT, &! d(qsatg)/dT + qred, &! soil surface relative humidity + sabv, &! solar absorbed by canopy [W/m2] + thm, &! intermediate variable (forc_t+0.0098*forc_hgt_t) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + rstfac, &! factor of soil water stress + t_grnd, &! ground surface temperature [K] + t_grnd_bef, &! ground surface temperature [K] + t_soil, &! ground soil temperature + t_snow, &! ground snow temperature + t_soisno_bef(lb:nl_soil), &! soil/snow temperature before update + tinc, &! temperature difference of two time step + ur, &! wind speed at reference height [m/s] + ulrad, &! upward longwave radiation above the canopy [W/m2] + wice0(lb:nl_soil), &! ice mass from previous time-step + wliq0(lb:nl_soil), &! liquid mass from previous time-step + wx, &! patial volume of ice and water of surface layer + xmf, &! total latent heat of phase change of ground water [W/m2] + hprl, &! precipitation sensible heat from canopy [W/m2] + dheatl ! vegetation heat change [W/m2] + + real(r8) :: z0m_g,z0h_g,zol_g,obu_g,rib_g,ustar_g,qstar_g,tstar_g + real(r8) :: fm10m,fm_g,fh_g,fq_g,fh2m,fq2m,um,obu + + integer p, ps, pe, pn + + real(r8), allocatable :: rootr_p (:,:) + real(r8), allocatable :: rootflux_p (:,:) + real(r8), allocatable :: etrc_p (:) + real(r8), allocatable :: rstfac_p (:) + real(r8), allocatable :: rstfacsun_p (:) + real(r8), allocatable :: rstfacsha_p (:) + real(r8), allocatable :: gssun_p (:) + real(r8), allocatable :: gssha_p (:) + real(r8), allocatable :: fsun_p (:) + real(r8), allocatable :: sabv_p (:) + real(r8), allocatable :: fcover (:) + +! 03/06/2020, yuan: added + real(r8), allocatable :: fseng_soil_p (:) + real(r8), allocatable :: fseng_snow_p (:) + real(r8), allocatable :: fevpg_soil_p (:) + real(r8), allocatable :: fevpg_snow_p (:) + real(r8), allocatable :: cgrnd_p (:) + real(r8), allocatable :: cgrnds_p (:) + real(r8), allocatable :: cgrndl_p (:) + real(r8), allocatable :: dlrad_p (:) + real(r8), allocatable :: ulrad_p (:) + real(r8), allocatable :: zol_p (:) + real(r8), allocatable :: rib_p (:) + real(r8), allocatable :: ustar_p (:) + real(r8), allocatable :: qstar_p (:) + real(r8), allocatable :: tstar_p (:) + real(r8), allocatable :: fm_p (:) + real(r8), allocatable :: fh_p (:) + real(r8), allocatable :: fq_p (:) + real(r8), allocatable :: hprl_p (:) + real(r8), allocatable :: assimsun_p (:) + real(r8), allocatable :: etrsun_p (:) + real(r8), allocatable :: assimsha_p (:) + real(r8), allocatable :: etrsha_p (:) + real(r8), allocatable :: dheatl_p (:) + + +!======================================================================= +! [1] Initial set and propositional variables +!======================================================================= + + ! emissivity + emg = 0.96 + IF (scv>0. .or. patchtype==3) emg = 0.97 + + ! fluxes + taux = 0.; tauy = 0. + fsena = 0.; fevpa = 0. + lfevpa = 0.; fsenl = 0. + fevpl = 0.; etr = 0. + fseng = 0.; fevpg = 0. + + cgrnds = 0.; cgrndl = 0. + cgrnd = 0.; tref = 0. + qref = 0.; rst = 2.0e4 + assim = 0.; respc = 0. + hprl = 0.; dheatl = 0. + + emis = 0.; z0m = 0. + zol = 0.; rib = 0. + ustar = 0.; qstar = 0. + tstar = 0.; rootr = 0. + rootflux = 0. + + dlrad = frl + + t_soil = t_soisno(1) + t_snow = t_soisno(lb) + +IF (.not.DEF_SPLIT_SOILSNOW) THEN + t_grnd = t_soisno(lb) + ulrad = frl*(1.-emg) + emg*stefnc*t_grnd**4 +ELSE + t_grnd = fsno*t_snow + (1.-fsno)*t_soil + ulrad = frl*(1.-emg) & + + fsno*emg*stefnc*t_snow**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 +ENDIF + + ! temperature and water mass from previous time step + t_soisno_bef(lb:) = t_soisno(lb:) + t_grnd_bef = t_grnd + wice0(lb:) = wice_soisno(lb:) + wliq0(lb:) = wliq_soisno(lb:) + + ! latent heat, assumed that the sublimation occurred only as wliq_soisno=0 + htvp = hvap + IF (wliq_soisno(lb)<=0. .and. wice_soisno(lb)>0.) htvp = hsub + + ! potential temperature at the reference height + thm = forc_t + 0.0098*forc_hgt_t !intermediate variable equivalent to + !forc_t*(pgcm/forc_psrf)**(rgas/cpair) + th = forc_t*(100000./forc_psrf)**(rgas/cpair) !potential T + thv = th*(1.+0.61*forc_q) !virtual potential T + ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) !limit set to 0.1 + + +!======================================================================= +! [2] specific humidity and its derivative at ground surface +!======================================================================= + + qred = 1. + hr = 1. + + IF ((patchtype<=1) .or. is_dry_lake & + .or. (DEF_USE_Dynamic_Wetland .and. (patchtype==2))) THEN !soil ground + wx = (wliq_soisno(1)/denh2o + wice_soisno(1)/denice)/dz_soisno(1) + IF (porsl(1) < 1.e-6) THEN !bed rock + fac = 0.001 + ELSE + fac = min(1.,wx/porsl(1)) + fac = max( fac, 0.001 ) + ENDIF + +#ifdef Campbell_SOIL_MODEL + psit = psi0(1) * fac ** (- bsw(1) ) !psit = max(smpmin, psit) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + psit = soil_psi_from_vliq ( fac*(porsl(1)-theta_r(1)) + theta_r(1), & + porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + psit = max( -1.e8, psit ) + hr = exp(psit/roverg/t_grnd) + qred = (1.-fsno)*hr + fsno + ENDIF + +IF (.not. DEF_SPLIT_SOILSNOW) THEN + CALL qsadv(t_grnd,forc_psrf,eg,degdT,qsatg,qsatgdT) + + qg = qred*qsatg + dqgdT = qred*qsatgdT + + IF (qsatg > forc_q .and. forc_q > qred*qsatg) THEN + qg = forc_q; dqgdT = 0. + ENDIF + + q_soil = qg + q_snow = qg + +ELSE + CALL qsadv(t_soil,forc_psrf,eg,degdT,qsatg,qsatgdT) + + q_soil = hr*qsatg + dqgdT = (1.-fsno)*hr*qsatgdT + + IF(qsatg > forc_q .and. forc_q > hr*qsatg)THEN + q_soil = forc_q; dqgdT = 0. + ENDIF + + CALL qsadv(t_snow,forc_psrf,eg,degdT,qsatg,qsatgdT) + + q_snow = qsatg + dqgdT = dqgdT + fsno*qsatgdT + + ! weighted average qg + qg = (1.-fsno)*q_soil + fsno*q_snow + ENDIF + IF (allocated(qsfc)) qsfc(ipatch) = qg + + ! calculate soil surface resistance (rss) + ! ------------------------------------------------ + !NOTE: (1) DEF_RSS_SCHEME=0 means no rss considered + ! (2) Do NOT calculate rss for the first timestep + IF (DEF_RSS_SCHEME>0 .and. rss/=spval) THEN + + !NOTE: If the beta scheme is used, the rss is not soil resistance, + !but soil beta factor (soil wetness relative to field capacity [0-1]). + CALL SoilSurfaceResistance (nl_soil,forc_rhoair,hksati,porsl,psi0, & +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + dz_soisno,t_soisno,wliq_soisno,wice_soisno,fsno,qg,rss) + ELSE + IF (DEF_RSS_SCHEME == 4) THEN + rss = 1. !LP92 + ELSE + rss = 0. !the other RSS schemes + ENDIF + ENDIF + +!======================================================================= +! [3] Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +! TODO: modify code description +!======================================================================= + + ! Always CALL GroundFluxes for bare ground CASE + CALL GroundFluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,forc_hpbl, & + forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & + ur,thm,th,thv,t_grnd,qg,rss,dqgdT,htvp, & + fsno,cgrnd,cgrndl,cgrnds, & + t_soil,t_snow,q_soil,q_snow, & + !taux,tauy,fseng,fevpg,tref,qref, & + taux,tauy,fseng,fseng_soil,fseng_snow, & + fevpg,fevpg_soil,fevpg_snow,tref,qref, & + z0m_g,z0h_g,zol_g,rib_g,ustar_g,qstar_g,tstar_g,fm_g,fh_g,fq_g) + + obu_g = forc_hgt_u / zol_g + + +!======================================================================= +! [4] Canopy temperature, fluxes from the canopy +!======================================================================= + +IF ( patchtype==0.and.DEF_USE_LCT .or. patchtype>0 ) THEN + + sabv = sabvsun + sabvsha + + IF (lai+sai > 1e-6) THEN + + ! soil water stress factor on stomatal resistance + CALL eroot (nl_soil,trsmx0,porsl,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + psi0,rootfr,dz_soisno,t_soisno,wliq_soisno,rootr,etrc,rstfac) + + ! fraction of sunlit and shaded leaves of canopy + fsun = ( 1. - exp(-min(extkb*lai,40.))) / max( min(extkb*lai,40.), 1.e-6 ) + + IF (coszen<=0.0 .or. sabv<1.) fsun = 0.5 + + laisun = lai*fsun + laisha = lai*(1-fsun) + rstfacsun_out = rstfac + rstfacsha_out = rstfac + + CALL LeafTemperature(ipatch,1,deltim,csoilc ,dewmx ,htvp ,& + lai ,sai ,htop ,hbot ,sqrtdi ,& + effcon ,vmax25 ,c3c4 ,slti ,hlti ,shti ,& + hhti ,trda ,trdm ,trop ,g1 ,& + g0 ,gradm ,binter ,extkn ,extkb ,& + extkd ,forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,forc_q ,& + forc_psrf ,forc_rhoair ,parsun ,parsha ,sabv ,& + frl ,fsun ,thermk ,rstfacsun_out,rstfacsha_out,& + gssun_out ,gssha_out ,forc_po2m ,forc_pco2m ,z0h_g ,& + obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& + sigf ,etrc ,t_grnd ,qg ,rss ,& + t_soil ,t_snow ,q_soil ,q_snow ,dqgdT ,& + emg ,tleaf ,ldew ,ldew_rain ,ldew_snow ,& + fwet_snow ,taux ,tauy ,& + fseng ,fseng_soil ,fseng_snow ,& + fevpg ,fevpg_soil ,fevpg_snow ,& + cgrnd ,cgrndl ,cgrnds ,& + tref ,qref ,rst ,assim ,respc ,& + fsenl ,fevpl ,etr ,dlrad ,ulrad ,& + z0m ,zol ,rib ,ustar ,qstar ,& + tstar ,fm ,fh ,fq ,rootfr ,& + kmax_sun ,kmax_sha ,kmax_xyl ,kmax_root ,psi50_sun ,& + psi50_sha ,psi50_xyl ,psi50_root ,ck ,vegwp ,& + gs0sun ,gs0sha ,& + assimsun_out,etrsun_out ,assimsha_out ,etrsha_out ,& +!Ozone stress variables + o3coefv_sun ,o3coefv_sha ,o3coefg_sun ,o3coefg_sha ,& + lai_old ,o3uptakesun ,o3uptakesha ,forc_ozone ,& +!end ozone stress variables +!Ozone WUE stomata model parameter + lambda ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + forc_hpbl ,& + qintr_rain ,qintr_snow ,t_precip ,hprl ,dheatl ,& + smp ,hk(1:) ,hksati(1:) ,rootflux(1:) ) + ELSE + tleaf = forc_t + laisun = 0. + laisha = 0. + ldew_rain = 0. + ldew_snow = 0. + fwet_snow = 0. + ldew = 0. + rstfacsun_out = 0. + rstfacsha_out = 0. + assimsun_out = 0. + assimsha_out = 0. + etrsun_out = 0. + etrsha_out = 0. + gssun_out = 0. + gssha_out = 0. + IF (DEF_USE_PLANTHYDRAULICS) THEN + vegwp = -2.5e4 + ENDIF + ENDIF + +ENDIF + + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +IF (patchtype == 0) THEN + + ps = patch_pft_s(ipatch) + pe = patch_pft_e(ipatch) + + allocate ( rootr_p (nl_soil, ps:pe) ) + allocate ( rootflux_p(nl_soil,ps:pe)) + allocate ( etrc_p (ps:pe) ) + allocate ( rstfac_p (ps:pe) ) + allocate ( rstfacsun_p (ps:pe) ) + allocate ( rstfacsha_p (ps:pe) ) + allocate ( gssun_p (ps:pe) ) + allocate ( gssha_p (ps:pe) ) + allocate ( fsun_p (ps:pe) ) + allocate ( sabv_p (ps:pe) ) + allocate ( fcover (ps:pe) ) + + allocate ( fseng_soil_p (ps:pe) ) + allocate ( fseng_snow_p (ps:pe) ) + allocate ( fevpg_soil_p (ps:pe) ) + allocate ( fevpg_snow_p (ps:pe) ) + allocate ( cgrnd_p (ps:pe) ) + allocate ( cgrnds_p (ps:pe) ) + allocate ( cgrndl_p (ps:pe) ) + allocate ( dlrad_p (ps:pe) ) + allocate ( ulrad_p (ps:pe) ) + allocate ( zol_p (ps:pe) ) + allocate ( rib_p (ps:pe) ) + allocate ( ustar_p (ps:pe) ) + allocate ( qstar_p (ps:pe) ) + allocate ( tstar_p (ps:pe) ) + allocate ( fm_p (ps:pe) ) + allocate ( fh_p (ps:pe) ) + allocate ( fq_p (ps:pe) ) + + allocate ( hprl_p (ps:pe) ) + allocate ( assimsun_p (ps:pe) ) + allocate ( etrsun_p (ps:pe) ) + allocate ( assimsha_p (ps:pe) ) + allocate ( etrsha_p (ps:pe) ) + allocate ( dheatl_p (ps:pe) ) + + sabv_p(ps:pe) = sabvsun_p(ps:pe) + sabvsha_p(ps:pe) + sabv = sabvsun + sabvsha + + DO i = ps, pe + p = pftclass(i) + + IF (lai_p(i)+sai_p(i) > 1e-6) THEN + + CALL eroot (nl_soil,trsmx0,porsl,& +#ifdef Campbell_SOIL_MODEL + bsw, & +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + psi0,rootfr_p(:,p),& + dz_soisno,t_soisno,wliq_soisno,rootr_p(:,i),etrc_p(i),rstfac_p(i)) + + ! fraction of sunlit and shaded leaves of canopy + fsun_p(i) = ( 1. - exp(-min(extkb_p(i)*lai_p(i),40.))) & + / max( min(extkb_p(i)*lai_p(i),40.), 1.e-6 ) + + IF (coszen<=0.0 .or. sabv_p(i)<1.) fsun_p(i) = 0.5 + + laisun_p(i) = lai_p(i)*fsun_p(i) + laisha_p(i) = lai_p(i)*(1-fsun_p(i)) + rstfacsun_p(i) = rstfac_p(i) + rstfacsha_p(i) = rstfac_p(i) + ELSE + laisun_p(i) = 0. + laisha_p(i) = 0. + ldew_rain_p(i) = 0. + ldew_snow_p(i) = 0. + fwet_snow_p(i) = 0. + ldew_p(i) = 0. + rootr_p(:,i) = 0. + rootflux_p(:,i)= 0. + rstfacsun_p(i) = 0. + rstfacsha_p(i) = 0. + dheatl_p(i) = 0. + ENDIF + ENDDO + + IF (.not. DEF_USE_LAIFEEDBACK)THEN + lai_enftemp (ipatch) = 0._r8 + lai_enfboreal (ipatch) = 0._r8 + lai_dnfboreal (ipatch) = 0._r8 + lai_ebftrop (ipatch) = 0._r8 + lai_ebftemp (ipatch) = 0._r8 + lai_dbftrop (ipatch) = 0._r8 + lai_dbftemp (ipatch) = 0._r8 + lai_dbfboreal (ipatch) = 0._r8 + lai_ebstemp (ipatch) = 0._r8 + lai_dbstemp (ipatch) = 0._r8 + lai_dbsboreal (ipatch) = 0._r8 + lai_c3arcgrass (ipatch) = 0._r8 + lai_c3grass (ipatch) = 0._r8 + lai_c4grass (ipatch) = 0._r8 + DO i = ps, pe + p = pftclass(i) + IF(p .eq. 1)THEN + lai_enftemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 2)THEN + lai_enfboreal (ipatch) = lai_p(i) + ELSE IF(p .eq. 3)THEN + lai_dnfboreal (ipatch) = lai_p(i) + ELSE IF(p .eq. 4)THEN + lai_ebftrop (ipatch) = lai_p(i) + ELSE IF(p .eq. 5)THEN + lai_ebftemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 6)THEN + lai_dbftrop (ipatch) = lai_p(i) + ELSE IF(p .eq. 7)THEN + lai_dbftemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 8)THEN + lai_dbfboreal (ipatch) = lai_p(i) + ELSE IF(p .eq. 9)THEN + lai_ebstemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 10)THEN + lai_dbstemp (ipatch) = lai_p(i) + ELSE IF(p .eq. 11)THEN + lai_dbsboreal (ipatch) = lai_p(i) + ELSE IF(p .eq. 12)THEN + lai_c3arcgrass(ipatch) = lai_p(i) + ELSE IF(p .eq. 13)THEN + lai_c3grass (ipatch) = lai_p(i) + ELSE IF(p .eq. 14)THEN + lai_c4grass (ipatch) = lai_p(i) + ENDIF + ENDDO + ENDIF + + DO i = ps, pe + p = pftclass(i) + + ! Dealing with PFTs for PC: + ! If defined DEF_PC_CROP_SPLIT, for crop PFTs, use 1D twostream model; + ! Otherwise, skip to run PC 3D model. + IF ( DEF_USE_PC .and. (.not.DEF_PC_CROP_SPLIT .or. p.lt.15) ) THEN + CYCLE + ENDIF + + IF (lai_p(i)+sai_p(i) > 1e-6) THEN + + CALL LeafTemperature(ipatch,p,deltim ,csoilc ,dewmx ,htvp ,& + lai_p(i) ,sai_p(i) ,htop_p(i) ,hbot_p(i) ,sqrtdi_p(p) ,& + effcon_p(p) ,vmax25_p(p) ,c3c4_p(p) ,slti_p(p) ,hlti_p(p) ,shti_p(p) ,& + hhti_p(p) ,trda_p(p) ,trdm_p(p) ,trop_p(p) ,g1_p(p) ,& + g0_p(p) ,gradm_p(p) ,binter_p(p) ,extkn_p(p) ,extkb_p(i) ,& + extkd_p(i) ,forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,forc_q ,& + forc_psrf ,forc_rhoair ,parsun_p(i) ,parsha_p(i) ,sabv_p(i) ,& + frl ,fsun_p(i) ,thermk_p(i) ,rstfacsun_p(i) ,rstfacsha_p(i) ,& + gssun_p(i) ,gssha_p(i) ,forc_po2m ,forc_pco2m ,z0h_g ,& + obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& + sigf_p(i) ,etrc_p(i) ,t_grnd ,qg ,rss ,& + t_soil ,t_snow ,q_soil ,q_snow ,dqgdT ,& + emg ,tleaf_p(i) ,ldew_p(i) ,ldew_rain_p(i) ,ldew_snow_p(i) ,& + fwet_snow_p(i) ,taux_p(i) ,tauy_p(i) ,& + fseng_p(i) ,fseng_soil_p(i) ,fseng_snow_p(i) ,& + fevpg_p(i) ,fevpg_soil_p(i) ,fevpg_snow_p(i) ,& + cgrnd_p(i) ,cgrndl_p(i) ,cgrnds_p(i) ,& + tref_p(i) ,qref_p(i) ,rst_p(i) ,assim_p(i) ,respc_p(i) ,& + fsenl_p(i) ,fevpl_p(i) ,etr_p(i) ,dlrad_p(i) ,ulrad_p(i) ,& + z0m_p(i) ,zol_p(i) ,rib_p(i) ,ustar_p(i) ,qstar_p(i) ,& + tstar_p(i) ,fm_p(i) ,fh_p(i) ,fq_p(i) ,rootfr_p(:,p) ,& + kmax_sun_p(p) ,kmax_sha_p(p) ,kmax_xyl_p(p) ,kmax_root_p(p) ,psi50_sun_p(p) ,& + psi50_sha_p(p) ,psi50_xyl_p(p) ,psi50_root_p(p) ,ck_p(p) ,vegwp_p(:,i) ,& + gs0sun_p(i) ,gs0sha_p(i) ,& + assimsun_p(i) ,etrsun_p(i) ,assimsha_p(i) ,etrsha_p(i) ,& +!Ozone stress variables + o3coefv_sun_p(i),o3coefv_sha_p(i),o3coefg_sun_p(i),o3coefg_sha_p(i),& + lai_old_p(i) ,o3uptakesun_p(i),o3uptakesha_p(i),forc_ozone ,& +!end ozone stress variables +!Ozone WUE stomata model parameter + lambda_p(p) ,&! Marginal water cost of carbon gain ((mol h2o) (mol co2)-1) +!End WUE stomata model parameter + forc_hpbl ,& + qintr_rain_p(i) ,qintr_snow_p(i) ,t_precip ,hprl_p(i) ,dheatl_p(i) ,& + smp ,hk(1:) ,hksati(1:) ,rootflux_p(1:,i) ) + ELSE + + CALL GroundFluxes (zlnd,zsno,forc_hgt_u,forc_hgt_t,forc_hgt_q,forc_hpbl, & + forc_us,forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & + ur,thm,th,thv,t_grnd,qg,rss,dqgdT,htvp, & + fsno,cgrnd_p(i),cgrndl_p(i),cgrnds_p(i), & + t_soil,t_snow,q_soil,q_snow, & + taux_p(i),tauy_p(i),fseng_p(i),fseng_soil_p(i),fseng_snow_p(i), & + fevpg_p(i),fevpg_soil_p(i),fevpg_snow_p(i),tref_p(i),qref_p(i), & + z0m_p(i),z0h_g,zol_p(i),rib_p(i),ustar_p(i),& + qstar_p(i),tstar_p(i),fm_p(i),fh_p(i),fq_p(i)) + + tleaf_p (i) = forc_t + gssun_p (i) = 0. + gssha_p (i) = 0. + assimsun_p (i) = 0. + etrsun_p (i) = 0. + assimsha_p (i) = 0. + etrsha_p (i) = 0. + rst_p (i) = 2.0e4 + assim_p (i) = 0. + respc_p (i) = 0. + fsenl_p (i) = 0. + fevpl_p (i) = 0. + etr_p (i) = 0. + dlrad_p (i) = frl + +IF (.not.DEF_SPLIT_SOILSNOW) THEN + ulrad_p (i) = frl*(1.-emg) + emg*stefnc*t_grnd**4 +ELSE + ulrad_p (i) = frl*(1.-emg) & + + fsno*emg*stefnc*t_snow**4 & + + (1.-fsno)*emg*stefnc*t_soil**4 +ENDIF + hprl_p (i) = 0. + + IF (DEF_USE_PLANTHYDRAULICS) THEN + vegwp_p(:,i) = -2.5e4 + ENDIF + ENDIF + ENDDO + + ! Calculate end index of natrue PFTs + DO i = ps, pe + pn = i + p = pftclass(i) + IF (DEF_PC_CROP_SPLIT .and. p.ge.15) THEN + pn = pn - 1 + EXIT + ENDIF + ENDDO + +IF ( DEF_USE_PC .and. pn.ge.ps ) THEN + + pe = pn + + ! initialization + rst_p (ps:pe) = 2.0e4 + assim_p (ps:pe) = 0. + respc_p (ps:pe) = 0. + fsenl_p (ps:pe) = 0. + fevpl_p (ps:pe) = 0. + etr_p (ps:pe) = 0. + hprl_p (ps:pe) = 0. + assimsun_p (ps:pe) = 0. + assimsha_p (ps:pe) = 0. + etrsun_p (ps:pe) = 0. + etrsha_p (ps:pe) = 0. + gssun_p (ps:pe) = 0. + gssha_p (ps:pe) = 0. + fcover (ps:pe) = pftfrac(ps:pe) / sum(pftfrac(ps:pe)) + z0m_p (ps:pe) = (1.-fsno)*zlnd + fsno*zsno + z0m = sum( z0m_p (ps:pe)*pftfrac(ps:pe) ) + + IF (DEF_USE_PLANTHYDRAULICS) THEN + vegwp_p (:,ps:pe) = -2.5e4 + ENDIF + + CALL LeafTemperaturePC (ipatch,ps,pe ,deltim ,csoilc ,dewmx ,& + htvp ,pftclass(ps:pe) ,fcover(ps:pe) ,htop_p(ps:pe) ,hbot_p(ps:pe) ,& + lai_p(ps:pe) ,sai_p(ps:pe) ,extkb_p(ps:pe) ,extkd_p(ps:pe) ,forc_hgt_u ,& + forc_hgt_t ,forc_hgt_q ,forc_us ,forc_vs ,forc_t ,& + thm ,th ,thv ,forc_q ,forc_psrf ,& + forc_rhoair ,parsun_p(ps:pe) ,parsha_p(ps:pe) ,fsun_p(:) ,sabv_p(:) ,& + frl ,thermk_p(ps:pe) ,fshade_p(ps:pe) ,rstfacsun_p(:) ,rstfacsha_p(:) ,& + gssun_p(:) ,gssha_p(:) ,forc_po2m ,forc_pco2m ,z0h_g ,& + obu_g ,ustar_g ,zlnd ,zsno ,fsno ,& + sigf_p(ps:pe) ,etrc_p(:) ,t_grnd ,qg,rss ,dqgdT ,& + emg ,t_soil ,t_snow ,q_soil ,q_snow ,& + z0m_p(ps:pe) ,tleaf_p(ps:pe) ,ldew_p(ps:pe) ,ldew_rain_p(ps:pe),ldew_snow_p(ps:pe),& + fwet_snow_p(ps:pe),taux ,tauy ,fseng ,fseng_soil ,& + fseng_snow ,fevpg ,fevpg_soil ,fevpg_snow ,cgrnd ,& + cgrndl ,cgrnds ,tref ,qref ,rst_p(ps:pe) ,& + assim_p(ps:pe) ,respc_p(ps:pe) ,fsenl_p(ps:pe) ,fevpl_p(ps:pe) ,etr_p(ps:pe) ,& + dlrad ,ulrad ,z0m ,zol ,rib ,& + ustar ,qstar ,tstar ,fm ,fh ,& + fq ,vegwp_p(:,ps:pe) ,gs0sun_p(ps:pe) ,gs0sha_p(ps:pe) ,assimsun_p(:) ,& + etrsun_p(:) ,assimsha_p(:) ,etrsha_p(:) ,& +!Ozone stress variables + o3coefv_sun_p(ps:pe) ,o3coefv_sha_p(ps:pe) ,o3coefg_sun_p(ps:pe) ,o3coefg_sha_p(ps:pe) ,& + lai_old_p(ps:pe) ,o3uptakesun_p(ps:pe) ,o3uptakesha_p(ps:pe) ,forc_ozone ,& +!End ozone stress variables + forc_hpbl ,& + qintr_rain_p(ps:pe) ,qintr_snow_p(ps:pe) ,t_precip ,hprl_p(:) ,& + dheatl_p(ps:pe) ,smp ,hk(1:) ,hksati(1:) ,& + rootflux_p(:,:) ) + + dlrad_p (ps:pe) = dlrad + ulrad_p (ps:pe) = ulrad + tref_p (ps:pe) = tref + qref_p (ps:pe) = qref + taux_p (ps:pe) = taux + tauy_p (ps:pe) = tauy + fseng_p (ps:pe) = fseng + fseng_soil_p (ps:pe) = fseng_soil + fseng_snow_p (ps:pe) = fseng_snow + fevpg_p (ps:pe) = fevpg + fevpg_soil_p (ps:pe) = fevpg_soil + fevpg_snow_p (ps:pe) = fevpg_snow + cgrnd_p (ps:pe) = cgrnd + cgrndl_p (ps:pe) = cgrndl + cgrnds_p (ps:pe) = cgrnds + z0m_p (ps:pe) = z0m + zol_p (ps:pe) = zol + rib_p (ps:pe) = rib + ustar_p (ps:pe) = ustar + qstar_p (ps:pe) = qstar + tstar_p (ps:pe) = tstar + fm_p (ps:pe) = fm + fh_p (ps:pe) = fh + fq_p (ps:pe) = fq +ENDIF + + pe = patch_pft_e(ipatch) + + ! aggregate PFTs to a patch + laisun = sum( laisun_p (ps:pe)*pftfrac(ps:pe) ) + laisha = sum( laisha_p (ps:pe)*pftfrac(ps:pe) ) + tleaf = sum( tleaf_p (ps:pe)*pftfrac(ps:pe) ) + ldew_rain = sum( ldew_rain_p (ps:pe)*pftfrac(ps:pe) ) + ldew_snow = sum( ldew_snow_p (ps:pe)*pftfrac(ps:pe) ) + fwet_snow = sum( fwet_snow_p (ps:pe)*pftfrac(ps:pe) ) + ldew = sum( ldew_p (ps:pe)*pftfrac(ps:pe) ) + ! may have problem with rst, but the same for LC + rst = sum( rst_p (ps:pe)*pftfrac(ps:pe) ) + assim = sum( assim_p (ps:pe)*pftfrac(ps:pe) ) + respc = sum( respc_p (ps:pe)*pftfrac(ps:pe) ) + fsenl = sum( fsenl_p (ps:pe)*pftfrac(ps:pe) ) + fevpl = sum( fevpl_p (ps:pe)*pftfrac(ps:pe) ) + etr = sum( etr_p (ps:pe)*pftfrac(ps:pe) ) + + dlrad = sum( dlrad_p (ps:pe)*pftfrac(ps:pe) ) + ulrad = sum( ulrad_p (ps:pe)*pftfrac(ps:pe) ) + tref = sum( tref_p (ps:pe)*pftfrac(ps:pe) ) + qref = sum( qref_p (ps:pe)*pftfrac(ps:pe) ) + taux = sum( taux_p (ps:pe)*pftfrac(ps:pe) ) + tauy = sum( tauy_p (ps:pe)*pftfrac(ps:pe) ) + fseng = sum( fseng_p (ps:pe)*pftfrac(ps:pe) ) + fseng_soil = sum( fseng_soil_p(ps:pe)*pftfrac(ps:pe) ) + fseng_snow = sum( fseng_snow_p(ps:pe)*pftfrac(ps:pe) ) + fevpg = sum( fevpg_p (ps:pe)*pftfrac(ps:pe) ) + fevpg_soil = sum( fevpg_soil_p(ps:pe)*pftfrac(ps:pe) ) + fevpg_snow = sum( fevpg_snow_p(ps:pe)*pftfrac(ps:pe) ) + cgrnd = sum( cgrnd_p (ps:pe)*pftfrac(ps:pe) ) + cgrndl = sum( cgrndl_p (ps:pe)*pftfrac(ps:pe) ) + cgrnds = sum( cgrnds_p (ps:pe)*pftfrac(ps:pe) ) + z0m = sum( z0m_p (ps:pe)*pftfrac(ps:pe) ) + zol = sum( zol_p (ps:pe)*pftfrac(ps:pe) ) + rib = sum( rib_p (ps:pe)*pftfrac(ps:pe) ) + ustar = sum( ustar_p (ps:pe)*pftfrac(ps:pe) ) + qstar = sum( qstar_p (ps:pe)*pftfrac(ps:pe) ) + tstar = sum( tstar_p (ps:pe)*pftfrac(ps:pe) ) + fm = sum( fm_p (ps:pe)*pftfrac(ps:pe) ) + fh = sum( fh_p (ps:pe)*pftfrac(ps:pe) ) + fq = sum( fq_p (ps:pe)*pftfrac(ps:pe) ) + + rstfacsun_out = sum( rstfacsun_p (ps:pe)*pftfrac(ps:pe) ) + rstfacsha_out = sum( rstfacsha_p (ps:pe)*pftfrac(ps:pe) ) + gssun_out = sum( gssun_p (ps:pe)*pftfrac(ps:pe) ) + gssha_out = sum( gssha_p (ps:pe)*pftfrac(ps:pe) ) + assimsun_out = sum( assimsun_p (ps:pe)*pftfrac(ps:pe) ) + etrsun_out = sum( etrsun_p (ps:pe)*pftfrac(ps:pe) ) + assimsha_out = sum( assimsha_p (ps:pe)*pftfrac(ps:pe) ) + etrsha_out = sum( etrsha_p (ps:pe)*pftfrac(ps:pe) ) + hprl = sum( hprl_p (ps:pe)*pftfrac(ps:pe) ) + dheatl = sum( dheatl_p (ps:pe)*pftfrac(ps:pe) ) +IF (DEF_USE_OZONESTRESS)THEN + o3uptakesun = sum(o3uptakesun_p(ps:pe)*pftfrac(ps:pe) ) + o3uptakesha = sum(o3uptakesha_p(ps:pe)*pftfrac(ps:pe) ) +END IF + + IF(DEF_USE_PLANTHYDRAULICS)THEN + DO j = 1, nvegwcs + vegwp(j) = sum( vegwp_p(j,ps:pe)*pftfrac(ps:pe) ) + ENDDO + + IF (abs(etr) > 0.) THEN + DO j = 1, nl_soil + rootflux(j) = sum(rootflux_p(j,ps:pe)*pftfrac(ps:pe)) + ENDDO + ENDIF + ELSE + IF (abs(etr) > 0.) THEN + DO j = 1, nl_soil + rootr(j) = sum(rootr_p(j,ps:pe)*etr_p(ps:pe)*pftfrac(ps:pe)) / etr + ENDDO + ENDIF + ENDIF + + deallocate ( rootflux_p ) + deallocate ( etrc_p ) + deallocate ( rstfac_p ) + deallocate ( rstfacsun_p ) + deallocate ( rstfacsha_p ) + deallocate ( gssun_p ) + deallocate ( gssha_p ) + deallocate ( fsun_p ) + deallocate ( sabv_p ) + deallocate ( fcover ) + + deallocate ( fseng_soil_p) + deallocate ( fseng_snow_p) + deallocate ( fevpg_soil_p) + deallocate ( fevpg_snow_p) + deallocate ( cgrnd_p ) + deallocate ( cgrnds_p ) + deallocate ( cgrndl_p ) + deallocate ( dlrad_p ) + deallocate ( ulrad_p ) + deallocate ( zol_p ) + deallocate ( rib_p ) + deallocate ( ustar_p ) + deallocate ( qstar_p ) + deallocate ( tstar_p ) + deallocate ( fm_p ) + deallocate ( fh_p ) + deallocate ( fq_p ) + + deallocate ( hprl_p ) + deallocate ( assimsun_p ) + deallocate ( etrsun_p ) + deallocate ( assimsha_p ) + deallocate ( etrsha_p ) + deallocate ( dheatl_p ) + +ENDIF +#endif + + +!======================================================================= +! [5] Ground temperature +!======================================================================= + + CALL GroundTemperature (patchtype,is_dry_lake,lb,nl_soil,deltim,& + capr,cnfac,vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + porsl,psi0,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm,& + sc_vgm , fc_vgm,& +#endif + csol,k_solids,dksatu,dksatf,dkdry,& + BA_alpha,BA_beta,& + sigf,dz_soisno,z_soisno,zi_soisno,& + t_soisno,t_grnd,t_soil,t_snow,wice_soisno,wliq_soisno,scv,snowdp,fsno,& + frl,dlrad,sabg,sabg_soil,sabg_snow,sabg_snow_lyr,& + fseng,fseng_soil,fseng_snow,fevpg,fevpg_soil,fevpg_snow,cgrnd,htvp,emg,& + imelt,snofrz,sm,xmf,fact,pg_rain,pg_snow,t_precip) + +!======================================================================= +! [6] Correct fluxes to present soil temperature +!======================================================================= + + IF (.not.DEF_SPLIT_SOILSNOW) THEN + t_grnd = t_soisno(lb) + tinc = t_soisno(lb) - t_soisno_bef(lb) + ELSE + t_grnd = fsno*t_soisno(lb) + (1.0-fsno)*t_soisno(1) + tinc = t_grnd - t_grnd_bef + ENDIF + + fseng = fseng + tinc*cgrnds + fseng_soil = fseng_soil + tinc*cgrnds + fseng_snow = fseng_snow + tinc*cgrnds + fevpg = fevpg + tinc*cgrndl + fevpg_soil = fevpg_soil + tinc*cgrndl + fevpg_snow = fevpg_snow + tinc*cgrndl + +! calculation of evaporative potential; flux in kg m-2 s-1. +! egidif holds the excess energy IF all water is evaporated +! during the timestep. This energy is later added to the sensible heat flux. + + qseva = 0. + qsubl = 0. + qfros = 0. + qsdew = 0. + qseva_soil = 0. + qsubl_soil = 0. + qfros_soil = 0. + qsdew_soil = 0. + qseva_snow = 0. + qsubl_snow = 0. + qfros_snow = 0. + qsdew_snow = 0. + + +IF (.not. DEF_SPLIT_SOILSNOW) THEN + egsmax = (wice_soisno(lb)+wliq_soisno(lb)) / deltim + egidif = max( 0., fevpg - egsmax ) + fevpg = min( fevpg, egsmax ) + fseng = fseng + htvp*egidif + + IF (fevpg >= 0.) THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva = min(wliq_soisno(lb)/deltim, fevpg) + qsubl = fevpg - qseva + ELSE + IF (t_grnd < tfrz) THEN + qfros = abs(fevpg) + ELSE + qsdew = abs(fevpg) + ENDIF + ENDIF + +ELSE + IF (lb < 1) THEN ! snow layer exist + egsmax = (wice_soisno(lb)+wliq_soisno(lb)) / deltim + egidif = max( 0., fevpg_snow - egsmax ) + fevpg_snow = min ( fevpg_snow, egsmax ) + fseng_snow = fseng_snow + htvp*egidif + ELSE ! no snow layer, attribute to soil + fevpg_soil = fevpg_soil*(1.-fsno) + fevpg_snow*fsno + ENDIF + + egsmax = (wice_soisno(1)+wliq_soisno(1)) / deltim + egidif = max( 0., fevpg_soil - egsmax ) + fevpg_soil = min ( fevpg_soil, egsmax ) + fseng_soil = fseng_soil + htvp*egidif + + IF (lb < 1) THEN ! snow layer exist + fseng = fseng_soil*(1.-fsno) + fseng_snow*fsno + fevpg = fevpg_soil*(1.-fsno) + fevpg_snow*fsno + ELSE ! no snow layer, attribute to soil + fseng = fseng_soil; fseng_snow = 0. + fevpg = fevpg_soil; fevpg_snow = 0. + ENDIF + + IF(fevpg_snow >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_snow = min(wliq_soisno(lb)/deltim, fevpg_snow) + qsubl_snow = fevpg_snow - qseva_snow + qseva_snow = qseva_snow*fsno + qsubl_snow = qsubl_snow*fsno + ELSE + ! snow temperature < tfrz + IF(t_soisno(lb) < tfrz)THEN + qfros_snow = abs(fevpg_snow*fsno) + ELSE + qsdew_snow = abs(fevpg_snow*fsno) + ENDIF + ENDIF + + IF(fevpg_soil >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_soil = min(wliq_soisno(1)/deltim, fevpg_soil) + qsubl_soil = fevpg_soil - qseva_soil + ELSE + ! soil temperature < tfrz + IF(t_soisno(1) < tfrz)THEN + qfros_soil = abs(fevpg_soil) + ELSE + qsdew_soil = abs(fevpg_soil) + ENDIF + ENDIF + + IF (lb < 1) THEN ! snow layer exists + qseva_soil = qseva_soil*(1.-fsno) + qsubl_soil = qsubl_soil*(1.-fsno) + qfros_soil = qfros_soil*(1.-fsno) + qsdew_soil = qsdew_soil*(1.-fsno) + ENDIF +ENDIF + + +! total fluxes to atmosphere + fsena = fsenl + fseng + fevpa = fevpl + fevpg + lfevpa = hvap*fevpl + htvp*fevpg ! W/m^2 (accounting for sublimation) + +! ground heat flux +IF (.not.DEF_SPLIT_SOILSNOW) THEN + fgrnd = sabg + dlrad*emg & + - emg*stefnc*t_grnd_bef**4 & + - emg*stefnc*t_grnd_bef**3*(4.*tinc) & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) +ELSE + fgrnd = sabg + dlrad*emg & + - fsno*emg*stefnc*t_snow**4 & + - (1.-fsno)*emg*stefnc*t_soil**4 & + - emg*stefnc*t_grnd_bef**3*(4.*tinc) & + - (fseng+fevpg*htvp) & + + cpliq*pg_rain*(t_precip-t_grnd) & + + cpice*pg_snow*(t_precip-t_grnd) +ENDIF + +! outgoing long-wave radiation from canopy + ground + olrg = ulrad & +! for conservation we put the increase of ground longwave to outgoing + + 4.*emg*stefnc*t_grnd_bef**3*tinc + +! averaged bulk surface emissivity + olrb = stefnc*t_grnd_bef**3*(4.*tinc) + olru = ulrad + emg*olrb + olrb = ulrad + olrb + emis = olru / olrb + +! radiative temperature + IF (olrg < 0) THEN + print *, "MOD_Thermal.F90: Error! Negative outgoing longwave radiation flux: " + write(6,*) ipatch, olrg, tinc, ulrad + write(6,*) ipatch,errore,sabv,sabg,frl,olrg,fsenl,fseng,hvap*fevpl,htvp*fevpg,xmf,fgrnd + ENDIF + + trad = (olrg/stefnc)**0.25 + +! additional variables required by WRF and RSM model + IF (lai+sai <= 1e-6) THEN + ustar = ustar_g + tstar = tstar_g + qstar = qstar_g + rib = rib_g + zol = zol_g + z0m = z0m_g + fm = fm_g + fh = fh_g + fq = fq_g + ENDIF + + +!======================================================================= +! [7] energy balance error +!======================================================================= + + ! one way to check energy balance + errore = sabv + sabg + frl - olrg - fsena - lfevpa - fgrnd - dheatl + hprl & + + cpliq*pg_rain*(t_precip-t_grnd) + cpice*pg_snow*(t_precip-t_grnd) + + ! another way to check energy balance + errore = sabv + sabg + frl - olrg - fsena - lfevpa - xmf - dheatl + hprl & + + cpliq*pg_rain*(t_precip-t_grnd) + cpice*pg_snow*(t_precip-t_grnd) + + DO j = lb, nl_soil + errore = errore - (t_soisno(j)-t_soisno_bef(j))/fact(j) + ENDDO + +#if (defined CoLMDEBUG) + IF (abs(errore) > .5) THEN + write(6,*) 'MOD_Thermal.F90: energy balance violation' + write(6,*) ipatch,errore,sabv,sabg,frl,olrg,fsenl,fseng,hvap*fevpl,htvp*fevpg,xmf,hprl + write(6,*) cpliq*pg_rain*(t_precip-t_grnd), cpice*pg_snow*(t_precip-t_grnd) + CALL CoLM_stop () + ENDIF +100 format(10(f15.3)) +#endif + + END SUBROUTINE THERMAL + +END MODULE MOD_Thermal +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_TurbulenceLEddy.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_TurbulenceLEddy.F90 new file mode 100644 index 0000000000..6ab6cbff0f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_TurbulenceLEddy.F90 @@ -0,0 +1,465 @@ +MODULE MOD_TurbulenceLEddy + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: moninobuk_leddy + PUBLIC :: moninobukm_leddy + + +! PRIVATE MEMBER FUNCTIONS: + PRIVATE :: psi + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE moninobuk_leddy(hu,ht,hq,displa,z0m,z0h,z0q,obu,um, hpbl, & + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + +!======================================================================= +! +! Implement the LZD2022 scheme (Liu et al., 2022), which accounts for +! large eddy effects by including the boundary layer height in the phim +! FUNCTION, to compute friction velocity, relation for potential +! temperature and humidity profiles of surface boundary layer. +! +! !REFERENCES: +! [1] Zeng et al., 1998: Intercomparison of bulk aerodynamic algorithms +! for the computation of sea surface fluxes using TOGA CORE and TAO +! data. J. Climate, 11: 2628-2644. +! [2] Liu et al., 2022: A surface flux estimation scheme accounting for +! large-eddy effects for land surface modeling. GRL, 49, +! e2022GL101754. +! +! Created by Shaofeng Liu, May 5, 2023 +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stability effect [m/s] + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fm10m ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + +!-------------------------- Local Variables ---------------------------- + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam, & + zetam2 ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) zetazi ! hpbl/obu, dimensionless height used in the LZD2022 scheme + real(r8) Bm ! Coefficient of the LZD2022 scheme: Bm = 0.0047*(-hpbl/L) + 0.1854 + real(r8) Bm2 ! max(Bm, 0.2722) + +! real(r8), external :: psi ! stability FUNCTION for unstable CASE +!----------------------------------------------------------------------- +! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + +! wind profile + zldis=hu-displa + zeta=zldis/obu +! +! Begin: Shaofeng Liu, 2023.05.05 +! + zetazi = max(5.*hu, hpbl)/obu + IF(zetazi >= 0.) THEN !stable + zetazi = min(200.,max(zetazi,1.e-5)) + ELSE !unstable + zetazi = max(-1.e4,min(zetazi,-1.e-5)) + ENDIF + + Bm = 0.0047 * (-zetazi) + 0.1854 + zetam = 0.5*Bm**4 * ( -16. - sqrt(256. + 4./Bm**4) ) + Bm2 = max(Bm, 0.2722) + zetam2 = min(zetam, -0.13) + + IF(zeta < zetam2)THEN ! zeta < zetam2 + fm = log(zetam2*obu/z0m) - psi(1,zetam2) & + + psi(1,z0m/obu) - 2.*Bm2 * ( (-zeta)**(-0.5)-(-zetam2)**(-0.5) ) + ustar = vonkar*um / fm +! +! End: Shaofeng Liu, 2023.05.05 +! + ELSEIF (zeta < 0.)THEN ! zetam2 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + +! for 10 meter wind-velocity + zldis=10.+z0m + zeta=zldis/obu +! +! Begin: Shaofeng Liu, 2023.05.18 +! + IF(zeta < zetam2)THEN ! zeta < zetam2 + fm10m = log(zetam2*obu/z0m) - psi(1,zetam2) & + + psi(1,z0m/obu) - 2.*Bm2 * ( (-zeta)**(-0.5)-(-zetam2)**(-0.5) ) +! +! End: Shaofeng Liu, 2023.05.18 +! + ELSEIF (zeta < 0.)THEN ! zetam2 <= zeta < 0 + fm10m = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm10m = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fm10m = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! temperature profile + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! humidity profile + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for 2 meter screen humidity + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobuk_leddy + + + SUBROUTINE moninobukm_leddy(hu,ht,hq,displa,z0m,z0h,z0q,obu,um,displat,z0mt, hpbl, & + ustar,fh2m,fq2m,htop,fmtop,fm,fh,fq,fht,fqt,phih) + +!======================================================================= +! +! !DESCRIPTION: +! +! +! Original author: Yongjiu Dai, September 15, 1999 +! +! calculation of friction velocity, relation for potential temperature and +! humidity profiles of surface boundary layer. the scheme is based on the work +! of Zeng et al. (1998): Intercomparison of bulk aerodynamic algorithms for the +! computation of sea surface fluxes using TOGA CORE and TAO data. J. Climate, +! Vol. 11: 2628-2644 +! +! !REVISIONS: +! Hua Yuan, 09/2017: adapted from moninobuk FUNCTION to calculate canopy top +! fm, fq and phih for roughness sublayer u/k profile calculation +! Shaofeng Liu, 05/2023: implement the LZD2022 scheme (Liu et al., 2022), which +! accounts for large eddy effects by including the +! boundary leyer height in the phim FUNCTION. +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar + IMPLICIT NONE + +! ---------------------- dummy argument -------------------------------- + + real(r8), intent(in) :: hu ! observational height of wind [m] + real(r8), intent(in) :: ht ! observational height of temperature [m] + real(r8), intent(in) :: hq ! observational height of humidity [m] + real(r8), intent(in) :: displa ! displacement height [m] + real(r8), intent(in) :: displat ! displacement height of the top layer [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(in) :: z0h ! roughness length, sensible heat [m] + real(r8), intent(in) :: z0q ! roughness length, latent heat [m] + real(r8), intent(in) :: z0mt ! roughness length of the top layer, latent heat [m] + real(r8), intent(in) :: htop ! canopy top height of the top layer [m] + real(r8), intent(in) :: obu ! monin-obukhov length (m) + real(r8), intent(in) :: um ! wind speed including the stability effect [m/s] + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(out) :: ustar ! friction velocity [m/s] + real(r8), intent(out) :: fh2m ! relation for temperature at 2m + real(r8), intent(out) :: fq2m ! relation for specific humidity at 2m + real(r8), intent(out) :: fmtop ! integral of profile FUNCTION for momentum at 10m + real(r8), intent(out) :: fm ! integral of profile FUNCTION for momentum + real(r8), intent(out) :: fh ! integral of profile FUNCTION for heat + real(r8), intent(out) :: fq ! integral of profile FUNCTION for moisture + real(r8), intent(out) :: fht ! integral of profile FUNCTION for heat at the top layer + real(r8), intent(out) :: fqt ! integral of profile FUNCTION for moisture at the top layer + real(r8), intent(out) :: phih ! phi(h), similarity FUNCTION for sensible heat + +!------------------------ local variables ------------------------------ + + real(r8) zldis ! reference height "minus" zero displacement height [m] + real(r8) zetam, & + zetam2 ! transition point of flux-gradient relation (wind profile) + real(r8) zetat ! transition point of flux-gradient relation (temp. profile) + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) zetazi ! hpbl/obu, dimensionless height used in the LZD2022 scheme + real(r8) Bm ! Coefficient of the LZD2022 scheme: Bm = 0.0047*(-hpbl/L) + 0.1854 + real(r8) Bm2 ! max(Bm, 0.2722) + +! real(r8), external :: psi ! stability FUNCTION for unstable CASE +!----------------------------------------------------------------------- +! adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + +! wind profile + zldis=hu-displa + zeta=zldis/obu +! +! Begin: Shaofeng Liu, 2023.05.05 +! +! zetazi = hpbl/obu + zetazi = max(5.*hu, hpbl)/obu + IF(zetazi >= 0.) THEN !stable + zetazi = min(200.,max(zetazi,1.e-5)) + ELSE !unstable + zetazi = max(-1.e4,min(zetazi,-1.e-5)) + ENDIF + + Bm = 0.0047 * (-zetazi) + 0.1854 + zetam = 0.5*Bm**4 * ( -16. - sqrt(256. + 4./Bm**4) ) + Bm2 = max(Bm, 0.2722) + zetam2 = min(zetam, -0.13) + + IF(zeta < zetam2)THEN ! zeta < zetam2 + fm = log(zetam2*obu/z0m) - psi(1,zetam2) & + + psi(1,z0m/obu) - 2.*Bm2 * ( (-zeta)**(-0.5)-(-zetam2)**(-0.5) ) + ustar = vonkar*um / fm +! +! End: Shaofeng Liu, 2023.05.05 +! + ELSEIF (zeta < 0.)THEN ! zetam2 <= zeta < 0 + fm = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ustar = vonkar*um / fm + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fm = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ustar = vonkar*um / fm + ELSE ! 1 < zeta, phi=5+zeta + fm = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ustar = vonkar*um / fm + ENDIF + +! for canopy top wind-velocity +!NOTE: changed for canopy top wind-velocity (no wake assumed) + zldis=htop-displa + zeta=zldis/obu +! +! Begin: Shaofeng Liu, 2023.05.18 +! +! zetam=1.574 + IF(zeta < zetam2)THEN ! zeta < zetam2 + fmtop = log(zetam2*obu/z0m) - psi(1,zetam2) & + + psi(1,z0m/obu) - 2.*Bm2 * ( (-zeta)**(-0.5)-(-zetam2)**(-0.5) ) +! +! End: Shaofeng Liu, 2023.05.18 +! + ELSEIF (zeta < 0.)THEN ! zetam2 <= zeta < 0 + fmtop = log(zldis/z0m) - psi(1,zeta) + psi(1,z0m/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fmtop = log(zldis/z0m) + 5.*zeta - 5.*z0m/obu + ELSE ! 1 < zeta, phi=5+zeta + fmtop = log(obu/z0m) + 5. - 5.*z0m/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! temperature profile + zldis=ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for 2 meter screen temperature + zldis=2.+z0h ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fh2m = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fh2m = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fh2m = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fh2m = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for top layer temperature + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fht = log(-zetat*obu/z0h)-psi(2,-zetat) & + + psi(2,z0h/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fht = log(zldis/z0h) - psi(2,zeta) + psi(2,z0h/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fht = log(zldis/z0h) + 5.*zeta - 5.*z0h/obu + ELSE ! 1 < zeta, phi=5+zeta + fht = log(obu/z0h) + 5. - 5.*z0h/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for canopy top phi(h) +! CESM TECH NOTE eq. (5.31) + zldis=htop-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + phih = 0.9*vonkar**(1.333)*(-zeta)**(-0.333) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + phih = (1. - 16.*zeta)**(-0.5) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + phih = 1. + 5.*zeta + ELSE ! 1 < zeta, phi=5+zeta + phih = 5. + zeta + ENDIF + +! humidity profile + zldis=hq-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq = log(-zetat*obu/z0q) - psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.)THEN ! -1 <= zeta < 0 + fq = log(zldis/z0q) - psi(2,zeta) + psi(2,z0q/obu) + ELSEIF (zeta <= 1.)THEN ! 0 <= zeta <= 1 + fq = log(zldis/z0q) + 5.*zeta - 5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq = log(obu/z0q) + 5. - 5.*z0q/obu + (5.*log(zeta)+zeta-1.) + ENDIF + +! for 2 meter screen humidity + zldis=2.+z0h + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fq2m = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fq2m = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fq2m = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fq2m = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + +! for top layer humidity + zldis=displat+z0mt-displa ! ht-displa + zeta=zldis/obu + zetat=0.465 + IF(zeta < -zetat)THEN ! zeta < -1 + fqt = log(-zetat*obu/z0q)-psi(2,-zetat) & + + psi(2,z0q/obu) + 0.8*((zetat)**(-0.333)-(-zeta)**(-0.333)) + ELSEIF (zeta < 0.) THEN ! -1 <= zeta < 0 + fqt = log(zldis/z0q)-psi(2,zeta)+psi(2,z0q/obu) + ELSEIF (zeta <= 1.) THEN ! 0 <= zeta <= 1 + fqt = log(zldis/z0q)+5.*zeta-5.*z0q/obu + ELSE ! 1 < zeta, phi=5+zeta + fqt = log(obu/z0q)+5.-5.*z0q/obu+(5.*log(zeta)+zeta-1.) + ENDIF + + END SUBROUTINE moninobukm_leddy + + + + real(r8) FUNCTION psi(k,zeta) + +!======================================================================= +! stability FUNCTION for unstable CASE (rib < 0) + + USE MOD_Precision + IMPLICIT NONE + + integer k + real(r8) zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) chik ! + + chik = (1.-16.*zeta)**0.25 + IF(k == 1)THEN + psi = 2.*log((1.+chik)*0.5)+log((1.+chik*chik)*0.5)-2.*atan(chik)+2.*atan(1.) + ELSE + psi = 2.*log((1.+chik*chik)*0.5) + ENDIF + + END FUNCTION psi + + +END MODULE MOD_TurbulenceLEddy +! --------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 new file mode 100644 index 0000000000..c99adaf678 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DFluxes.F90 @@ -0,0 +1,305 @@ +#include + +MODULE MOD_Vars_1DFluxes +!----------------------------------------------------------------------- +! Created by Yongjiu Dai, 03/2014 +!----------------------------------------------------------------------- + + USE MOD_Precision +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_1DPFTFluxes +#endif +#ifdef BGC + USE MOD_BGC_Vars_1DFluxes +#endif +#ifdef CatchLateralFlow + USE MOD_Catch_Vars_1DFluxes +#endif +#ifdef URBAN_MODEL + USE MOD_Urban_Vars_1DFluxes +#endif +#ifdef DataAssimilation + USE MOD_DA_Vars_1DFluxes +#endif + IMPLICIT NONE + SAVE + +!----------------------------------------------------------------------- +! Fluxes +!----------------------------------------------------------------------- + real(r8), allocatable :: taux (:) !wind stress: E-W [kg/m/s2] + real(r8), allocatable :: tauy (:) !wind stress: N-S [kg/m/s2] + real(r8), allocatable :: fsena (:) !sensible heat from canopy height to atmosphere [W/m2] + real(r8), allocatable :: lfevpa (:) !latent heat flux from canopy height to atmosphere [W/m2] + real(r8), allocatable :: fevpa (:) !evapotranspiration from canopy to atmosphere [mm/s] + real(r8), allocatable :: fsenl (:) !sensible heat from leaves [W/m2] + real(r8), allocatable :: fevpl (:) !evaporation+transpiration from leaves [mm/s] + real(r8), allocatable :: etr (:) !transpiration rate [mm/s] + real(r8), allocatable :: fseng (:) !sensible heat flux from ground [W/m2] + real(r8), allocatable :: fevpg (:) !evaporation heat flux from ground [mm/s] + real(r8), allocatable :: fgrnd (:) !ground heat flux [W/m2] + real(r8), allocatable :: sabvsun(:) !solar absorbed by sunlit vegetation [W/m2] + real(r8), allocatable :: sabvsha(:) !solar absorbed by shaded vegetation [W/m2] + real(r8), allocatable :: sabg (:) !solar absorbed by ground [W/m2] + real(r8), allocatable :: sr (:) !total reflected solar radiation (W/m2) + real(r8), allocatable :: solvd (:) !incident direct beam vis solar radiation (W/m2) + real(r8), allocatable :: solvi (:) !incident diffuse beam vis solar radiation (W/m2) + real(r8), allocatable :: solnd (:) !incident direct beam nir solar radiation (W/m2) + real(r8), allocatable :: solni (:) !incident diffuse beam nir solar radiation (W/m2) + real(r8), allocatable :: srvd (:) !reflected direct beam vis solar radiation (W/m2) + real(r8), allocatable :: srvi (:) !reflected diffuse beam vis solar radiation (W/m2) + real(r8), allocatable :: srnd (:) !reflected direct beam nir solar radiation (W/m2) + real(r8), allocatable :: srni (:) !reflected diffuse beam nir solar radiation (W/m2) + real(r8), allocatable :: solvdln(:) !incident direct beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: solviln(:) !incident diffuse beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: solndln(:) !incident direct beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: solniln(:) !incident diffuse beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: srvdln (:) !reflected direct beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: srviln (:) !reflected diffuse beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: srndln (:) !reflected direct beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: srniln (:) !reflected diffuse beam nir solar radiation at local noon (W/m2) +#ifdef HYPERSPECTRAL + real(r8), allocatable :: sol_dir_ln_hires(:,:) !incident direct beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: sol_dif_ln_hires(:,:) !incident diffuse beam vis solar radiation at local noon (W/m2) + real(r8), allocatable :: sr_dir_ln_hires (:,:) !reflected direct beam nir solar radiation at local noon (W/m2) + real(r8), allocatable :: sr_dif_ln_hires (:,:) !reflected diffuse beam nir solar radiation at local noon (W/m2) +#endif + real(r8), allocatable :: olrg (:) !outgoing long-wave radiation from ground+canopy [W/m2] + real(r8), allocatable :: rnet (:) !net radiation by surface [W/m2] + real(r8), allocatable :: xerr (:) !the error of water balance [mm/s] + real(r8), allocatable :: zerr (:) !the error of energy balance [W/m2] + real(r8), allocatable :: frcsat (:) !fraction of saturation area [-] + real(r8), allocatable :: rsur (:) !surface runoff (mm h2o/s) + real(r8), allocatable :: rsur_se(:) !saturation excess surface runoff (mm h2o/s) + real(r8), allocatable :: rsur_ie(:) !infiltration excess surface runoff (mm h2o/s) + real(r8), allocatable :: rsub (:) !subsurface runoff (mm h2o/s) + real(r8), allocatable :: rnof (:) !total runoff (mm h2o/s) + real(r8), allocatable :: qintr (:) !interception (mm h2o/s) + real(r8), allocatable :: qinfl (:) !infiltration (mm h2o/s) + real(r8), allocatable :: qdrip (:) !throughfall (mm h2o/s) + real(r8), allocatable :: assim (:) !canopy assimilation rate (mol m-2 s-1) + real(r8), allocatable :: respc (:) !canopy respiration (mol m-2 s-1) + + real(r8), allocatable :: qcharge(:) !groundwater recharge [mm/s] + + real(r8), allocatable :: qlayer (:,:) !water flux at between soil layer [mm h2o/s] + real(r8), allocatable :: lake_deficit (:) !lake deficit due to evaporation (mm h2o/s) + + real(r8), allocatable :: oroflag(:) !/ocean(0)/seaice(2) flag + + integer, parameter :: nsensor = 1 + real(r8), allocatable :: sensors(:,:) + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_Fluxes + PUBLIC :: deallocate_1D_Fluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_Fluxes + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! ------------------------------------------------------------------- + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_MPAS_MPI + USE MOD_LandPatch + IMPLICIT NONE + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + allocate ( taux (numpatch) ) ; taux (:) = spval ! wind stress: E-W [kg/m/s2] + allocate ( tauy (numpatch) ) ; tauy (:) = spval ! wind stress: N-S [kg/m/s2] + allocate ( fsena (numpatch) ) ; fsena (:) = spval ! sensible heat from canopy height to atmosphere [W/m2] + allocate ( lfevpa (numpatch) ) ; lfevpa (:) = spval ! latent heat flux from canopy height to atmosphere [W/m2] + allocate ( fevpa (numpatch) ) ; fevpa (:) = spval ! evapotranspiration from canopy to atmosphere [mm/s] + allocate ( fsenl (numpatch) ) ; fsenl (:) = spval ! sensible heat from leaves [W/m2] + allocate ( fevpl (numpatch) ) ; fevpl (:) = spval ! evaporation+transpiration from leaves [mm/s] + allocate ( etr (numpatch) ) ; etr (:) = spval ! transpiration rate [mm/s] + allocate ( fseng (numpatch) ) ; fseng (:) = spval ! sensible heat flux from ground [W/m2] + allocate ( fevpg (numpatch) ) ; fevpg (:) = spval ! evaporation heat flux from ground [mm/s] + allocate ( fgrnd (numpatch) ) ; fgrnd (:) = spval ! ground heat flux [W/m2] + allocate ( sabvsun(numpatch) ) ; sabvsun(:) = spval ! solar absorbed by sunlit vegetation [W/m2] + allocate ( sabvsha(numpatch) ) ; sabvsha(:) = spval ! solar absorbed by shaded vegetation [W/m2] + allocate ( sabg (numpatch) ) ; sabg (:) = spval ! solar absorbed by ground [W/m2] + allocate ( sr (numpatch) ) ; sr (:) = spval ! incident direct beam vis solar radiation (W/m2) + allocate ( solvd (numpatch) ) ; solvd (:) = spval ! incident direct beam vis solar radiation (W/m2) + allocate ( solvi (numpatch) ) ; solvi (:) = spval ! incident diffuse beam vis solar radiation (W/m2) + allocate ( solnd (numpatch) ) ; solnd (:) = spval ! incident direct beam nir solar radiation (W/m2) + allocate ( solni (numpatch) ) ; solni (:) = spval ! incident diffuse beam nir solar radiation (W/m2) + allocate ( srvd (numpatch) ) ; srvd (:) = spval ! reflected direct beam vis solar radiation (W/m2) + allocate ( srvi (numpatch) ) ; srvi (:) = spval ! reflected diffuse beam vis solar radiation (W/m2) + allocate ( srnd (numpatch) ) ; srnd (:) = spval ! reflected direct beam nir solar radiation (W/m2) + allocate ( srni (numpatch) ) ; srni (:) = spval ! reflected diffuse beam nir solar radiation (W/m2) + allocate ( solvdln(numpatch) ) ; solvdln(:) = spval ! incident direct beam vis solar radiation at local noon(W/m2) + allocate ( solviln(numpatch) ) ; solviln(:) = spval ! incident diffuse beam vis solar radiation at local noon(W/m2) + allocate ( solndln(numpatch) ) ; solndln(:) = spval ! incident direct beam nir solar radiation at local noon(W/m2) + allocate ( solniln(numpatch) ) ; solniln(:) = spval ! incident diffuse beam nir solar radiation at local noon(W/m2) + allocate ( srvdln (numpatch) ) ; srvdln (:) = spval ! reflected direct beam vis solar radiation at local noon(W/m2) + allocate ( srviln (numpatch) ) ; srviln (:) = spval ! reflected diffuse beam vis solar radiation at local noon(W/m2) + allocate ( srndln (numpatch) ) ; srndln (:) = spval ! reflected direct beam nir solar radiation at local noon(W/m2) + allocate ( srniln (numpatch) ) ; srniln (:) = spval ! reflected diffuse beam nir solar radiation at local noon(W/m2) +#ifdef HYPERSPECTRAL + allocate ( sol_dir_ln_hires(211,numpatch) ) ; sol_dir_ln_hires(:,:) = spval ! incident direct beam vis solar radiation at local noon(W/m2) + allocate ( sol_dif_ln_hires(211,numpatch) ) ; sol_dif_ln_hires(:,:) = spval ! incident diffuse beam vis solar radiation at local noon(W/m2) + allocate ( sr_dir_ln_hires (211,numpatch) ) ; sr_dir_ln_hires (:,:) = spval ! reflected direct beam nir solar radiation at local noon(W/m2) + allocate ( sr_dif_ln_hires (211,numpatch) ) ; sr_dif_ln_hires (:,:) = spval ! reflected diffuse beam nir solar radiation at local noon(W/m2) +#endif + allocate ( olrg (numpatch) ) ; olrg (:) = spval ! outgoing long-wave radiation from ground+canopy [W/m2] + allocate ( rnet (numpatch) ) ; rnet (:) = spval ! net radiation by surface [W/m2] + allocate ( xerr (numpatch) ) ; xerr (:) = spval ! the error of water balance [mm/s] + allocate ( zerr (numpatch) ) ; zerr (:) = spval ! the error of energy balance [W/m2] + + allocate ( frcsat (numpatch) ) ; frcsat (:) = spval ! fraction of saturation area [-] + allocate ( rsur (numpatch) ) ; rsur (:) = spval ! surface runoff (mm h2o/s) + allocate ( rsur_se(numpatch) ) ; rsur_se(:) = spval ! saturation excess surface runoff (mm h2o/s) + allocate ( rsur_ie(numpatch) ) ; rsur_ie(:) = spval ! infiltration excess surface runoff (mm h2o/s) + allocate ( rsub (numpatch) ) ; rsub (:) = spval ! subsurface runoff (mm h2o/s) + allocate ( rnof (numpatch) ) ; rnof (:) = spval ! total runoff (mm h2o/s) + allocate ( qintr (numpatch) ) ; qintr (:) = spval ! interception (mm h2o/s) + allocate ( qinfl (numpatch) ) ; qinfl (:) = spval ! infiltration (mm h2o/s) + allocate ( qdrip (numpatch) ) ; qdrip (:) = spval ! throughfall (mm h2o/s) + allocate ( assim (numpatch) ) ; assim (:) = spval ! canopy assimilation rate (mol m-2 s-1) + allocate ( respc (numpatch) ) ; respc (:) = spval ! canopy respiration (mol m-2 s-1) + + allocate ( qcharge(numpatch) ) ; qcharge(:) = spval ! groundwater recharge [mm/s] + + allocate ( qlayer (0:nl_soil,numpatch) ); qlayer(:,:) = spval ! water flux between soil layer [mm h2o/s] + allocate ( lake_deficit (numpatch) ); lake_deficit(:) = spval ! lake deficit due to evaporation (mm h2o/s) + + allocate ( oroflag(numpatch) ) ; oroflag(:) = 1.0 ! /ocean(0)/seaice(2) flag + + allocate ( sensors(nsensor,numpatch) ); sensors(:,:) = spval ! + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL allocate_1D_PFTFluxes +#endif + +#ifdef BGC + CALL allocate_1D_BGCFluxes +#endif + +#ifdef CatchLateralFlow + CALL allocate_1D_CatchFluxes +#endif + +#ifdef URBAN_MODEL + CALL allocate_1D_UrbanFluxes +#endif + +#ifdef DataAssimilation + CALL allocate_1D_DAFluxes +#endif + + END SUBROUTINE allocate_1D_Fluxes + + SUBROUTINE deallocate_1D_Fluxes () + ! -------------------------------------------------------------------- + ! deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_LandPatch + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + deallocate ( taux ) ! wind stress: E-W [kg/m/s2] + deallocate ( tauy ) ! wind stress: N-S [kg/m/s2] + deallocate ( fsena ) ! sensible heat from canopy height to atmosphere [W/m2] + deallocate ( lfevpa ) ! latent heat flux from canopy height to atmosphere [W/m2] + deallocate ( fevpa ) ! evapotranspiration from canopy to atmosphere [mm/s] + deallocate ( fsenl ) ! sensible heat from leaves [W/m2] + deallocate ( fevpl ) ! evaporation+transpiration from leaves [mm/s] + deallocate ( etr ) ! transpiration rate [mm/s] + deallocate ( fseng ) ! sensible heat flux from ground [W/m2] + deallocate ( fevpg ) ! evaporation heat flux from ground [mm/s] + deallocate ( fgrnd ) ! ground heat flux [W/m2] + deallocate ( sabvsun ) ! solar absorbed by sunlit vegetation [W/m2] + deallocate ( sabvsha ) ! solar absorbed by shaded vegetation [W/m2] + deallocate ( sabg ) ! solar absorbed by ground [W/m2] + deallocate ( sr ) ! incident direct beam vis solar radiation (W/m2) + deallocate ( solvd ) ! incident direct beam vis solar radiation (W/m2) + deallocate ( solvi ) ! incident diffuse beam vis solar radiation (W/m2) + deallocate ( solnd ) ! incident direct beam nir solar radiation (W/m2) + deallocate ( solni ) ! incident diffuse beam nir solar radiation (W/m2) + deallocate ( srvd ) ! reflected direct beam vis solar radiation (W/m2) + deallocate ( srvi ) ! reflected diffuse beam vis solar radiation (W/m2) + deallocate ( srnd ) ! reflected direct beam nir solar radiation (W/m2) + deallocate ( srni ) ! reflected diffuse beam nir solar radiation (W/m2) + deallocate ( solvdln ) ! incident direct beam vis solar radiation at local noon(W/m2) + deallocate ( solviln ) ! incident diffuse beam vis solar radiation at local noon(W/m2) + deallocate ( solndln ) ! incident direct beam nir solar radiation at local noon(W/m2) + deallocate ( solniln ) ! incident diffuse beam nir solar radiation at local noon(W/m2) + deallocate ( srvdln ) ! reflected direct beam vis solar radiation at local noon(W/m2) + deallocate ( srviln ) ! reflected diffuse beam vis solar radiation at local noon(W/m2) + deallocate ( srndln ) ! reflected direct beam nir solar radiation at local noon(W/m2) + deallocate ( srniln ) ! reflected diffuse beam nir solar radiation at local noon(W/m2) +#ifdef HYPERSPECTRAL + deallocate ( sol_dir_ln_hires ) ! incident direct beam vis solar radiation at local noon(W/m2) + deallocate ( sol_dif_ln_hires ) ! incident diffuse beam vis solar radiation at local noon(W/m2) + deallocate ( sr_dir_ln_hires ) ! reflected direct beam nir solar radiation at local noon(W/m2) + deallocate ( sr_dif_ln_hires ) ! reflected diffuse beam nir solar radiation at local noon(W/m2) +#endif + deallocate ( olrg ) ! outgoing long-wave radiation from ground+canopy [W/m2] + deallocate ( rnet ) ! net radiation by surface [W/m2] + deallocate ( xerr ) ! the error of water balance [mm/s] + deallocate ( zerr ) ! the error of energy balance [W/m2] + deallocate ( frcsat ) ! fraction of saturation area [-] + deallocate ( rsur ) ! surface runoff (mm h2o/s) + deallocate ( rsur_se ) ! saturation excess surface runoff (mm h2o/s) + deallocate ( rsur_ie ) ! infiltration excess surface runoff (mm h2o/s) + deallocate ( rsub ) ! subsurface runoff (mm h2o/s) + deallocate ( rnof ) ! total runoff (mm h2o/s) + deallocate ( qintr ) ! interception (mm h2o/s) + deallocate ( qinfl ) ! infiltration (mm h2o/s) + deallocate ( qdrip ) ! throughfall (mm h2o/s) + deallocate ( assim ) ! canopy assimilation rate (mol m-2 s-1) + deallocate ( respc ) ! canopy respiration (mol m-2 s-1) + + deallocate ( qcharge ) ! groundwater recharge [mm/s] + deallocate ( qlayer ) ! water flux between soil layer [mm h2o/s] + deallocate ( lake_deficit ) ! lake deficit due to evaporation (mm h2o/s) + + deallocate ( oroflag ) ! + + deallocate ( sensors ) ! + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL deallocate_1D_PFTFluxes +#endif + +#ifdef BGC + CALL deallocate_1D_BGCFluxes +#endif + +#ifdef CatchLateralFlow + CALL deallocate_1D_CatchFluxes +#endif + +#ifdef URBAN_MODEL + CALL deallocate_1D_UrbanFluxes +#endif + +#ifdef DataAssimilation + CALL deallocate_1D_DAFluxes +#endif + + END SUBROUTINE deallocate_1D_Fluxes + +END MODULE MOD_Vars_1DFluxes +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 new file mode 100644 index 0000000000..745c13b9bc --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90 @@ -0,0 +1,200 @@ +#include + +MODULE MOD_Vars_1DForcing +!----------------------------------------------------------------------- +! Meteorological Forcing +! +! Created by Yongjiu Dai, 03/2014 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE + + character(len=*), parameter :: forc_height_mode = 'absolute' + +!----------------------------------------------------------------------- + real(r8), allocatable :: forc_pco2m (:) ! CO2 concentration in atmos. (pascals) + real(r8), allocatable :: forc_po2m (:) ! O2 concentration in atmos. (pascals) + real(r8), allocatable :: forc_us (:) ! wind in eastward direction [m/s] + real(r8), allocatable :: forc_vs (:) ! wind in northward direction [m/s] + real(r8), allocatable :: forc_t (:) ! temperature at reference height [kelvin] + real(r8), allocatable :: forc_q (:) ! specific humidity at reference height [kg/kg] + real(r8), allocatable :: forc_prc (:) ! convective precipitation [mm/s] + real(r8), allocatable :: forc_prl (:) ! large scale precipitation [mm/s] + real(r8), allocatable :: forc_rain (:) ! rain [mm/s] + real(r8), allocatable :: forc_snow (:) ! snow [mm/s] + real(r8), allocatable :: forc_psrf (:) ! atmospheric pressure at the surface [pa] + real(r8), allocatable :: forc_pbot (:) ! atm bottom level pressure (or reference height) (pa) + real(r8), allocatable :: forc_sols (:) ! atm vis direct beam solar rad onto srf [W/m2] + real(r8), allocatable :: forc_soll (:) ! atm nir direct beam solar rad onto srf [W/m2] + real(r8), allocatable :: forc_solsd (:) ! atm vis diffuse solar rad onto srf [W/m2] + real(r8), allocatable :: forc_solld (:) ! atm nir diffuse solar rad onto srf [W/m2] + real(r8), allocatable :: forc_frl (:) ! atmospheric infrared (longwave) radiation [W/m2] + real(r8), allocatable :: forc_swrad (:) ! atmospheric shortwave radiation [W/m2] + real(r8), allocatable :: forc_hgt_u (:) ! observational height of wind [m] + real(r8), allocatable :: forc_hgt_t (:) ! observational height of temperature [m] + real(r8), allocatable :: forc_hgt_q (:) ! observational height of humidity [m] + real(r8), allocatable :: forc_rhoair(:) ! air density [kg/m3] + real(r8), allocatable :: forc_ozone (:) ! ozone concentration [ppbv] +#ifdef HYPERSPECTRAL + real(r8), allocatable :: forc_solarin(:) ! incident solar radiation [W/m2] +#endif + + real(r8), allocatable :: forc_topo (:) ! topography [m] + + real(r8), allocatable :: forc_hpbl (:) ! atmospheric boundary layer height [m] + real(r8), allocatable :: forc_aerdep(:,:) ! atmospheric aerosol deposition data [kg/m/s] + + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_Forcing + PUBLIC :: deallocate_1D_Forcing + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- +CONTAINS +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_Forcing + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! ------------------------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_Mesh + USE MOD_LandPatch + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + allocate (forc_pco2m (numpatch) ) ! CO2 concentration in atmos. (pascals) + allocate (forc_po2m (numpatch) ) ! O2 concentration in atmos. (pascals) + allocate (forc_us (numpatch) ) ! wind in eastward direction [m/s] + allocate (forc_vs (numpatch) ) ! wind in northward direction [m/s] + allocate (forc_t (numpatch) ) ! temperature at reference height [kelvin] + allocate (forc_q (numpatch) ) ! specific humidity at reference height [kg/kg] + allocate (forc_prc (numpatch) ) ! convective precipitation [mm/s] + allocate (forc_prl (numpatch) ) ! large scale precipitation [mm/s] + allocate (forc_rain (numpatch) ) ! rain [mm/s] + allocate (forc_snow (numpatch) ) ! snow [mm/s] + allocate (forc_psrf (numpatch) ) ! atmospheric pressure at the surface [pa] + allocate (forc_pbot (numpatch) ) ! atm bottom level pressure (or reference height) (pa) +#ifdef HYPERSPECTRAL + allocate (forc_solarin(numpatch) ) ! solar rad onto srf [W/m2] +#endif + allocate (forc_sols (numpatch) ) ! atm vis direct beam solar rad onto srf [W/m2] + allocate (forc_soll (numpatch) ) ! atm nir direct beam solar rad onto srf [W/m2] + allocate (forc_solsd (numpatch) ) ! atm vis diffuse solar rad onto srf [W/m2] + allocate (forc_solld (numpatch) ) ! atm nir diffuse solar rad onto srf [W/m2] + allocate (forc_frl (numpatch) ) ! atmospheric infrared (longwave) radiation [W/m2] + allocate (forc_swrad (numpatch) ) ! atmospheric shortwave radiation [W/m2] + allocate (forc_hgt_u (numpatch) ) ! observational height of wind [m] + allocate (forc_hgt_t (numpatch) ) ! observational height of temperature [m] + allocate (forc_hgt_q (numpatch) ) ! observational height of humidity [m] + allocate (forc_rhoair (numpatch) ) ! air density [kg/m3] + allocate (forc_ozone (numpatch) ) ! ozone concentration [ppbv] + + allocate (forc_hpbl (numpatch) ) ! atmospheric boundary layer height [m] + + IF (DEF_USE_Forcing_Downscaling) THEN + allocate (forc_topo (numpatch)) + ENDIF + + allocate (forc_aerdep(14,numpatch) ) ! atmospheric aerosol deposition data [kg/m/s] + + forc_pco2m = spval + forc_po2m = spval + forc_us = spval + forc_vs = spval + forc_t = spval + forc_q = spval + forc_prc = spval + forc_prl = spval + forc_rain = spval + forc_snow = spval + forc_psrf = spval + forc_pbot = spval +#ifdef HYPERSPECTRAL + forc_solarin = spval +#endif + forc_sols = spval + forc_soll = spval + forc_solsd = spval + forc_solld = spval + forc_frl = spval + forc_swrad = spval + forc_hgt_u = spval + forc_hgt_t = spval + forc_hgt_q = spval + forc_rhoair = spval + forc_ozone = spval + forc_hpbl = spval + IF (allocated(forc_topo)) forc_topo = spval + forc_aerdep = spval + + ENDIF + + ENDIF + + END SUBROUTINE allocate_1D_Forcing + + + SUBROUTINE deallocate_1D_Forcing () + + USE MOD_MPAS_MPI + USE MOD_Mesh + USE MOD_LandPatch + IMPLICIT NONE + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + deallocate ( forc_pco2m ) ! CO2 concentration in atmos. (pascals) + deallocate ( forc_po2m ) ! O2 concentration in atmos. (pascals) + deallocate ( forc_us ) ! wind in eastward direction [m/s] + deallocate ( forc_vs ) ! wind in northward direction [m/s] + deallocate ( forc_t ) ! temperature at reference height [kelvin] + deallocate ( forc_q ) ! specific humidity at reference height [kg/kg] + deallocate ( forc_prc ) ! convective precipitation [mm/s] + deallocate ( forc_prl ) ! large scale precipitation [mm/s] + deallocate ( forc_rain ) ! rain [mm/s] + deallocate ( forc_snow ) ! snow [mm/s] + deallocate ( forc_psrf ) ! atmospheric pressure at the surface [pa] + deallocate ( forc_pbot ) ! atm bottom level pressure (or reference height) (pa) +#ifdef HYPERSPECTRAL + deallocate ( forc_solarin) ! solar rad onto srf [W/m2] +#endif + deallocate ( forc_sols ) ! atm vis direct beam solar rad onto srf [W/m2] + deallocate ( forc_soll ) ! atm nir direct beam solar rad onto srf [W/m2] + deallocate ( forc_solsd ) ! atm vis diffuse solar rad onto srf [W/m2] + deallocate ( forc_solld ) ! atm nir diffuse solar rad onto srf [W/m2] + deallocate ( forc_frl ) ! atmospheric infrared (longwave) radiation [W/m2] + deallocate ( forc_swrad ) ! atmospheric shortwave radiation [W/m2] + deallocate ( forc_hgt_u ) ! observational height of wind [m] + deallocate ( forc_hgt_t ) ! observational height of temperature [m] + deallocate ( forc_hgt_q ) ! observational height of humidity [m] + deallocate ( forc_rhoair ) ! air density [kg/m3] + deallocate ( forc_ozone ) ! ozone concentration [ppbv] + + deallocate ( forc_hpbl ) ! atmospheric boundary layer height [m] + + IF (DEF_USE_Forcing_Downscaling) THEN + deallocate (forc_topo) + ENDIF + + deallocate ( forc_aerdep ) ! atmospheric aerosol deposition data [kg/m/s] + + ENDIF + + ENDIF + + END SUBROUTINE deallocate_1D_Forcing + +END MODULE MOD_Vars_1DForcing +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 new file mode 100644 index 0000000000..183c40177b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DPFTFluxes.F90 @@ -0,0 +1,173 @@ +#include + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +MODULE MOD_Vars_1DPFTFluxes +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Define PFT flux variables +! +! Created by Hua Yuan, 08/2019 +!----------------------------------------------------------------------- + + USE MOD_Precision +#ifdef BGC + USE MOD_BGC_Vars_1DPFTFluxes +#endif + IMPLICIT NONE + SAVE + +!----------------------------------------------------------------------- +! Fluxes +!----------------------------------------------------------------------- + real(r8), allocatable :: taux_p (:) !wind stress: E-W [kg/m/s2] + real(r8), allocatable :: tauy_p (:) !wind stress: N-S [kg/m/s2] + real(r8), allocatable :: fsenl_p (:) !sensible heat from leaves [W/m2] + real(r8), allocatable :: fevpl_p (:) !evaporation+transpiration from leaves [mm/s] + real(r8), allocatable :: etr_p (:) !transpiration rate [mm/s] + real(r8), allocatable :: fseng_p (:) !sensible heat flux from ground [W/m2] + real(r8), allocatable :: fevpg_p (:) !evaporation heat flux from ground [mm/s] + real(r8), allocatable :: parsun_p (:) !solar absorbed by sunlit vegetation [W/m2] + real(r8), allocatable :: parsha_p (:) !solar absorbed by shaded vegetation [W/m2] + real(r8), allocatable :: sabvsun_p(:) !solar absorbed by sunlit vegetation [W/m2] + real(r8), allocatable :: sabvsha_p(:) !solar absorbed by shaded vegetation [W/m2] + real(r8), allocatable :: qintr_p (:) !interception (mm h2o/s) + real(r8), allocatable :: qintr_rain_p(:) !rainfall interception (mm h2o/s) + real(r8), allocatable :: qintr_snow_p(:) !snowfall interception (mm h2o/s) + real(r8), allocatable :: assim_p (:) !canopy assimilation rate (mol m-2 s-1) + real(r8), allocatable :: respc_p (:) !canopy respiration (mol m-2 s-1) + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_PFTFluxes + PUBLIC :: deallocate_1D_PFTFluxes + PUBLIC :: set_1D_PFTFluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_PFTFluxes + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandPFT + IMPLICIT NONE + + IF (.true.) THEN + IF (numpft > 0) THEN + + allocate (taux_p (numpft)) ; taux_p (:) = spval !wind stress: E-W [kg/m/s2] + allocate (tauy_p (numpft)) ; tauy_p (:) = spval !wind stress: N-S [kg/m/s2] + allocate (fsenl_p (numpft)) ; fsenl_p (:) = spval !sensible heat from leaves [W/m2] + allocate (fevpl_p (numpft)) ; fevpl_p (:) = spval !evaporation+transpiration from leaves [mm/s] + allocate (etr_p (numpft)) ; etr_p (:) = spval !transpiration rate [mm/s] + allocate (fseng_p (numpft)) ; fseng_p (:) = spval !sensible heat flux from ground [W/m2] + allocate (fevpg_p (numpft)) ; fevpg_p (:) = spval !evaporation heat flux from ground [mm/s] + allocate (parsun_p (numpft)) ; parsun_p (:) = spval !solar absorbed by sunlit vegetation [W/m2] + allocate (parsha_p (numpft)) ; parsha_p (:) = spval !solar absorbed by shaded vegetation [W/m2] + allocate (sabvsun_p (numpft)) ; sabvsun_p (:) = spval !solar absorbed by sunlit vegetation [W/m2] + allocate (sabvsha_p (numpft)) ; sabvsha_p (:) = spval !solar absorbed by shaded vegetation [W/m2] + allocate (qintr_p (numpft)) ; qintr_p (:) = spval !interception (mm h2o/s) + allocate (qintr_rain_p (numpft)) ; qintr_rain_p (:) = spval !rainfall interception (mm h2o/s) + allocate (qintr_snow_p (numpft)) ; qintr_snow_p (:) = spval !snowfall interception (mm h2o/s) + allocate (assim_p (numpft)) ; assim_p (:) = spval !canopy assimilation rate (mol m-2 s-1) + allocate (respc_p (numpft)) ; respc_p (:) = spval !canopy respiration (mol m-2 s-1) + + ENDIF + ENDIF + +#ifdef BGC + CALL allocate_1D_BGCPFTFluxes +#endif + + END SUBROUTINE allocate_1D_PFTFluxes + + SUBROUTINE deallocate_1D_PFTFluxes + ! ------------------------------------------------------------------- + ! deallocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_LandPFT + + IF (.true.) THEN + IF (numpft > 0) THEN + + deallocate (taux_p ) + deallocate (tauy_p ) + deallocate (fsenl_p ) + deallocate (fevpl_p ) + deallocate (etr_p ) + deallocate (fseng_p ) + deallocate (fevpg_p ) + deallocate (parsun_p ) + deallocate (parsha_p ) + deallocate (sabvsun_p ) + deallocate (sabvsha_p ) + deallocate (qintr_p ) + deallocate (qintr_rain_p ) + deallocate (qintr_snow_p ) + deallocate (assim_p ) + deallocate (respc_p ) + + ENDIF + ENDIF + +#ifdef BGC + CALL deallocate_1D_BGCPFTFluxes +#endif + + END SUBROUTINE deallocate_1D_PFTFluxes + + SUBROUTINE set_1D_PFTFluxes(Values, Nan) + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandPFT + IMPLICIT NONE + + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan + + IF (.true.) THEN + IF (numpft > 0) THEN + + taux_p (:) = Values !wind stress: E-W [kg/m/s2] + tauy_p (:) = Values !wind stress: N-S [kg/m/s2] + fsenl_p (:) = Values !sensible heat from leaves [W/m2] + fevpl_p (:) = Values !evaporation+transpiration from leaves [mm/s] + etr_p (:) = Values !transpiration rate [mm/s] + fseng_p (:) = Values !sensible heat flux from ground [W/m2] + fevpg_p (:) = Values !evaporation heat flux from ground [mm/s] + parsun_p (:) = Values !solar absorbed by sunlit vegetation [W/m2] + parsha_p (:) = Values !solar absorbed by shaded vegetation [W/m2] + sabvsun_p (:) = Values !solar absorbed by sunlit vegetation [W/m2] + sabvsha_p (:) = Values !solar absorbed by shaded vegetation [W/m2] + qintr_p (:) = Values !interception (mm h2o/s) + qintr_rain_p(:) = Values !rainfall interception (mm h2o/s) + qintr_snow_p(:) = Values !snowfall interception (mm h2o/s) + assim_p (:) = Values !canopy assimilation rate (mol m-2 s-1) + respc_p (:) = Values !canopy respiration (mol m-2 s-1) + + ENDIF + ENDIF + +#ifdef BGC + CALL set_1D_BGCPFTFluxes (Values, Nan) +#endif + + END SUBROUTINE set_1D_PFTFluxes + +END MODULE MOD_Vars_1DPFTFluxes + +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_Global.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_Global.F90 new file mode 100644 index 0000000000..473bebe5c8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_Global.F90 @@ -0,0 +1,168 @@ +#include + +MODULE MOD_Vars_Global +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Define some global variables +! +! !REVISIONS: +! Hua Yuan, 08/2019: initial version partly adapted from CoLM2014 +! TODO ... +! +!----------------------------------------------------------------------- +! !USES: + USE MOD_Precision + USE MOD_Namelist + IMPLICIT NONE + SAVE + +#ifdef LULC_USGS + ! GLCC USGS number of land cover category + integer, parameter :: N_land_classification = 24 + ! GLCC USGS land cover named index (could be added IF needed) + integer, parameter :: URBAN = 1 + integer, parameter :: WATERBODY = 16 + integer, parameter :: WETLAND = 17 + integer, parameter :: CROPLAND = 7 + integer, parameter :: GLACIERS = 24 +#else + ! MODIS IGBP number of land cover category + integer, parameter :: N_land_classification = 17 + ! MODIS IGBP land cover named index (could be added IF needed) + integer, parameter :: WETLAND = 11 + integer, parameter :: CROPLAND = 12 + integer, parameter :: URBAN = 13 + integer, parameter :: GLACIERS = 15 + integer, parameter :: WATERBODY = 17 +#endif + + ! number of plant functional types +#ifndef CROP + integer, parameter :: N_PFT = 16 + integer, parameter :: N_CFT = 0 +#else + integer, parameter :: N_PFT = 15 + integer, parameter :: N_CFT = 64 +#endif + + ! urban type number + integer :: N_URB + + ! vertical layer number + integer, parameter :: maxsnl = -5 + integer, parameter :: nl_soil = 10 + integer, parameter :: nl_soil_full = 15 + + integer, parameter :: nl_lake = 10 + integer, parameter :: nl_roof = 10 + integer, parameter :: nl_wall = 10 + integer, parameter :: nvegwcs = 4 ! number of vegetation water potential nodes + integer, parameter :: nwl = 211 ! number of hyperspectral wavelengths + ! used for downscaling + integer, parameter :: num_slope_type = 4 + integer, parameter :: num_aspect_type = 9 + integer, parameter :: num_zenith = 101 + integer, parameter :: num_zenith_parameter = 3 + integer, parameter :: num_azimuth = 16 + + ! bgc variables + integer, parameter :: ndecomp_pools = 7 + integer, parameter :: ndecomp_transitions = 10 + integer, parameter :: npcropmin = 17 + real(r8),parameter :: zmin_bedrock = 0.4 + integer, parameter :: nbedrock = 10 + integer, parameter :: ndecomp_pools_vr = ndecomp_pools * nl_soil + + ! crop index + integer, parameter :: noveg = 0 + integer, parameter :: nbrdlf_evr_shrub = 9 + integer, parameter :: nbrdlf_dcd_brl_shrub = 11 + integer, parameter :: nc3crop = 15 + integer, parameter :: nc3irrig = 16 + integer, parameter :: ntmp_corn = 17 ! temperate_corn + integer, parameter :: nirrig_tmp_corn = 18 ! irrigated temperate corn + integer, parameter :: nswheat = 19 ! spring wheat + integer, parameter :: nirrig_swheat = 20 ! irrigated spring wheat + integer, parameter :: nwwheat = 21 ! winter wheat + integer, parameter :: nirrig_wwheat = 22 ! irrigated winter wheat + integer, parameter :: ntmp_soybean = 23 ! temperate soybean + integer, parameter :: nirrig_tmp_soybean = 24 ! irrigated temperate soybean + integer, parameter :: ncotton = 41 ! cotton + integer, parameter :: nirrig_cotton = 42 ! irrigated cotton + integer, parameter :: nrice = 61 ! rice + integer, parameter :: nirrig_rice = 62 ! irrigated rice + integer, parameter :: nsugarcane = 67 ! sugarcane + integer, parameter :: nirrig_sugarcane = 68 ! irrigated sugarcane + integer, parameter :: nmiscanthus = 71 ! miscanthus + integer, parameter :: nirrig_miscanthus = 72 ! irrigated miscanthus + integer, parameter :: nswitchgrass = 73 ! switchgrass + integer, parameter :: nirrig_switchgrass = 74 ! irrigated switchgrass + integer, parameter :: ntrp_corn = 75 ! tropical corn + integer, parameter :: nirrig_trp_corn = 76 ! irrigated tropical corn + integer, parameter :: ntrp_soybean = 77 ! tropical soybean + integer, parameter :: nirrig_trp_soybean = 78 ! irrigated tropical soybean + + real(r8) :: z_soi (1:nl_soil) ! node depth [m] + real(r8) :: dz_soi(1:nl_soil) ! soil node thickness [m] + real(r8) :: zi_soi(1:nl_soil) ! interface level below a zsoi level [m] + + real(r8), parameter :: spval = -1.e36_r8 ! missing value + integer , parameter :: spval_i4 = -9999 ! missing value + real(r8), parameter :: PI = 4*atan(1.) ! pi value + real(r8), parameter :: deg2rad = 1.745329251994330e-2_r8 ! degree to radius + + integer , parameter :: irrig_start_time = 21600 ! local time of irrigation start + real(r8), parameter :: irrig_max_depth = 1._r8 ! max irrigation depth + real(r8), parameter :: irrig_threshold_fraction = 1._r8 ! irrigation thershold + real(r8), parameter :: irrig_supply_fraction = 1._r8 ! irrigation supply thershold + real(r8), parameter :: irrig_min_cphase = 1._r8 ! crop phenology when begin irrigation + real(r8), parameter :: irrig_max_cphase = 4._r8 ! crop phenology when end irrigation + integer , parameter :: irrig_time_per_day = 14400 ! irrigation last time + integer , parameter :: irrig_method_drip = 1 ! irrigation method + integer , parameter :: irrig_method_sprinkler = 2 ! irrigation method + integer , parameter :: irrig_method_flood = 3 ! irrigation method + integer , parameter :: irrig_method_paddy = 4 ! irrigation method + real(r8), parameter :: pondmxc = 100.0 ! ponding depth (mm) +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: Init_GlobalVars + +CONTAINS + + SUBROUTINE Init_GlobalVars + + IMPLICIT NONE + + integer :: nsl + + ! node depths of each soil layer + DO nsl = 1, nl_soil + z_soi(nsl) = 0.025*(exp(0.5*(nsl-0.5))-1.) + ENDDO + + ! thickness between two soil layer interfaces + dz_soi(1) = 0.5*(z_soi(1)+z_soi(2)) !=zi_soi(1) + dz_soi(nl_soil) = z_soi(nl_soil)-z_soi(nl_soil-1) + DO nsl = 2, nl_soil-1 + dz_soi(nsl) = 0.5*(z_soi(nsl+1)-z_soi(nsl-1)) + ENDDO + + ! interface depths of soil layers + zi_soi(1) = dz_soi(1) + DO nsl = 2, nl_soil + zi_soi(nsl) = zi_soi(nsl-1) + dz_soi(nsl) + ENDDO + + ! set urban class number + IF (DEF_URBAN_type_scheme == 1) THEN + N_URB = 3 + ELSE IF(DEF_URBAN_type_scheme == 2) THEN + N_URB = 10 + ENDIF + + !ndecomp_pools_vr = ndecomp_pools * nl_soil + + END SUBROUTINE Init_GlobalVars + +END MODULE MOD_Vars_Global +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 new file mode 100644 index 0000000000..7bd3609e3b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90 @@ -0,0 +1,1150 @@ +#include + +!----------------------------------------------------------------------- +! Created by Yongjiu Dai, 03/2014 +!----------------------------------------------------------------------- + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +MODULE MOD_Vars_PFTimeInvariants +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Define PFT time invariables +! +! Added by Hua Yuan, 08/2019 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + IMPLICIT NONE + SAVE + + ! for LULC_IGBP_PFT and LULC_IGBP_PC + integer , allocatable :: pftclass (:) !PFT type + real(r8), allocatable :: pftfrac (:) !PFT fractional cover + real(r8), allocatable :: htop_p (:) !canopy top height [m] + real(r8), allocatable :: hbot_p (:) !canopy bottom height [m] +#ifdef CROP + real(r8), allocatable :: cropfrac (:) !Crop fractional cover +#endif + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_PFTimeInvariants + PUBLIC :: READ_PFTimeInvariants + PUBLIC :: WRITE_PFTimeInvariants + PUBLIC :: deallocate_PFTimeInvariants +#ifdef RangeCheck + PUBLIC :: check_PFTimeInvariants +#endif + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_PFTimeInvariants + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + + USE MOD_MPAS_MPI + USE MOD_LandPatch, only: numpatch + USE MOD_LandPFT, only: numpft + USE MOD_Precision + IMPLICIT NONE + + IF (.true.) THEN + IF (numpft > 0) THEN + allocate (pftclass (numpft)) + allocate (pftfrac (numpft)) + allocate (htop_p (numpft)) + allocate (hbot_p (numpft)) + ENDIF + +#ifdef CROP + IF (numpatch > 0) THEN + allocate (cropfrac (numpatch)) + ENDIF +#endif + ENDIF + + END SUBROUTINE allocate_PFTimeInvariants + + SUBROUTINE READ_PFTimeInvariants (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandPatch + USE MOD_LandPFT + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + IF (numpft > 0) THEN + CALL ncio_read_vector (file_restart, 'pftclass', landpft, pftclass) ! + CALL ncio_read_vector (file_restart, 'pftfrac ', landpft, pftfrac ) ! + CALL ncio_read_vector (file_restart, 'htop_p ', landpft, htop_p ) ! + CALL ncio_read_vector (file_restart, 'hbot_p ', landpft, hbot_p ) ! + ENDIF +#ifdef CROP + IF (numpatch > 0) CALL ncio_read_vector (file_restart, 'cropfrac ', landpatch, cropfrac) ! +#endif + + END SUBROUTINE READ_PFTimeInvariants + + SUBROUTINE WRITE_PFTimeInvariants (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandPFT + USE MOD_LandPatch + USE MOD_Namelist + USE MOD_Vars_Global + IMPLICIT NONE + + ! Local variables + character(len=*), intent(in) :: file_restart + integer :: compress + + compress = DEF_REST_CompressLevel + + IF (numpft > 0) THEN + CALL ncio_create_file_vector (file_restart, landpft) + CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') + + CALL ncio_write_vector (file_restart, 'pftclass', 'pft', landpft, pftclass, compress) ! + CALL ncio_write_vector (file_restart, 'pftfrac ', 'pft', landpft, pftfrac , compress) ! + CALL ncio_write_vector (file_restart, 'htop_p ', 'pft', landpft, htop_p , compress) ! + CALL ncio_write_vector (file_restart, 'hbot_p ', 'pft', landpft, hbot_p , compress) ! + ENDIF + +#ifdef CROP + IF (numpatch > 0) THEN + IF (numpft <= 0) CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_write_vector (file_restart, 'cropfrac', 'patch', landpatch, cropfrac, compress) ! + ENDIF +#endif + + END SUBROUTINE WRITE_PFTimeInvariants + + SUBROUTINE deallocate_PFTimeInvariants + ! ------------------------------------------------------------------- + ! Deallocates memory for CoLM PFT 1d [numpft] variables + ! ------------------------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_LandPFT + + IF (.true.) THEN + IF (numpft > 0) THEN + deallocate (pftclass) + deallocate (pftfrac ) + deallocate (htop_p ) + deallocate (hbot_p ) + ENDIF +#ifdef CROP + IF (numpatch > 0) deallocate (cropfrac) +#endif + ENDIF + + END SUBROUTINE deallocate_PFTimeInvariants + +#ifdef RangeCheck + SUBROUTINE check_PFTimeInvariants () + + USE MOD_RangeCheck + IMPLICIT NONE + + CALL check_vector_data ('pftfrac', pftfrac) ! + CALL check_vector_data ('htop_p ', htop_p ) ! + CALL check_vector_data ('hbot_p ', hbot_p ) ! +#ifdef CROP + CALL check_vector_data ('cropfrac', cropfrac) ! +#endif + + END SUBROUTINE check_PFTimeInvariants +#endif + +END MODULE MOD_Vars_PFTimeInvariants +#endif + +MODULE MOD_Vars_TimeInvariants +! ------------------------------- +! Created by Yongjiu Dai, 03/2014 +! ------------------------------- + + USE MOD_Precision +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeInvariants +#endif +#ifdef BGC + USE MOD_BGC_Vars_TimeInvariants +#endif +#ifdef URBAN_MODEL + USE MOD_Urban_Vars_TimeInvariants +#endif + IMPLICIT NONE + SAVE + +! ----------------------------------------------------------------- +! surface classification and soil information + integer, allocatable :: patchclass (:) !index of land cover type of the patches at the fraction > 0 + integer, allocatable :: patchtype (:) !land patch type + logical, allocatable :: patchmask (:) !patch mask + + real(r8), allocatable :: patchlatr (:) !latitude in radians + real(r8), allocatable :: patchlonr (:) !longitude in radians + + real(r8), allocatable :: lakedepth (:) !lake depth + real(r8), allocatable :: dz_lake (:,:) !new lake scheme + + real(r8), allocatable :: soil_s_v_alb (:) !albedo of visible of the saturated soil + real(r8), allocatable :: soil_d_v_alb (:) !albedo of visible of the dry soil + real(r8), allocatable :: soil_s_n_alb (:) !albedo of near infrared of the saturated soil + real(r8), allocatable :: soil_d_n_alb (:) !albedo of near infrared of the dry soil +#ifdef HYPERSPECTRAL + real(r8), allocatable :: soil_alb (:,:) ! hyper spectral soil albedo. (numpatch, nwl) +#endif + real(r8), allocatable :: vf_quartz (:,:) !volumetric fraction of quartz within mineral soil + real(r8), allocatable :: vf_gravels (:,:) !volumetric fraction of gravels + real(r8), allocatable :: vf_om (:,:) !volumetric fraction of organic matter + real(r8), allocatable :: vf_sand (:,:) !volumetric fraction of sand + real(r8), allocatable :: vf_clay (:,:) !volumetric fraction of clay + real(r8), allocatable :: wf_gravels (:,:) !gravimetric fraction of gravels + real(r8), allocatable :: wf_sand (:,:) !gravimetric fraction of sand + real(r8), allocatable :: wf_clay (:,:) !gravimetric fraction of clay + real(r8), allocatable :: wf_om (:,:) !gravimetric fraction of om +#ifdef DataAssimilation + real(r8), allocatable :: wf_silt (:,:) !gravimetric fraction of silt +#endif + real(r8), allocatable :: OM_density (:,:) !OM density (kg/m3) + real(r8), allocatable :: BD_all (:,:) !bulk density of soil (GRAVELS + ORGANIC MATTER + Mineral Soils,kg/m3) + + real(r8), allocatable :: wfc (:,:) !field capacity + real(r8), allocatable :: porsl (:,:) !fraction of soil that is voids [-] + real(r8), allocatable :: psi0 (:,:) !minimum soil suction [mm] (NOTE: "-" valued) + real(r8), allocatable :: bsw (:,:) !clapp and hornberger "b" parameter [-] + real(r8), allocatable :: theta_r (:,:) !residual moisture content [-] + real(r8), allocatable :: BVIC (:) !b parameter in Fraction of saturated soil in a grid calculated by VIC +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), allocatable :: alpha_vgm (:,:) !a parameter corresponding approximately to the inverse of the air-entry value + real(r8), allocatable :: L_vgm (:,:) !pore-connectivity parameter [dimensionless] + real(r8), allocatable :: n_vgm (:,:) !a shape parameter [dimensionless] + real(r8), allocatable :: sc_vgm (:,:) !saturation at the air entry value in the classical vanGenuchten model [-] + real(r8), allocatable :: fc_vgm (:,:) !a scaling factor by using air entry value in the Mualem model [-] +#endif + + integer, allocatable :: soiltext (:) !USDA soil texture class + + real(r8), allocatable :: fsatmax (:) !maximum saturated area fraction [-] + real(r8), allocatable :: fsatdcf (:) !decay factor in calculation of saturated area fraction [1/m] + + real(r8), allocatable :: topoweti (:) !topographic wetness index [log m] + real(r8), allocatable :: alp_twi (:) !alpha in three parameter gamma distribution of twi + real(r8), allocatable :: chi_twi (:) !chi in three parameter gamma distribution of twi + real(r8), allocatable :: mu_twi (:) !mu in three parameter gamma distribution of twi + + real(r8), allocatable :: vic_b_infilt (:) + real(r8), allocatable :: vic_Dsmax (:) + real(r8), allocatable :: vic_Ds (:) + real(r8), allocatable :: vic_Ws (:) + real(r8), allocatable :: vic_c (:) + + real(r8), allocatable :: hksati (:,:) !hydraulic conductivity at saturation [mm h2o/s] + real(r8), allocatable :: csol (:,:) !heat capacity of soil solids [J/(m3 K)] + real(r8), allocatable :: k_solids (:,:) !thermal conductivity of soil solids [W/m-K] + real(r8), allocatable :: dksatu (:,:) !thermal conductivity of saturated soil [W/m-K] + real(r8), allocatable :: dksatf (:,:) !thermal conductivity of saturated frozen soil [W/m-K] + real(r8), allocatable :: dkdry (:,:) !thermal conductivity for dry soil [W/(m-K)] + real(r8), allocatable :: BA_alpha (:,:) !alpha in Balland and Arp(2005) thermal conductivity scheme + real(r8), allocatable :: BA_beta (:,:) !beta in Balland and Arp(2005) thermal conductivity scheme + real(r8), allocatable :: htop (:) !canopy top height [m] + real(r8), allocatable :: hbot (:) !canopy bottom height [m] + + real(r8), allocatable :: dbedrock (:) !depth to bedrock + integer , allocatable :: ibedrock (:) !bedrock level + + real(r8), allocatable :: elvmean (:) !elevation above sea level [m] + real(r8), allocatable :: elvstd (:) !standard deviation of elevation [m] + real(r8), allocatable :: slpratio (:) !slope ratio [-] + + real(r8) :: zlnd !roughness length for soil [m] + real(r8) :: zsno !roughness length for snow [m] + real(r8) :: csoilc !drag coefficient for soil under canopy [-] + real(r8) :: dewmx !maximum dew + ! 'wtfact' is updated to gridded 'fsatmax' data. + ! real(r8) :: wtfact !fraction of model area with high water table + real(r8) :: capr !tuning factor to turn first layer T into surface T + real(r8) :: cnfac !Crank Nicholson factor between 0 and 1 + real(r8) :: ssi !irreducible water saturation of snow + real(r8) :: wimp !water impermeable IF porosity less than wimp + real(r8) :: pondmx !ponding depth (mm) + real(r8) :: smpmax !wilting point potential in mm + real(r8) :: smpmin !restriction for min of soil poten. (mm) + real(r8) :: smpmax_hr !wilting point potential in mm for heterotrophic respiration + real(r8) :: smpmin_hr !restriction for min of soil poten for heterotrophic respiration. (mm) + real(r8) :: trsmx0 !max transpiration for moist soil+100% veg. [mm/s] + real(r8) :: tcrit !critical temp. to determine rain or snow + real(r8) :: wetwatmax !maximum wetland water (mm) + + ! Used for downscaling + real(r8), allocatable :: svf_patches (:) !sky view factor + real(r8), allocatable :: cur_patches (:) !curvature + real(r8), allocatable :: sf_lut_patches (:,:,:) !look up table of shadow factor of a patch + real(r8), allocatable :: sf_curve_patches(:,:,:) !curve parameters of shadow factor of a patch + real(r8), allocatable :: asp_type_patches (:,:) !topographic aspect of each character of one patch + real(r8), allocatable :: slp_type_patches (:,:) !topographic slope of each character of one patch + real(r8), allocatable :: area_type_patches (:,:) !area percentage of each character of one patch + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_TimeInvariants + PUBLIC :: deallocate_TimeInvariants + PUBLIC :: READ_TimeInvariants + PUBLIC :: WRITE_TimeInvariants + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_TimeInvariants () + ! ------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + ! ------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_MPAS_MPI + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + allocate (patchclass (numpatch)) + allocate (patchtype (numpatch)) + allocate (patchmask (numpatch)) + + allocate (patchlonr (numpatch)) + allocate (patchlatr (numpatch)) + + allocate (lakedepth (numpatch)) + allocate (dz_lake (nl_lake,numpatch)) + + allocate (soil_s_v_alb (numpatch)) + allocate (soil_d_v_alb (numpatch)) + allocate (soil_s_n_alb (numpatch)) + allocate (soil_d_n_alb (numpatch)) +#ifdef HYPERSPECTRAL + allocate (soil_alb (nwl, numpatch)) +#endif + + allocate (vf_quartz (nl_soil,numpatch)) + allocate (vf_gravels (nl_soil,numpatch)) + allocate (vf_om (nl_soil,numpatch)) + allocate (vf_sand (nl_soil,numpatch)) + allocate (vf_clay (nl_soil,numpatch)) + allocate (wf_gravels (nl_soil,numpatch)) + allocate (wf_sand (nl_soil,numpatch)) + allocate (wf_clay (nl_soil,numpatch)) + allocate (wf_om (nl_soil,numpatch)) +#ifdef DataAssimilation + allocate (wf_silt (nl_soil,numpatch)) +#endif + allocate (OM_density (nl_soil,numpatch)) + allocate (BD_all (nl_soil,numpatch)) + allocate (wfc (nl_soil,numpatch)) + allocate (porsl (nl_soil,numpatch)) + allocate (psi0 (nl_soil,numpatch)) + allocate (bsw (nl_soil,numpatch)) + allocate (theta_r (nl_soil,numpatch)) + allocate (BVIC (numpatch)) + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + allocate (alpha_vgm (nl_soil,numpatch)) + allocate (L_vgm (nl_soil,numpatch)) + allocate (n_vgm (nl_soil,numpatch)) + allocate (sc_vgm (nl_soil,numpatch)) + allocate (fc_vgm (nl_soil,numpatch)) +#endif + allocate (soiltext (numpatch)) + + allocate (fsatmax (numpatch)) + allocate (fsatdcf (numpatch)) + allocate (topoweti (numpatch)) + allocate (alp_twi (numpatch)) + allocate (chi_twi (numpatch)) + allocate (mu_twi (numpatch)) + + allocate (vic_b_infilt (numpatch)) + allocate (vic_Dsmax (numpatch)) + allocate (vic_Ds (numpatch)) + allocate (vic_Ws (numpatch)) + allocate (vic_c (numpatch)) + + allocate (hksati (nl_soil,numpatch)) + allocate (csol (nl_soil,numpatch)) + allocate (k_solids (nl_soil,numpatch)) + allocate (dksatu (nl_soil,numpatch)) + allocate (dksatf (nl_soil,numpatch)) + allocate (dkdry (nl_soil,numpatch)) + allocate (BA_alpha (nl_soil,numpatch)) + allocate (BA_beta (nl_soil,numpatch)) + allocate (htop (numpatch)) + allocate (hbot (numpatch)) + allocate (dbedrock (numpatch)) + allocate (ibedrock (numpatch)) + allocate (elvmean (numpatch)) + allocate (elvstd (numpatch)) + allocate (slpratio (numpatch)) + + IF (DEF_USE_Forcing_Downscaling) THEN + ! Used for downscaling + allocate (svf_patches (numpatch)) + allocate (asp_type_patches (num_slope_type,numpatch)) + allocate (slp_type_patches (num_slope_type,numpatch)) + allocate (area_type_patches (num_slope_type,numpatch)) + allocate (cur_patches (numpatch)) +#ifdef SinglePoint + allocate (sf_lut_patches (num_azimuth,num_zenith,numpatch)) +#else + allocate (sf_curve_patches (num_azimuth,num_zenith_parameter,numpatch)) +#endif + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + ! Used for downscaling + allocate (asp_type_patches (num_aspect_type,numpatch)) + allocate (slp_type_patches (num_aspect_type,numpatch)) + allocate (cur_patches (numpatch)) + ENDIF + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL allocate_PFTimeInvariants +#endif + +#ifdef BGC + CALL allocate_BGCTimeInvariants +#endif + +#ifdef URBAN_MODEL + CALL allocate_UrbanTimeInvariants +#endif + + END SUBROUTINE allocate_TimeInvariants + + !--------------------------------------- + SUBROUTINE READ_TimeInvariants (lc_year, casename, dir_restart) + + !==================================================================== + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !==================================================================== + + USE MOD_Namelist + USE MOD_MPAS_MPI + USE MOD_NetCDFVector + USE MOD_NetCDFSerial +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + USE MOD_Const_LC, only: patchtypes + + IMPLICIT NONE + + integer , intent(in) :: lc_year + character(len=*), intent(in) :: casename + character(len=*), intent(in) :: dir_restart + + ! Local variables + character(len=256) :: file_restart, cyear, lndname + + write(cyear,'(i4.4)') lc_year + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' // '_lc' // trim(cyear) // '.nc' + +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif + + CALL ncio_read_vector (file_restart, 'patchclass', landpatch, patchclass) ! + CALL ncio_read_vector (file_restart, 'patchtype' , landpatch, patchtype ) ! + CALL ncio_read_vector (file_restart, 'patchmask' , landpatch, patchmask ) ! + + CALL ncio_read_vector (file_restart, 'patchlonr' , landpatch, patchlonr ) ! + CALL ncio_read_vector (file_restart, 'patchlatr' , landpatch, patchlatr ) ! + + CALL ncio_read_vector (file_restart, 'lakedepth', landpatch, lakedepth) ! + CALL ncio_read_vector (file_restart, 'dz_lake' , nl_lake, landpatch, dz_lake) ! + + CALL ncio_read_vector (file_restart, 'soil_s_v_alb', landpatch, soil_s_v_alb) ! albedo of visible of the saturated soil + CALL ncio_read_vector (file_restart, 'soil_d_v_alb', landpatch, soil_d_v_alb) ! albedo of visible of the dry soil + CALL ncio_read_vector (file_restart, 'soil_s_n_alb', landpatch, soil_s_n_alb) ! albedo of near infrared of the saturated soil + CALL ncio_read_vector (file_restart, 'soil_d_n_alb', landpatch, soil_d_n_alb) ! albedo of near infrared of the dry soil +#ifdef HYPERSPECTRAL + CALL ncio_read_vector (file_restart, 'soil_alb' , nwl, landpatch, soil_alb ) ! hyper spectral soil albedo. (numpatch, nwl) +#endif + + CALL ncio_read_vector (file_restart, 'vf_quartz ', nl_soil, landpatch, vf_quartz ) ! volumetric fraction of quartz within mineral soil + CALL ncio_read_vector (file_restart, 'vf_gravels', nl_soil, landpatch, vf_gravels) ! volumetric fraction of gravels + CALL ncio_read_vector (file_restart, 'vf_om ', nl_soil, landpatch, vf_om ) ! volumetric fraction of organic matter + CALL ncio_read_vector (file_restart, 'vf_sand ', nl_soil, landpatch, vf_sand ) ! volumetric fraction of sand + CALL ncio_read_vector (file_restart, 'vf_clay ', nl_soil, landpatch, vf_clay ,defval = 0.1 ) ! volumetric fraction of clay + CALL ncio_read_vector (file_restart, 'wf_gravels', nl_soil, landpatch, wf_gravels) ! gravimetric fraction of gravels + CALL ncio_read_vector (file_restart, 'wf_sand ', nl_soil, landpatch, wf_sand ) ! gravimetric fraction of sand + CALL ncio_read_vector (file_restart, 'wf_clay ', nl_soil, landpatch, wf_clay ) ! gravimetric fraction of clay + CALL ncio_read_vector (file_restart, 'wf_om ', nl_soil, landpatch, wf_om ) ! gravimetric fraction of om + CALL ncio_read_vector (file_restart, 'OM_density', nl_soil, landpatch, OM_density) ! OM density + CALL ncio_read_vector (file_restart, 'BD_all ', nl_soil, landpatch, BD_all ) ! bulk density of soil + CALL ncio_read_vector (file_restart, 'wfc ', nl_soil, landpatch, wfc ) ! field capacity + CALL ncio_read_vector (file_restart, 'porsl ' , nl_soil, landpatch, porsl ) ! fraction of soil that is voids [-] + CALL ncio_read_vector (file_restart, 'psi0 ' , nl_soil, landpatch, psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) + CALL ncio_read_vector (file_restart, 'bsw ' , nl_soil, landpatch, bsw ) ! clapp and hornberger "b" parameter [-] + CALL ncio_read_vector (file_restart, 'theta_r ' , nl_soil, landpatch, theta_r ) ! residual moisture content [-] + CALL ncio_read_vector (file_restart, 'BVIC ' , landpatch, BVIC ) ! b parameter in Fraction of saturated soil in a grid calculated by VIC +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL ncio_read_vector (file_restart, 'alpha_vgm' , nl_soil, landpatch, alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value + CALL ncio_read_vector (file_restart, 'L_vgm ' , nl_soil, landpatch, L_vgm ) ! pore-connectivity parameter [dimensionless] + CALL ncio_read_vector (file_restart, 'n_vgm ' , nl_soil, landpatch, n_vgm ) ! a shape parameter [dimensionless] + CALL ncio_read_vector (file_restart, 'sc_vgm ' , nl_soil, landpatch, sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] + CALL ncio_read_vector (file_restart, 'fc_vgm ' , nl_soil, landpatch, fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] +#endif +#ifdef DataAssimilation + IF (numpatch > 0 .and. .true.) wf_silt = 1.0_r8 - wf_gravels - wf_sand - wf_clay - wf_om +#endif + + CALL ncio_read_vector (file_restart, 'soiltext', landpatch, soiltext, defval = 0 ) + + IF (DEF_Runoff_SCHEME == 0) THEN + CALL ncio_read_vector (file_restart, 'topoweti', landpatch, topoweti, defval = 9.27 ) + CALL ncio_read_vector (file_restart, 'fsatmax ', landpatch, fsatmax , defval = 0.38 ) + CALL ncio_read_vector (file_restart, 'fsatdcf ', landpatch, fsatdcf , defval = 0.55 ) + CALL ncio_read_vector (file_restart, 'alp_twi ', landpatch, alp_twi , defval = 1.34 ) + CALL ncio_read_vector (file_restart, 'chi_twi ', landpatch, chi_twi , defval = 1.61 ) + CALL ncio_read_vector (file_restart, 'mu_twi ', landpatch, mu_twi , defval = 6.95 ) + ENDIF + + CALL ncio_read_vector (file_restart, 'vic_b_infilt', landpatch, vic_b_infilt) + CALL ncio_read_vector (file_restart, 'vic_Dsmax' , landpatch, vic_Dsmax ) + CALL ncio_read_vector (file_restart, 'vic_Ds' , landpatch, vic_Ds ) + CALL ncio_read_vector (file_restart, 'vic_Ws' , landpatch, vic_Ws ) + CALL ncio_read_vector (file_restart, 'vic_c' , landpatch, vic_c ) + + CALL ncio_read_vector (file_restart, 'hksati ' , nl_soil, landpatch, hksati ) ! hydraulic conductivity at saturation [mm h2o/s] + CALL ncio_read_vector (file_restart, 'csol ' , nl_soil, landpatch, csol ) ! heat capacity of soil solids [J/(m3 K)] + CALL ncio_read_vector (file_restart, 'k_solids', nl_soil, landpatch, k_solids) ! thermal conductivity of soil solids [W/m-K] + CALL ncio_read_vector (file_restart, 'dksatu ' , nl_soil, landpatch, dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] + CALL ncio_read_vector (file_restart, 'dksatf ' , nl_soil, landpatch, dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] + CALL ncio_read_vector (file_restart, 'dkdry ' , nl_soil, landpatch, dkdry ) ! thermal conductivity for dry soil [W/(m-K)] + CALL ncio_read_vector (file_restart, 'BA_alpha', nl_soil, landpatch, BA_alpha) ! alpha in Balland and Arp(2005) thermal conductivity scheme + CALL ncio_read_vector (file_restart, 'BA_beta' , nl_soil, landpatch, BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme + CALL ncio_read_vector (file_restart, 'htop' , landpatch, htop) ! + CALL ncio_read_vector (file_restart, 'hbot' , landpatch, hbot) ! + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_read_vector (file_restart, 'debdrock' , landpatch, dbedrock) ! + CALL ncio_read_vector (file_restart, 'ibedrock' , landpatch, ibedrock) ! + ENDIF + + CALL ncio_read_vector (file_restart, 'elvmean ', landpatch, elvmean ) ! + CALL ncio_read_vector (file_restart, 'elvstd ', landpatch, elvstd ) ! + CALL ncio_read_vector (file_restart, 'slpratio', landpatch, slpratio) ! + +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#endif + + CALL ncio_read_bcast_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] + CALL ncio_read_bcast_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] + CALL ncio_read_bcast_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] + CALL ncio_read_bcast_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew + ! CALL ncio_read_bcast_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table + CALL ncio_read_bcast_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T + CALL ncio_read_bcast_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 + CALL ncio_read_bcast_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow + CALL ncio_read_bcast_serial (file_restart, 'wimp ', wimp ) ! water impermeable IF porosity less than wimp + CALL ncio_read_bcast_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) + CALL ncio_read_bcast_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm + CALL ncio_read_bcast_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) + CALL ncio_read_bcast_serial (file_restart, 'smpmax_hr', smpmax_hr) ! wilting point potential in mm + CALL ncio_read_bcast_serial (file_restart, 'smpmin_hr', smpmin_hr) ! restriction for min of soil poten. (mm) + CALL ncio_read_bcast_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] + CALL ncio_read_bcast_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow + CALL ncio_read_bcast_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) + +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif + + IF (DEF_USE_Forcing_Downscaling) THEN + CALL ncio_read_vector (file_restart, 'slp_type_patches' , num_slope_type, landpatch, slp_type_patches) + CALL ncio_read_vector (file_restart, 'svf_patches' , landpatch, svf_patches ) + CALL ncio_read_vector (file_restart, 'asp_type_patches' , num_slope_type, landpatch, asp_type_patches) + CALL ncio_read_vector (file_restart, 'area_type_patches', num_slope_type, landpatch, area_type_patches) + CALL ncio_read_vector (file_restart, 'cur_patches' , landpatch, cur_patches ) +#ifdef SinglePoint + CALL ncio_read_vector (file_restart, 'sf_lut_patches' , num_azimuth , num_zenith, landpatch, sf_lut_patches) +#else + CALL ncio_read_vector (file_restart, 'sf_curve_patches' , num_azimuth , num_zenith_parameter, landpatch, sf_curve_patches) +#endif + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + CALL ncio_read_vector (file_restart, 'slp_type_patches' , num_aspect_type, landpatch, slp_type_patches) + CALL ncio_read_vector (file_restart, 'asp_type_patches' , num_aspect_type, landpatch, asp_type_patches) + CALL ncio_read_vector (file_restart, 'cur_patches' , landpatch, cur_patches ) + ENDIF + +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef SinglePoint + IF (patchtypes(SITE_landtype) == 0) THEN + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_PFTimeInvariants (file_restart) + ENDIF +#else + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_PFTimeInvariants (file_restart) +#endif +#endif + +#if (defined BGC) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_BGCTimeInvariants (file_restart) +#endif + +#if (defined URBAN_MODEL) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' // '_lc' // trim(cyear) // '.nc' + CALL READ_UrbanTimeInvariants (file_restart) +#endif + +#ifdef RangeCheck + CALL check_TimeInvariants () +#endif + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant restart read completion') +#endif + + IF (mpas_is_root) THEN + write(*,*) 'Loading Time Invariants done.' + ENDIF + + END SUBROUTINE READ_TimeInvariants + + !--------------------------------------- + SUBROUTINE WRITE_TimeInvariants (lc_year, casename, dir_restart) + + !==================================================================== + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !==================================================================== + + USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_BEDROCK + USE MOD_MPAS_MPI + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_Utils, only: make_directory + USE MOD_LandPatch + USE MOD_Vars_Global + + IMPLICIT NONE + + integer , intent(in) :: lc_year + character(len=*), intent(in) :: casename + character(len=*), intent(in) :: dir_restart + + ! Local Variables + character(len=256) :: file_restart, cyear + integer :: compress + + compress = DEF_REST_CompressLevel + + write(cyear,'(i4.4)') lc_year + + IF (mpas_is_root) THEN + CALL make_directory(trim(dir_restart)//'/const') + ENDIF +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant restart directory creation') +#endif + + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_const' //'_lc'// trim(cyear) // '.nc' + + CALL ncio_create_file_vector (file_restart, landpatch) + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'type', num_slope_type) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'azi', num_azimuth) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'zen', num_zenith) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'zen_p', num_zenith_parameter) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'type_a', num_aspect_type) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'wavelength', nwl) + + CALL ncio_write_vector (file_restart, 'patchclass', 'patch', landpatch, patchclass) ! + CALL ncio_write_vector (file_restart, 'patchtype' , 'patch', landpatch, patchtype ) ! + CALL ncio_write_vector (file_restart, 'patchmask' , 'patch', landpatch, patchmask ) ! + + CALL ncio_write_vector (file_restart, 'patchlonr' , 'patch', landpatch, patchlonr ) ! + CALL ncio_write_vector (file_restart, 'patchlatr' , 'patch', landpatch, patchlatr ) ! + + CALL ncio_write_vector (file_restart, 'lakedepth' , 'patch', landpatch, lakedepth , compress) ! + CALL ncio_write_vector (file_restart, 'dz_lake' , 'lake', nl_lake, 'patch', landpatch, dz_lake, compress) ! + + CALL ncio_write_vector (file_restart, 'soil_s_v_alb', 'patch', landpatch, soil_s_v_alb, compress) ! albedo of visible of the saturated soil + CALL ncio_write_vector (file_restart, 'soil_d_v_alb', 'patch', landpatch, soil_d_v_alb, compress) ! albedo of visible of the dry soil + CALL ncio_write_vector (file_restart, 'soil_s_n_alb', 'patch', landpatch, soil_s_n_alb, compress) ! albedo of near infrared of the saturated soil + CALL ncio_write_vector (file_restart, 'soil_d_n_alb', 'patch', landpatch, soil_d_n_alb, compress) ! albedo of near infrared of the dry soil +#ifdef HYPERSPECTRAL + CALL ncio_write_vector (file_restart, 'soil_alb' , 'wavelength', nwl, 'patch', landpatch, soil_alb, compress) ! hyper spectral soil albedo. (numpatch, nwl) +#endif + + CALL ncio_write_vector (file_restart, 'vf_quartz ', 'soil', nl_soil, 'patch', landpatch, vf_quartz , compress) ! volumetric fraction of quartz within mineral soil + CALL ncio_write_vector (file_restart, 'vf_gravels', 'soil', nl_soil, 'patch', landpatch, vf_gravels, compress) ! volumetric fraction of gravels + CALL ncio_write_vector (file_restart, 'vf_om ', 'soil', nl_soil, 'patch', landpatch, vf_om , compress) ! volumetric fraction of organic matter + CALL ncio_write_vector (file_restart, 'vf_sand ', 'soil', nl_soil, 'patch', landpatch, vf_sand , compress) ! volumetric fraction of sand + CALL ncio_write_vector (file_restart, 'vf_clay ', 'soil', nl_soil, 'patch', landpatch, vf_clay , compress) ! volumetric fraction of clay + CALL ncio_write_vector (file_restart, 'wf_gravels', 'soil', nl_soil, 'patch', landpatch, wf_gravels, compress) ! gravimetric fraction of gravels + CALL ncio_write_vector (file_restart, 'wf_sand ', 'soil', nl_soil, 'patch', landpatch, wf_sand , compress) ! gravimetric fraction of sand + CALL ncio_write_vector (file_restart, 'wf_clay ', 'soil', nl_soil, 'patch', landpatch, wf_clay , compress) ! gravimetric fraction of clay + CALL ncio_write_vector (file_restart, 'wf_om ', 'soil', nl_soil, 'patch', landpatch, wf_om , compress) ! gravimetric fraction of om + CALL ncio_write_vector (file_restart, 'OM_density', 'soil', nl_soil, 'patch', landpatch, OM_density, compress) ! OM_density + CALL ncio_write_vector (file_restart, 'BD_all ', 'soil', nl_soil, 'patch', landpatch, BD_all , compress) ! bulk density of soil + CALL ncio_write_vector (file_restart, 'wfc ', 'soil', nl_soil, 'patch', landpatch, wfc , compress) ! field capacity + CALL ncio_write_vector (file_restart, 'porsl ', 'soil', nl_soil, 'patch', landpatch, porsl , compress) ! fraction of soil that is voids [-] + CALL ncio_write_vector (file_restart, 'psi0 ', 'soil', nl_soil, 'patch', landpatch, psi0 , compress) ! minimum soil suction [mm] (NOTE: "-" valued) + CALL ncio_write_vector (file_restart, 'bsw ', 'soil', nl_soil, 'patch', landpatch, bsw , compress) ! clapp and hornberger "b" parameter [-] + CALL ncio_write_vector (file_restart, 'theta_r ' , 'soil', nl_soil, 'patch', landpatch, theta_r , compress) ! residual moisture content [-] + CALL ncio_write_vector (file_restart, 'BVIC ' , 'patch', landpatch, BVIC, compress) ! b parameter in Fraction of saturated soil in a grid calculated by VIC + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL ncio_write_vector (file_restart, 'alpha_vgm' , 'soil', nl_soil, 'patch', landpatch, alpha_vgm , compress) ! a parameter corresponding approximately to the inverse of the air-entry value + CALL ncio_write_vector (file_restart, 'L_vgm ' , 'soil', nl_soil, 'patch', landpatch, L_vgm , compress) ! pore-connectivity parameter [dimensionless] + CALL ncio_write_vector (file_restart, 'n_vgm ' , 'soil', nl_soil, 'patch', landpatch, n_vgm , compress) ! a shape parameter [dimensionless] + CALL ncio_write_vector (file_restart, 'sc_vgm ' , 'soil', nl_soil, 'patch', landpatch, sc_vgm , compress) ! saturation at the air entry value in the classical vanGenuchten model [-] + CALL ncio_write_vector (file_restart, 'fc_vgm ' , 'soil', nl_soil, 'patch', landpatch, fc_vgm , compress) ! a scaling factor by using air entry value in the Mualem model [-] +#endif + + CALL ncio_write_vector (file_restart, 'soiltext', 'patch', landpatch, soiltext) + + IF (DEF_Runoff_SCHEME == 0) THEN + CALL ncio_write_vector (file_restart, 'topoweti', 'patch', landpatch, topoweti) + CALL ncio_write_vector (file_restart, 'fsatmax ', 'patch', landpatch, fsatmax ) + CALL ncio_write_vector (file_restart, 'fsatdcf ', 'patch', landpatch, fsatdcf ) + CALL ncio_write_vector (file_restart, 'alp_twi ', 'patch', landpatch, alp_twi ) + CALL ncio_write_vector (file_restart, 'chi_twi ', 'patch', landpatch, chi_twi ) + CALL ncio_write_vector (file_restart, 'mu_twi ', 'patch', landpatch, mu_twi ) + ENDIF + + CALL ncio_write_vector (file_restart, 'vic_b_infilt', 'patch', landpatch, vic_b_infilt) + CALL ncio_write_vector (file_restart, 'vic_Dsmax' , 'patch', landpatch, vic_Dsmax ) + CALL ncio_write_vector (file_restart, 'vic_Ds' , 'patch', landpatch, vic_Ds ) + CALL ncio_write_vector (file_restart, 'vic_Ws' , 'patch', landpatch, vic_Ws ) + CALL ncio_write_vector (file_restart, 'vic_c' , 'patch', landpatch, vic_c ) + + CALL ncio_write_vector (file_restart, 'hksati ' , 'soil', nl_soil, 'patch', landpatch, hksati , compress) ! hydraulic conductivity at saturation [mm h2o/s] + CALL ncio_write_vector (file_restart, 'csol ' , 'soil', nl_soil, 'patch', landpatch, csol , compress) ! heat capacity of soil solids [J/(m3 K)] + CALL ncio_write_vector (file_restart, 'k_solids ' , 'soil', nl_soil, 'patch', landpatch, k_solids , compress) ! thermal conductivity of soil solids [W/m-K] + CALL ncio_write_vector (file_restart, 'dksatu ' , 'soil', nl_soil, 'patch', landpatch, dksatu , compress) ! thermal conductivity of saturated soil [W/m-K] + CALL ncio_write_vector (file_restart, 'dksatf ' , 'soil', nl_soil, 'patch', landpatch, dksatf , compress) ! thermal conductivity of saturated soil [W/m-K] + CALL ncio_write_vector (file_restart, 'dkdry ' , 'soil', nl_soil, 'patch', landpatch, dkdry , compress) ! thermal conductivity for dry soil [W/(m-K)] + CALL ncio_write_vector (file_restart, 'BA_alpha ' , 'soil', nl_soil, 'patch', landpatch, BA_alpha , compress) ! alpha in Balland and Arp(2005) thermal conductivity scheme + CALL ncio_write_vector (file_restart, 'BA_beta ' , 'soil', nl_soil, 'patch', landpatch, BA_beta , compress) ! beta in Balland and Arp(2005) thermal conductivity scheme + + CALL ncio_write_vector (file_restart, 'htop' , 'patch', landpatch, htop) ! + CALL ncio_write_vector (file_restart, 'hbot' , 'patch', landpatch, hbot) ! + + IF(DEF_USE_BEDROCK)THEN + CALL ncio_write_vector (file_restart, 'debdrock' , 'patch', landpatch, dbedrock) + CALL ncio_write_vector (file_restart, 'ibedrock' , 'patch', landpatch, ibedrock) + ENDIF + + CALL ncio_write_vector (file_restart, 'elvmean ', 'patch', landpatch, elvmean ) + CALL ncio_write_vector (file_restart, 'elvstd ', 'patch', landpatch, elvstd ) + CALL ncio_write_vector (file_restart, 'slpratio', 'patch', landpatch, slpratio) + + IF (DEF_USE_Forcing_Downscaling) THEN + CALL ncio_write_vector (file_restart, 'svf_patches', 'patch', landpatch, svf_patches) + CALL ncio_write_vector (file_restart, 'cur_patches', 'patch', landpatch, cur_patches) + CALL ncio_write_vector (file_restart, 'slp_type_patches', 'type', num_slope_type, 'patch', landpatch, slp_type_patches) + CALL ncio_write_vector (file_restart, 'asp_type_patches', 'type', num_slope_type, 'patch', landpatch, asp_type_patches) + CALL ncio_write_vector (file_restart, 'area_type_patches', 'type', num_slope_type, 'patch', landpatch, area_type_patches) +#ifdef SinglePoint + CALL ncio_write_vector (file_restart, 'sf_lut_patches', 'azi' , num_azimuth,'zen', num_zenith, 'patch', landpatch, sf_lut_patches) +#else + CALL ncio_write_vector (file_restart, 'sf_curve_patches', 'azi' , num_azimuth,'zen_p', num_zenith_parameter, 'patch', landpatch, sf_curve_patches) +#endif + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + CALL ncio_write_vector (file_restart, 'cur_patches', 'patch', landpatch, cur_patches) + CALL ncio_write_vector (file_restart, 'slp_type_patches', 'type_a', num_aspect_type, 'patch', landpatch, slp_type_patches) + CALL ncio_write_vector (file_restart, 'asp_type_patches', 'type_a', num_aspect_type, 'patch', landpatch, asp_type_patches) + ENDIF + + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant vector write completion') +#endif + + if (mpas_is_root) then + +#if (!defined(VectorInOneFileS) && !defined(VectorInOneFileP)) + CALL ncio_create_file (file_restart) +#endif + + CALL ncio_write_serial (file_restart, 'zlnd ', zlnd ) ! roughness length for soil [m] + CALL ncio_write_serial (file_restart, 'zsno ', zsno ) ! roughness length for snow [m] + CALL ncio_write_serial (file_restart, 'csoilc', csoilc) ! drag coefficient for soil under canopy [-] + CALL ncio_write_serial (file_restart, 'dewmx ', dewmx ) ! maximum dew + ! CALL ncio_write_serial (file_restart, 'wtfact', wtfact) ! fraction of model area with high water table + CALL ncio_write_serial (file_restart, 'capr ', capr ) ! tuning factor to turn first layer T into surface T + CALL ncio_write_serial (file_restart, 'cnfac ', cnfac ) ! Crank Nicholson factor between 0 and 1 + CALL ncio_write_serial (file_restart, 'ssi ', ssi ) ! irreducible water saturation of snow + CALL ncio_write_serial (file_restart, 'wimp ', wimp ) ! water impermeable if porosity less than wimp + CALL ncio_write_serial (file_restart, 'pondmx', pondmx) ! ponding depth (mm) + CALL ncio_write_serial (file_restart, 'smpmax', smpmax) ! wilting point potential in mm + CALL ncio_write_serial (file_restart, 'smpmin', smpmin) ! restriction for min of soil poten. (mm) + CALL ncio_write_serial (file_restart, 'smpmax_hr', smpmax_hr) ! wilting point potential in mm + CALL ncio_write_serial (file_restart, 'smpmin_hr', smpmin_hr) ! restriction for min of soil poten. (mm) + CALL ncio_write_serial (file_restart, 'trsmx0', trsmx0) ! max transpiration for moist soil+100% veg. [mm/s] + CALL ncio_write_serial (file_restart, 'tcrit ', tcrit ) ! critical temp. to determine rain or snow + CALL ncio_write_serial (file_restart, 'wetwatmax', wetwatmax) ! maximum wetland water (mm) + + ENDIF + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant scalar write completion') +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_pft_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_PFTimeInvariants (file_restart) +#endif + +#if (defined BGC) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_bgc_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_BGCTimeInvariants (file_restart) +#endif + +#if (defined URBAN_MODEL) + file_restart = trim(dir_restart) // '/const/' // trim(casename) //'_restart_urb_const' //'_lc'// trim(cyear) // '.nc' + CALL WRITE_UrbanTimeInvariants (file_restart) +#endif + + END SUBROUTINE WRITE_TimeInvariants + + SUBROUTINE deallocate_TimeInvariants () + + USE MOD_Namelist, only: DEF_USE_Forcing_Downscaling, DEF_USE_Forcing_Downscaling_Simple + USE MOD_MPAS_MPI + USE MOD_LandPatch, only: numpatch + + IMPLICIT NONE + + ! -------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + ! -------------------------------------------------- + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + deallocate (patchclass ) + deallocate (patchtype ) + deallocate (patchmask ) + + deallocate (patchlonr ) + deallocate (patchlatr ) + + deallocate (lakedepth ) + deallocate (dz_lake ) + + deallocate (soil_s_v_alb ) + deallocate (soil_d_v_alb ) + deallocate (soil_s_n_alb ) + deallocate (soil_d_n_alb ) +#ifdef HYPERSPECTRAL + deallocate (soil_alb ) +#endif + + deallocate (vf_quartz ) + deallocate (vf_gravels ) + deallocate (vf_om ) + deallocate (vf_sand ) + deallocate (vf_clay ) + deallocate (wf_gravels ) + deallocate (wf_sand ) + deallocate (wf_clay ) + deallocate (wf_om ) +#ifdef DataAssimilation + deallocate (wf_silt ) +#endif + deallocate (OM_density ) + deallocate (BD_all ) + deallocate (wfc ) + deallocate (porsl ) + deallocate (psi0 ) + deallocate (bsw ) + deallocate (theta_r ) + deallocate (BVIC ) + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + deallocate (alpha_vgm ) + deallocate (L_vgm ) + deallocate (n_vgm ) + deallocate (sc_vgm ) + deallocate (fc_vgm ) +#endif + deallocate (soiltext ) + + deallocate (fsatmax ) + deallocate (fsatdcf ) + deallocate (topoweti ) + deallocate (alp_twi ) + deallocate (chi_twi ) + deallocate (mu_twi ) + + deallocate (vic_b_infilt ) + deallocate (vic_Dsmax ) + deallocate (vic_Ds ) + deallocate (vic_Ws ) + deallocate (vic_c ) + + deallocate (hksati ) + deallocate (csol ) + deallocate (k_solids ) + deallocate (dksatu ) + deallocate (dksatf ) + deallocate (dkdry ) + deallocate (BA_alpha ) + deallocate (BA_beta ) + + deallocate (htop ) + deallocate (hbot ) + + deallocate (dbedrock ) + deallocate (ibedrock ) + + deallocate (elvmean ) + deallocate (elvstd ) + deallocate (slpratio ) + + IF (DEF_USE_Forcing_Downscaling) THEN + deallocate(slp_type_patches ) + deallocate(svf_patches ) + deallocate(asp_type_patches ) + deallocate(area_type_patches ) +#ifdef SinglePoint + deallocate(sf_lut_patches ) +#else + deallocate(sf_curve_patches ) +#endif + deallocate(cur_patches ) + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + deallocate(slp_type_patches ) + deallocate(asp_type_patches ) + deallocate(cur_patches ) + ENDIF + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL deallocate_PFTimeInvariants +#endif + +#ifdef BGC + CALL deallocate_BGCTimeInvariants +#endif + +#ifdef URBAN_MODEL + CALL deallocate_UrbanTimeInvariants +#endif + END SUBROUTINE deallocate_TimeInvariants + +#ifdef RangeCheck + SUBROUTINE check_TimeInvariants () + + USE MOD_MPAS_MPI + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_Runoff_SCHEME, DEF_TOPMOD_method, DEF_USE_BEDROCK, & + DEF_USE_Forcing_Downscaling, DEF_USE_Forcing_Downscaling_Simple + + IMPLICIT NONE + + real(r8), allocatable :: tmpcheck(:,:) + + IF (mpas_is_root) THEN + write(*,'(/,A29)') 'Checking Time Invariants ...' + ENDIF + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant range-check entry') +#endif + + CALL check_vector_data ('lakedepth [m] ', lakedepth ) ! + CALL check_vector_data ('dz_lake [m] ', dz_lake ) ! new lake scheme + + CALL check_vector_data ('soil_s_v_alb [-] ', soil_s_v_alb) ! albedo of visible of the saturated soil + CALL check_vector_data ('soil_d_v_alb [-] ', soil_d_v_alb) ! albedo of visible of the dry soil + CALL check_vector_data ('soil_s_n_alb [-] ', soil_s_n_alb) ! albedo of near infrared of the saturated soil + CALL check_vector_data ('soil_d_n_alb [-] ', soil_d_n_alb) ! albedo of near infrared of the dry soil +#ifdef HYPERSPECTRAL + CALL check_vector_data ('soil_alb [-] ', soil_alb ) ! hyper spectral soil albedo. +#endif + CALL check_vector_data ('vf_quartz [m3/m3] ', vf_quartz ) ! volumetric fraction of quartz within mineral soil + CALL check_vector_data ('vf_gravels [m3/m3] ', vf_gravels ) ! volumetric fraction of gravels + CALL check_vector_data ('vf_sand [m3/m3] ', vf_sand ) ! volumetric fraction of sand + CALL check_vector_data ('vf_clay [m3/m3] ', vf_clay ) ! volumetric fraction of clay + CALL check_vector_data ('vf_om [m3/m3] ', vf_om ) ! volumetric fraction of organic matter + CALL check_vector_data ('wf_gravels [kg/kg] ', wf_gravels ) ! gravimetric fraction of gravels + CALL check_vector_data ('wf_sand [kg/kg] ', wf_sand ) ! gravimetric fraction of sand + CALL check_vector_data ('wf_clay [kg/kg] ', wf_clay ) ! gravimetric fraction of clay + CALL check_vector_data ('wf_om [kg/kg] ', wf_om ) ! gravimetric fraction of om + CALL check_vector_data ('OM_density [kg/m3] ', OM_density ) ! OM density + CALL check_vector_data ('BD_all [kg/m3] ', BD_all ) ! bulk density of soils + CALL check_vector_data ('wfc [m3/m3] ', wfc ) ! field capacity + CALL check_vector_data ('porsl [m3/m3] ', porsl ) ! fraction of soil that is voids [-] + CALL check_vector_data ('psi0 [mm] ', psi0 ) ! minimum soil suction [mm] (NOTE: "-" valued) + CALL check_vector_data ('bsw [-] ', bsw ) ! clapp and hornberger "b" parameter [-] +#ifdef vanGenuchten_Mualem_SOIL_MODEL + CALL check_vector_data ('theta_r [m3/m3] ', theta_r ) ! residual moisture content [-] + CALL check_vector_data ('alpha_vgm [-] ', alpha_vgm ) ! a parameter corresponding approximately to the inverse of the air-entry value + CALL check_vector_data ('L_vgm [-] ', L_vgm ) ! pore-connectivity parameter [dimensionless] + CALL check_vector_data ('n_vgm [-] ', n_vgm ) ! a shape parameter [dimensionless] + CALL check_vector_data ('sc_vgm [-] ', sc_vgm ) ! saturation at the air entry value in the classical vanGenuchten model [-] + CALL check_vector_data ('fc_vgm [-] ', fc_vgm ) ! a scaling factor by using air entry value in the Mualem model [-] +#endif + + IF ((DEF_Runoff_SCHEME == 0) .and. (DEF_TOPMOD_method == 1)) THEN + CALL check_vector_data ('mean twi [log m] ', topoweti) ! + CALL check_vector_data ('max sat frac area [-]', fsatmax ) ! + CALL check_vector_data ('sat frac area decay ', fsatdcf ) ! + ENDIF + + IF ((DEF_Runoff_SCHEME == 0) .and. (DEF_TOPMOD_method == 2)) THEN + CALL check_vector_data ('mean twi [log m] ', topoweti) ! + CALL check_vector_data ('twi alpha in 3-gamma ', alp_twi ) + CALL check_vector_data ('twi chi in 3-gamma ', chi_twi ) + CALL check_vector_data ('twi mu in 3-gamma ', mu_twi ) + ENDIF + + CALL check_vector_data ('hksati [mm/s] ', hksati ) ! hydraulic conductivity at saturation [mm h2o/s] + CALL check_vector_data ('csol [J/m3/K]', csol ) ! heat capacity of soil solids [J/(m3 K)] + CALL check_vector_data ('k_solids [W/m/K] ', k_solids ) ! thermal conductivity of soil solids [W/m-K] + CALL check_vector_data ('dksatu [W/m/K] ', dksatu ) ! thermal conductivity of unfrozen saturated soil [W/m-K] + CALL check_vector_data ('dksatf [W/m/K] ', dksatf ) ! thermal conductivity of frozen saturated soil [W/m-K] + CALL check_vector_data ('dkdry [W/m/K] ', dkdry ) ! thermal conductivity for dry soil [W/(m-K)] + CALL check_vector_data ('BA_alpha [-] ', BA_alpha ) ! alpha in Balland and Arp(2005) thermal conductivity scheme + CALL check_vector_data ('BA_beta [-] ', BA_beta ) ! beta in Balland and Arp(2005) thermal conductivity scheme + + CALL check_vector_data ('soiltexture [-] ', soiltext, -1) ! + + CALL check_vector_data ('htop [m] ', htop ) + CALL check_vector_data ('hbot [m] ', hbot ) + + IF(DEF_USE_BEDROCK)THEN + CALL check_vector_data ('dbedrock [m] ', dbedrock ) ! + ENDIF + + CALL check_vector_data ('elvmean [m] ', elvmean ) ! + CALL check_vector_data ('elvstd [m] ', elvstd ) ! + CALL check_vector_data ('slpratio [-] ', slpratio ) ! + + IF (DEF_Runoff_SCHEME == 3) THEN + CALL check_vector_data ('BVIC [-] ', BVIC ) ! + ENDIF + + IF (DEF_USE_Forcing_Downscaling) THEN + CALL check_vector_data ('slp_type [rad] ', slp_type_patches ) ! slope + CALL check_vector_data ('svf [-] ', svf_patches ) ! sky view factor + CALL check_vector_data ('asp_type [rad] ', asp_type_patches ) ! aspect + CALL check_vector_data ('area_type [-] ', area_type_patches) ! area percent + CALL check_vector_data ('cur [-] ', cur_patches ) +#ifdef SinglePoint + CALL check_vector_data ('sf_lut [-] ', sf_lut_patches ) ! shadow mask +#else + IF (allocated(sf_curve_patches)) allocate(tmpcheck(size(sf_curve_patches,1),size(sf_curve_patches,3))) + + IF (allocated(sf_curve_patches)) tmpcheck = sf_curve_patches(:,1,:) + CALL check_vector_data ('1 sf_curve p [-] ', tmpcheck) ! shadow mask + IF (allocated(sf_curve_patches)) tmpcheck = sf_curve_patches(:,2,:) + CALL check_vector_data ('2 sf_curve p [-] ', tmpcheck) ! shadow mask + IF (allocated(sf_curve_patches)) tmpcheck = sf_curve_patches(:,3,:) + CALL check_vector_data ('3 sf_curve p [-] ', tmpcheck) ! shadow mask + + IF (allocated(tmpcheck)) deallocate(tmpcheck) +#endif + ENDIF + + IF (DEF_USE_Forcing_Downscaling_Simple) THEN + CALL check_vector_data ('slp_type [rad] ', slp_type_patches ) ! slope + CALL check_vector_data ('asp_type [-] ', asp_type_patches ) ! aspect fraction of direction of patches + CALL check_vector_data ('cur [-] ', cur_patches ) + ENDIF + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-invariant range-check completion') +#endif + + IF (mpas_is_root) THEN + write(*,'(/,A)') 'Checking Constants ...' + write(*,'(A,E20.10)') 'zlnd [m] ', zlnd ! roughness length for soil [m] + write(*,'(A,E20.10)') 'zsno [m] ', zsno ! roughness length for snow [m] + write(*,'(A,E20.10)') 'csoilc [-] ', csoilc ! drag coefficient for soil under canopy [-] + write(*,'(A,E20.10)') 'dewmx [mm] ', dewmx ! maximum dew + ! write(*,'(A,E20.10)') 'wtfact [-] ', wtfact ! fraction of model area with high water table + write(*,'(A,E20.10)') 'capr [-] ', capr ! tuning factor to turn first layer T into surface T + write(*,'(A,E20.10)') 'cnfac [-] ', cnfac ! Crank Nicholson factor between 0 and 1 + write(*,'(A,E20.10)') 'ssi [-] ', ssi ! irreducible water saturation of snow + write(*,'(A,E20.10)') 'wimp [m3/m3]', wimp ! water impermeable IF porosity less than wimp + write(*,'(A,E20.10)') 'pondmx [mm] ', pondmx ! ponding depth (mm) + write(*,'(A,E20.10)') 'smpmax [mm] ', smpmax ! wilting point potential in mm + write(*,'(A,E20.10)') 'smpmin [mm] ', smpmin ! restriction for min of soil poten. (mm) + write(*,'(A,E20.10)') 'smpmax_hr [mm]', smpmax_hr ! wilting point potential in mm + write(*,'(A,E20.10)') 'smpmin_hr [mm]', smpmin_hr ! restriction for min of soil poten. (mm) + write(*,'(A,E20.10)') 'trsmx0 [mm/s] ', trsmx0 ! max transpiration for moist soil+100% veg. [mm/s] + write(*,'(A,E20.10)') 'tcrit [K] ', tcrit ! critical temp. to determine rain or snow + write(*,'(A,E20.10)') 'wetwatmax [mm]', wetwatmax ! maximum wetland water (mm) + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL check_PFTimeInvariants +#endif + +#ifdef BGC + CALL check_BGCTimeInvariants +#endif + + END SUBROUTINE check_TimeInvariants +#endif + +END MODULE MOD_Vars_TimeInvariants +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 new file mode 100644 index 0000000000..ea56676520 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90 @@ -0,0 +1,1736 @@ +#include + +!----------------------------------------------------------------------- +! Created by Yongjiu Dai, 03/2014 +!----------------------------------------------------------------------- + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +MODULE MOD_Vars_PFTimeVariables +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Define PFT time variables +! +! Added by Hua Yuan, 08/2019 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_TimeManager +#ifdef BGC + USE MOD_BGC_Vars_PFTimeVariables +#endif + + IMPLICIT NONE + SAVE +!----------------------------------------------------------------------- +! Time-varying state variables which required by restart run + + ! for LULC_IGBP_PFT or LULC_IGBP_PC + real(r8), allocatable :: tleaf_p (:) !shaded leaf temperature [K] + real(r8), allocatable :: ldew_p (:) !depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain_p (:) !depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow_p (:) !depth of snow on foliage [mm] + real(r8), allocatable :: fwet_snow_p (:) !vegetation snow fractional cover [-] + real(r8), allocatable :: sigf_p (:) !fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: tlai_p (:) !leaf area index + real(r8), allocatable :: lai_p (:) !leaf area index + real(r8), allocatable :: laisun_p (:) !sunlit leaf area index + real(r8), allocatable :: laisha_p (:) !shaded leaf area index + real(r8), allocatable :: tsai_p (:) !stem area index + real(r8), allocatable :: sai_p (:) !stem area index + real(r8), allocatable :: ssun_p (:,:,:) !sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha_p (:,:,:) !shaded canopy absorption for solar radiation (0-1) + +#ifdef HYPERSPECTRAL + real(r8), allocatable :: ssun_hires_p (:,:,:) !sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha_hires_p (:,:,:) !shaded canopy absorption for solar radiation (0-1) +#endif + + real(r8), allocatable :: thermk_p (:) !canopy gap fraction for tir radiation + real(r8), allocatable :: fshade_p (:) !canopy shade fraction for tir radiation + real(r8), allocatable :: extkb_p (:) !(k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd_p (:) !diffuse and scattered diffuse PAR extinction coefficient + !TODO@yuan: to check the below for PC whether they are needed + real(r8), allocatable :: tref_p (:) !2 m height air temperature [kelvin] + real(r8), allocatable :: t2m_wmo_p (:) !2 m WMO air temperature [kelvin] + real(r8), allocatable :: qref_p (:) !2 m height air specific humidity + real(r8), allocatable :: rst_p (:) !canopy stomatal resistance (s/m) + real(r8), allocatable :: z0m_p (:) !effective roughness [m] +! Plant Hydraulic variables + real(r8), allocatable :: vegwp_p (:,:) !vegetation water potential [mm] + real(r8), allocatable :: gs0sun_p (:) !working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha_p (:) !working copy of shaded stomata conductance +! END plant hydraulic variables +! Ozone Stress Variables + real(r8), allocatable :: o3coefv_sun_p(:) !Ozone stress factor for photosynthesis on sunlit leaf + real(r8), allocatable :: o3coefv_sha_p(:) !Ozone stress factor for photosynthesis on shaded leaf + real(r8), allocatable :: o3coefg_sun_p(:) !Ozone stress factor for stomata on sunlit leaf + real(r8), allocatable :: o3coefg_sha_p(:) !Ozone stress factor for stomata on shaded leaf + real(r8), allocatable :: lai_old_p (:) !lai in last time step + real(r8), allocatable :: o3uptakesun_p(:) !Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha_p(:) !Ozone does, shaded leaf (mmol O3/m^2) +! END Ozone Stress Variables +! irrigation variables + integer , allocatable :: irrig_method_p(:)!irrigation method +! END irrigation variables + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_PFTimeVariables + PUBLIC :: deallocate_PFTimeVariables + PUBLIC :: READ_PFTimeVariables + PUBLIC :: WRITE_PFTimeVariables +#ifdef RangeCheck + PUBLIC :: check_PFTimeVariables +#endif + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_PFTimeVariables () + !-------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpft] variables + !-------------------------------------------------------------------- + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandPFT + USE MOD_Vars_Global + IMPLICIT NONE + + IF (.true.) THEN + IF (numpft > 0) THEN + allocate (tleaf_p (numpft)) ; tleaf_p (:) = spval !leaf temperature [K] + allocate (ldew_p (numpft)) ; ldew_p (:) = spval !depth of water on foliage [mm] + allocate (ldew_rain_p (numpft)) ; ldew_rain_p (:) = spval !depth of rain on foliage [mm] + allocate (ldew_snow_p (numpft)) ; ldew_snow_p (:) = spval !depth of snow on foliage [mm] + allocate (fwet_snow_p (numpft)) ; fwet_snow_p (:) = spval !vegetation snow fractional cover [-] + allocate (sigf_p (numpft)) ; sigf_p (:) = spval !fraction of veg cover, excluding snow-covered veg [-] + allocate (tlai_p (numpft)) ; tlai_p (:) = spval !leaf area index + allocate (lai_p (numpft)) ; lai_p (:) = spval !leaf area index + allocate (laisun_p (numpft)) ; laisun_p (:) = spval !leaf area index + allocate (laisha_p (numpft)) ; laisha_p (:) = spval !leaf area index + allocate (tsai_p (numpft)) ; tsai_p (:) = spval !stem area index + allocate (sai_p (numpft)) ; sai_p (:) = spval !stem area index + allocate (ssun_p (2,2,numpft)) ; ssun_p (:,:,:) = spval !sunlit canopy absorption for solar radiation (0-1) + allocate (ssha_p (2,2,numpft)) ; ssha_p (:,:,:) = spval !shaded canopy absorption for solar radiation (0-1) + +#ifdef HYPERSPECTRAL + allocate (ssun_hires_p (211,2,numpft)) ; ssun_hires_p (:,:,:) = spval !sunlit canopy absorption for solar radiation (0-1) + allocate (ssha_hires_p (211,2,numpft)) ; ssha_hires_p (:,:,:) = spval !shaded canopy absorption for solar radiation (0-1) +#endif + + allocate (thermk_p (numpft)) ; thermk_p (:) = spval !canopy gap fraction for tir radiation + allocate (fshade_p (numpft)) ; fshade_p (:) = spval !canopy shade fraction for tir radiation + allocate (extkb_p (numpft)) ; extkb_p (:) = spval !(k, g(mu)/mu) direct solar extinction coefficient + allocate (extkd_p (numpft)) ; extkd_p (:) = spval !diffuse and scattered diffuse PAR extinction coefficient + allocate (tref_p (numpft)) ; tref_p (:) = spval !2 m height air temperature [kelvin] + allocate (t2m_wmo_p (numpft)) ; t2m_wmo_p (:) = spval !2 m WMO air temperature [kelvin] + allocate (qref_p (numpft)) ; qref_p (:) = spval !2 m height air specific humidity + allocate (rst_p (numpft)) ; rst_p (:) = spval !canopy stomatal resistance (s/m) + allocate (z0m_p (numpft)) ; z0m_p (:) = spval !effective roughness [m] +! Plant Hydraulic variables + allocate (vegwp_p(1:nvegwcs,numpft)); vegwp_p (:,:) = spval + allocate (gs0sun_p (numpft)); gs0sun_p (:) = spval + allocate (gs0sha_p (numpft)); gs0sha_p (:) = spval +! END plant hydraulic variables +! Allocate Ozone Stress Variables + allocate (o3coefv_sun_p(numpft)) ; o3coefv_sun_p(:) = spval !Ozone stress factor for photosynthesis on sunlit leaf + allocate (o3coefv_sha_p(numpft)) ; o3coefv_sha_p(:) = spval !Ozone stress factor for photosynthesis on shaded leaf + allocate (o3coefg_sun_p(numpft)) ; o3coefg_sun_p(:) = spval !Ozone stress factor for stomata on sunlit leaf + allocate (o3coefg_sha_p(numpft)) ; o3coefg_sha_p(:) = spval !Ozone stress factor for stomata on shaded leaf + allocate (lai_old_p (numpft)) ; lai_old_p (:) = spval !lai in last time step + allocate (o3uptakesun_p(numpft)) ; o3uptakesun_p(:) = spval !Ozone does, sunlit leaf (mmol O3/m^2) + allocate (o3uptakesha_p(numpft)) ; o3uptakesha_p(:) = spval !Ozone does, shaded leaf (mmol O3/m^2) +! END allocate Ozone Stress Variables + allocate (irrig_method_p(numpft)); irrig_method_p(:) = 0! irrigation method + + ENDIF + ENDIF + +#ifdef BGC + CALL allocate_BGCPFTimeVariables +#endif + + END SUBROUTINE allocate_PFTimeVariables + + SUBROUTINE READ_PFTimeVariables (file_restart) + + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION + USE MOD_NetCDFVector + USE MOD_LandPFT + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + +#ifdef MPAS_EMBEDDED_COLM + IF (numpft <= 0) RETURN +#endif + + CALL ncio_read_vector (file_restart, 'tleaf_p ', landpft, tleaf_p ) + CALL ncio_read_vector (file_restart, 'ldew_p ', landpft, ldew_p ) + CALL ncio_read_vector (file_restart, 'ldew_rain_p',landpft, ldew_rain_p ) + CALL ncio_read_vector (file_restart, 'ldew_snow_p',landpft, ldew_snow_p ) + CALL ncio_read_vector (file_restart, 'fwet_snow_p',landpft, fwet_snow_p ) + CALL ncio_read_vector (file_restart, 'sigf_p ', landpft, sigf_p ) + CALL ncio_read_vector (file_restart, 'tlai_p ', landpft, tlai_p ) + CALL ncio_read_vector (file_restart, 'lai_p ', landpft, lai_p ) +! CALL ncio_read_vector (file_restart, 'laisun_p ', landpft, laisun_p ) +! CALL ncio_read_vector (file_restart, 'laisha_p ', landpft, laisha_p ) + CALL ncio_read_vector (file_restart, 'tsai_p ', landpft, tsai_p ) + CALL ncio_read_vector (file_restart, 'sai_p ', landpft, sai_p ) + CALL ncio_read_vector (file_restart, 'ssun_p ', 2,2, landpft, ssun_p ) + CALL ncio_read_vector (file_restart, 'ssha_p ', 2,2, landpft, ssha_p ) + +#ifdef HYPERSPECTRAL + CALL ncio_read_vector (file_restart, 'ssun_hires_p ', 211,2, landpft, ssun_hires_p ) + CALL ncio_read_vector (file_restart, 'ssha_hires_p ', 211,2, landpft, ssha_hires_p ) +#endif + + CALL ncio_read_vector (file_restart, 'thermk_p ', landpft, thermk_p ) + CALL ncio_read_vector (file_restart, 'fshade_p ', landpft, fshade_p ) + CALL ncio_read_vector (file_restart, 'extkb_p ', landpft, extkb_p ) + CALL ncio_read_vector (file_restart, 'extkd_p ', landpft, extkd_p ) + CALL ncio_read_vector (file_restart, 'tref_p ', landpft, tref_p ) + CALL ncio_read_vector (file_restart, 'qref_p ', landpft, qref_p ) + CALL ncio_read_vector (file_restart, 'rst_p ', landpft, rst_p ) + CALL ncio_read_vector (file_restart, 'z0m_p ', landpft, z0m_p ) +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_read_vector (file_restart, 'vegwp_p ', nvegwcs, landpft, vegwp_p ) + CALL ncio_read_vector (file_restart, 'gs0sun_p ', landpft, gs0sun_p ) + CALL ncio_read_vector (file_restart, 'gs0sha_p ', landpft, gs0sha_p ) +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_read_vector (file_restart, 'lai_old_p ', landpft, lai_old_p , defval = 0._r8) + CALL ncio_read_vector (file_restart, 'o3uptakesun_p', landpft, o3uptakesun_p, defval = 0._r8) + CALL ncio_read_vector (file_restart, 'o3uptakesha_p', landpft, o3uptakesha_p, defval = 0._r8) +ENDIF +IF(DEF_USE_IRRIGATION)THEN + CALL ncio_read_vector (file_restart,'irrig_method_p', landpft,irrig_method_p, defval = 0) +ENDIF + +#ifdef BGC + CALL read_BGCPFTimeVariables (file_restart) +#endif + + END SUBROUTINE READ_PFTimeVariables + + SUBROUTINE WRITE_PFTimeVariables (file_restart) + + USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_USE_IRRIGATION + USE MOD_LandPFT + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local variables + integer :: compress + + compress = DEF_REST_CompressLevel + +#ifdef MPAS_EMBEDDED_COLM + IF (numpft <= 0) RETURN +#endif + + CALL ncio_create_file_vector (file_restart, landpft) + CALL ncio_define_dimension_vector (file_restart, landpft, 'pft') + CALL ncio_define_dimension_vector (file_restart, landpft, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpft, 'rtyp', 2) + + CALL ncio_define_dimension_vector (file_restart, landpft, 'wavelength', 211) + +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_define_dimension_vector (file_restart, landpft, 'vegnodes', nvegwcs) +ENDIF + + CALL ncio_write_vector (file_restart, 'tleaf_p ', 'pft', landpft, tleaf_p , compress) + CALL ncio_write_vector (file_restart, 'ldew_p ', 'pft', landpft, ldew_p , compress) + CALL ncio_write_vector (file_restart, 'ldew_rain_p','pft',landpft,ldew_rain_p,compress) + CALL ncio_write_vector (file_restart, 'ldew_snow_p','pft',landpft,ldew_snow_p,compress) + CALL ncio_write_vector (file_restart, 'fwet_snow_p','pft',landpft,fwet_snow_p,compress) + CALL ncio_write_vector (file_restart, 'sigf_p ', 'pft', landpft, sigf_p , compress) + CALL ncio_write_vector (file_restart, 'tlai_p ', 'pft', landpft, tlai_p , compress) + CALL ncio_write_vector (file_restart, 'lai_p ', 'pft', landpft, lai_p , compress) +! CALL ncio_write_vector (file_restart, 'laisun_p ', 'pft', landpft, laisun_p , compress) +! CALL ncio_write_vector (file_restart, 'laisha_p ', 'pft', landpft, laisha_p , compress) + CALL ncio_write_vector (file_restart, 'tsai_p ', 'pft', landpft, tsai_p , compress) + CALL ncio_write_vector (file_restart, 'sai_p ', 'pft', landpft, sai_p , compress) + CALL ncio_write_vector (file_restart, 'ssun_p ', 'band', 2, 'rtyp', 2, 'pft', landpft, ssun_p, compress) + CALL ncio_write_vector (file_restart, 'ssha_p ', 'band', 2, 'rtyp', 2, 'pft', landpft, ssha_p, compress) + +#ifdef HYPERSPECTRAL + CALL ncio_write_vector (file_restart, 'ssun_hires_p', 'wavelength', 211, 'rtyp', 2, 'pft', landpft, ssun_hires_p, compress) + CALL ncio_write_vector (file_restart, 'ssha_hires_p', 'wavelength', 211, 'rtyp', 2, 'pft', landpft, ssha_hires_p, compress) +#endif + + CALL ncio_write_vector (file_restart, 'thermk_p ', 'pft', landpft, thermk_p , compress) + CALL ncio_write_vector (file_restart, 'fshade_p ', 'pft', landpft, fshade_p , compress) + CALL ncio_write_vector (file_restart, 'extkb_p ', 'pft', landpft, extkb_p , compress) + CALL ncio_write_vector (file_restart, 'extkd_p ', 'pft', landpft, extkd_p , compress) + CALL ncio_write_vector (file_restart, 'tref_p ', 'pft', landpft, tref_p , compress) + CALL ncio_write_vector (file_restart, 'qref_p ', 'pft', landpft, qref_p , compress) + CALL ncio_write_vector (file_restart, 'rst_p ', 'pft', landpft, rst_p , compress) + CALL ncio_write_vector (file_restart, 'z0m_p ', 'pft', landpft, z0m_p , compress) +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_write_vector (file_restart, 'vegwp_p ', 'vegnodes', nvegwcs, 'pft', landpft, vegwp_p, compress) + CALL ncio_write_vector (file_restart, 'gs0sun_p ', 'pft', landpft, gs0sun_p , compress) + CALL ncio_write_vector (file_restart, 'gs0sha_p ', 'pft', landpft, gs0sha_p , compress) +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_write_vector (file_restart, 'lai_old_p ', 'pft', landpft, lai_old_p , compress) + CALL ncio_write_vector (file_restart, 'o3uptakesun_p', 'pft', landpft, o3uptakesun_p, compress) + CALL ncio_write_vector (file_restart, 'o3uptakesha_p', 'pft', landpft, o3uptakesha_p, compress) +ENDIF +IF(DEF_USE_IRRIGATION)THEN + CALL ncio_write_vector (file_restart,'irrig_method_p','pft', landpft, irrig_method_p, compress) +ENDIF + +#ifdef BGC + CALL WRITE_BGCPFTimeVariables (file_restart) +#endif + + END SUBROUTINE WRITE_PFTimeVariables + + + SUBROUTINE deallocate_PFTimeVariables + !-------------------------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpft/numpc] variables + !-------------------------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_LandPFT + + IF (.true.) THEN + IF (numpft > 0) THEN + deallocate (tleaf_p ) ! leaf temperature [K] + deallocate (ldew_p ) ! depth of water on foliage [mm] + deallocate (ldew_rain_p ) ! depth of rain on foliage [mm] + deallocate (ldew_snow_p ) ! depth of snow on foliage [mm] + deallocate (fwet_snow_p ) ! vegetation snow fractional cover [-] + deallocate (sigf_p ) ! fraction of veg cover, excluding snow-covered veg [-] + deallocate (tlai_p ) ! leaf area index + deallocate (lai_p ) ! leaf area index + deallocate (laisun_p ) ! leaf area index + deallocate (laisha_p ) ! leaf area index + deallocate (tsai_p ) ! stem area index + deallocate (sai_p ) ! stem area index + deallocate (ssun_p ) ! sunlit canopy absorption for solar radiation (0-1) + deallocate (ssha_p ) ! shaded canopy absorption for solar radiation (0-1) + +#ifdef HYPERSPECTRAL + deallocate (ssun_hires_p ) ! sunlit canopy absorption for solar radiation (0-1) + deallocate (ssha_hires_p ) ! shaded canopy absorption for solar radiation (0-1) +#endif + + deallocate (thermk_p ) ! canopy gap fraction for tir radiation + deallocate (fshade_p ) ! canopy gap fraction for tir radiation + deallocate (extkb_p ) ! (k, g(mu)/mu) direct solar extinction coefficient + deallocate (extkd_p ) ! diffuse and scattered diffuse PAR extinction coefficient + deallocate (tref_p ) ! 2 m height air temperature [kelvin] + deallocate (t2m_wmo_p ) ! 2 m WMO air temperature [kelvin] + deallocate (qref_p ) ! 2 m height air specific humidity + deallocate (rst_p ) ! canopy stomatal resistance (s/m) + deallocate (z0m_p ) ! effective roughness [m] +! Plant Hydraulic variables + deallocate (vegwp_p ) ! vegetation water potential [mm] + deallocate (gs0sun_p ) ! working copy of sunlit stomata conductance + deallocate (gs0sha_p ) ! working copy of shaded stomata conductance +! END plant hydraulic variables +! Ozone Stress variables + deallocate (o3coefv_sun_p ) ! Ozone stress factor for photosynthesis on sunlit leaf + deallocate (o3coefv_sha_p ) ! Ozone stress factor for photosynthesis on shaded leaf + deallocate (o3coefg_sun_p ) ! Ozone stress factor for stomata on sunlit leaf + deallocate (o3coefg_sha_p ) ! Ozone stress factor for stomata on shaded leaf + deallocate (lai_old_p ) ! lai in last time step + deallocate (o3uptakesun_p ) ! Ozone does, sunlit leaf (mmol O3/m^2) + deallocate (o3uptakesha_p ) ! Ozone does, shaded leaf (mmol O3/m^2) + deallocate (irrig_method_p ) +! Ozone Stress variables + ENDIF + ENDIF + +#ifdef BGC + CALL deallocate_BGCPFTimeVariables +#endif + + END SUBROUTINE deallocate_PFTimeVariables + +#ifdef RangeCheck + SUBROUTINE check_PFTimeVariables + + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION + + IMPLICIT NONE + + CALL check_vector_data (' tleaf_p', tleaf_p ) + CALL check_vector_data (' ldew_p', ldew_p ) + CALL check_vector_data (' ldew_rain_p', ldew_rain_p ) + CALL check_vector_data (' ldew_snow_p', ldew_snow_p ) + CALL check_vector_data (' fwet_snow_p', fwet_snow_p ) + CALL check_vector_data (' sigf_p', sigf_p ) + CALL check_vector_data (' tlai_p', tlai_p ) + CALL check_vector_data (' lai_p', lai_p ) + CALL check_vector_data (' laisun_p', lai_p ) + CALL check_vector_data (' laisha_p', lai_p ) + CALL check_vector_data (' tsai_p', tsai_p ) + CALL check_vector_data (' sai_p', sai_p ) + CALL check_vector_data (' ssun_p', ssun_p ) + CALL check_vector_data (' ssha_p', ssha_p ) + CALL check_vector_data (' thermk_p', thermk_p ) + CALL check_vector_data (' fshade_p', fshade_p ) + CALL check_vector_data (' extkb_p', extkb_p ) + CALL check_vector_data (' extkd_p', extkd_p ) + CALL check_vector_data (' tref_p', tref_p ) + CALL check_vector_data (' t2m_wmo_p', t2m_wmo_p ) + CALL check_vector_data (' qref_p', qref_p ) + CALL check_vector_data (' rst_p', rst_p ) + CALL check_vector_data (' z0m_p', z0m_p ) +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL check_vector_data (' vegwp_p', vegwp_p ) + CALL check_vector_data (' gs0sun_p', gs0sun_p ) + CALL check_vector_data (' gs0sha_p', gs0sha_p ) +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL check_vector_data (' o3coefv_sun_p', o3coefv_sun_p ) + CALL check_vector_data (' o3coefv_sha_p', o3coefv_sha_p ) + CALL check_vector_data (' o3coefg_sun_p', o3coefg_sun_p ) + CALL check_vector_data (' o3coefg_sha_p', o3coefg_sha_p ) + CALL check_vector_data (' lai_old_p', lai_old_p ) + CALL check_vector_data (' o3uptakesun_p', o3uptakesun_p ) + CALL check_vector_data (' o3uptakesha_p', o3uptakesha_p ) +ENDIF +IF(DEF_USE_IRRIGATION)THEN + CALL check_vector_data ('irrig_method_p', irrig_method_p ) +ENDIF + +#ifdef BGC + CALL check_BGCPFTimeVariables +#endif + + END SUBROUTINE check_PFTimeVariables +#endif + +END MODULE MOD_Vars_PFTimeVariables +#endif + + +MODULE MOD_Vars_TimeVariables +! ------------------------------- +! Created by Yongjiu Dai, 03/2014 +! ------------------------------- + + USE MOD_Precision + USE MOD_TimeManager +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + USE MOD_Vars_PFTimeVariables +#endif +#ifdef BGC + USE MOD_BGC_Vars_TimeVariables +#endif +#ifdef CatchLateralFlow + USE MOD_Catch_Vars_TimeVariables +#endif +#ifdef GridRiverLakeFlow + USE MOD_Grid_RiverLakeTimeVars +#endif +#ifdef URBAN_MODEL + USE MOD_Urban_Vars_TimeVariables +#endif +#ifdef EXTERNAL_LAKE + USE MOD_Lake_TimeVars +#endif +#ifdef DataAssimilation + USE MOD_DA_Vars_TimeVariables +#endif + + IMPLICIT NONE + SAVE +! ----------------------------------------------------------------- +! Time-varying state variables which required by restart run + real(r8), allocatable :: z_sno (:,:) ! node depth [m] + real(r8), allocatable :: dz_sno (:,:) ! interface depth [m] + real(r8), allocatable :: t_soisno (:,:) ! soil temperature [K] + real(r8), allocatable :: wliq_soisno (:,:) ! liquid water in layers [kg/m2] + real(r8), allocatable :: wice_soisno (:,:) ! ice lens in layers [kg/m2] + real(r8), allocatable :: h2osoi (:,:) ! volumetric soil water in layers [m3/m3] + real(r8), allocatable :: smp (:,:) ! soil matrix potential [mm] + real(r8), allocatable :: hk (:,:) ! hydraulic conductivity [mm h2o/s] + real(r8), allocatable :: rootr (:,:) ! transpiration contribution fraction from different layers + real(r8), allocatable :: rootflux (:,:) ! water exchange between soil and root. Positive: soil->root [?] +!Plant Hydraulic variables + real(r8), allocatable :: vegwp (:,:) ! vegetation water potential [mm] + real(r8), allocatable :: gs0sun (:) ! working copy of sunlit stomata conductance + real(r8), allocatable :: gs0sha (:) ! working copy of shaded stomata conductance +!END plant hydraulic variables +!Ozone stress variables + real(r8), allocatable :: o3coefv_sun (:) ! Ozone stress factor for photosynthesis on sunlit leaf + real(r8), allocatable :: o3coefv_sha (:) ! Ozone stress factor for photosynthesis on shaded leaf + real(r8), allocatable :: o3coefg_sun (:) ! Ozone stress factor for stomata on sunlit leaf + real(r8), allocatable :: o3coefg_sha (:) ! Ozone stress factor for stomata on shaded leaf + real(r8), allocatable :: lai_old (:) ! lai in last time step + real(r8), allocatable :: o3uptakesun (:) ! Ozone does, sunlit leaf (mmol O3/m^2) + real(r8), allocatable :: o3uptakesha (:) ! Ozone does, shaded leaf (mmol O3/m^2) +!END ozone stress variables + real(r8), allocatable :: rstfacsun_out (:) ! factor of soil water stress on sunlit leaf + real(r8), allocatable :: rstfacsha_out (:) ! factor of soil water stress on shaded leaf + real(r8), allocatable :: gssun_out (:) ! stomata conductance on sunlit leaf + real(r8), allocatable :: gssha_out (:) ! stomata conductance on shaded leaf + real(r8), allocatable :: t_grnd (:) ! ground surface temperature [K] + + real(r8), allocatable :: assimsun_out (:) ! diagnostic sunlit leaf assim value for output + real(r8), allocatable :: assimsha_out (:) ! diagnostic sunlit leaf etr value for output + real(r8), allocatable :: etrsun_out (:) ! diagnostic shaded leaf assim for output + real(r8), allocatable :: etrsha_out (:) ! diagnostic shaded leaf etr for output + + real(r8), allocatable :: tleaf (:) ! leaf temperature [K] + real(r8), allocatable :: ldew (:) ! depth of water on foliage [mm] + real(r8), allocatable :: ldew_rain (:) ! depth of rain on foliage [mm] + real(r8), allocatable :: ldew_snow (:) ! depth of rain on foliage [mm] + real(r8), allocatable :: fwet_snow (:) ! vegetation snow fractional cover [-] + real(r8), allocatable :: sag (:) ! non dimensional snow age [-] + real(r8), allocatable :: scv (:) ! snow cover, water equivalent [mm] + real(r8), allocatable :: snowdp (:) ! snow depth [meter] + real(r8), allocatable :: fveg (:) ! fraction of vegetation cover + real(r8), allocatable :: fsno (:) ! fraction of snow cover on ground + real(r8), allocatable :: sigf (:) ! fraction of veg cover, excluding snow-covered veg [-] + real(r8), allocatable :: green (:) ! leaf greenness + real(r8), allocatable :: tlai (:) ! leaf area index + real(r8), allocatable :: lai (:) ! leaf area index + real(r8), allocatable :: laisun (:) ! leaf area index for sunlit leaf + real(r8), allocatable :: laisha (:) ! leaf area index for shaded leaf + real(r8), allocatable :: tsai (:) ! stem area index + real(r8), allocatable :: sai (:) ! stem area index +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + real(r8), allocatable :: lai_enftemp (:) ! lai for needleleaf evergreen temperate tree (m2 m-2) + real(r8), allocatable :: lai_enfboreal (:) ! lai for needleleaf evergreen boreal tree (m2 m-2) + real(r8), allocatable :: lai_dnfboreal (:) ! lai for needleleaf deciduous boreal tree (m2 m-2) + real(r8), allocatable :: lai_ebftrop (:) ! lai for broadleaf evergreen tropical tree (m2 m-2) + real(r8), allocatable :: lai_ebftemp (:) ! lai for broadleaf evergreen temperate tree (m2 m-2) + real(r8), allocatable :: lai_dbftrop (:) ! lai for broadleaf deciduous tropical tree (m2 m-2) + real(r8), allocatable :: lai_dbftemp (:) ! lai for broadleaf deciduous temperate tree (m2 m-2) + real(r8), allocatable :: lai_dbfboreal (:) ! lai for broadleaf deciduous boreal tree (m2 m-2) + real(r8), allocatable :: lai_ebstemp (:) ! lai for broadleaf evergreen temperate shrub (m2 m-2) + real(r8), allocatable :: lai_dbstemp (:) ! lai for broadleaf deciduous temperate shrub (m2 m-2) + real(r8), allocatable :: lai_dbsboreal (:) ! lai for broadleaf deciduous boreal shrub (m2 m-2) + real(r8), allocatable :: lai_c3arcgrass(:) ! lai for c3 arctic grass (m2 m-2) + real(r8), allocatable :: lai_c3grass (:) ! lai for c3 grass (m2 m-2) + real(r8), allocatable :: lai_c4grass (:) ! lai for c4 grass (m2 m-2) +#endif + + real(r8), allocatable :: coszen (:) ! cosine of solar zenith angle + real(r8), allocatable :: alb (:,:,:) ! averaged albedo [-] + real(r8), allocatable :: ssun (:,:,:) ! sunlit canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssha (:,:,:) ! shaded canopy absorption for solar radiation (0-1) + real(r8), allocatable :: ssoi (:,:,:) ! soil absorption for solar radiation (0-1) + real(r8), allocatable :: ssno (:,:,:) ! snow absorption for solar radiation (0-1) +#ifdef HYPERSPECTRAL + ! new variables for hyperspectral scheme + real(r8), allocatable :: alb_hires (:,:,:) ! averaged albedo [-] + real(r8), allocatable :: reflectance_out (:,:,:) ! averaged albedo [-] + real(r8), allocatable :: transmittance_out (:,:,:) ! averaged albedo [-] +#endif + real(r8), allocatable :: thermk (:) ! canopy gap fraction for tir radiation + real(r8), allocatable :: extkb (:) ! (k, g(mu)/mu) direct solar extinction coefficient + real(r8), allocatable :: extkd (:) ! diffuse and scattered diffuse PAR extinction coefficient + real(r8), allocatable :: zwt (:) ! the depth to water table [m] + real(r8), allocatable :: wa (:) ! water storage in aquifer [mm] + real(r8), allocatable :: wetwat (:) ! water storage in wetland [mm] + real(r8), allocatable :: wat (:) ! total water storage [mm] + real(r8), allocatable :: wdsrf (:) ! depth of surface water [mm] + real(r8), allocatable :: rss (:) ! soil surface resistance [s/m] + + real(r8), allocatable :: t_lake (:,:) ! lake layer temperature [K] + real(r8), allocatable :: lake_icefrac(:,:) ! lake mass fraction of lake layer that is frozen + real(r8), allocatable :: savedtke1 (:) ! top level eddy conductivity (W/m K) + + real(r8), allocatable :: snw_rds (:,:) ! effective grain radius (col,lyr) [microns, m-6] + real(r8), allocatable :: mss_bcpho (:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_bcphi (:,:) ! mass of hydrophillic BC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocpho (:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_ocphi (:,:) ! mass of hydrophillic OC in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst1 (:,:) ! mass of dust species 1 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst2 (:,:) ! mass of dust species 2 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst3 (:,:) ! mass of dust species 3 in snow (col,lyr) [kg] + real(r8), allocatable :: mss_dst4 (:,:) ! mass of dust species 4 in snow (col,lyr) [kg] + real(r8), allocatable :: ssno_lyr(:,:,:,:) ! snow layer absorption [-] + + real(r8), allocatable :: trad (:) ! radiative temperature of surface [K] + real(r8), allocatable :: tref (:) ! 2 m height air temperature [kelvin] + real(r8), allocatable :: t2m_wmo (:) ! 2 m WMO air temperature [kelvin] + real(r8), allocatable :: qref (:) ! 2 m height air specific humidity + real(r8), allocatable :: qsfc (:) ! bulk surface/ground specific humidity [kg/kg] + real(r8), allocatable :: rst (:) ! canopy stomatal resistance (s/m) + real(r8), allocatable :: emis (:) ! averaged bulk surface emissivity + real(r8), allocatable :: z0m (:) ! effective roughness [m] + real(r8), allocatable :: displa (:) ! zero displacement height [m] + real(r8), allocatable :: zol (:) ! dimensionless height (z/L) used in Monin-Obukhov theory + real(r8), allocatable :: rib (:) ! bulk Richardson number in surface layer + real(r8), allocatable :: ustar (:) ! u* in similarity theory [m/s] + real(r8), allocatable :: qstar (:) ! q* in similarity theory [kg/kg] + real(r8), allocatable :: tstar (:) ! t* in similarity theory [K] + real(r8), allocatable :: fm (:) ! integral of profile FUNCTION for momentum + real(r8), allocatable :: fh (:) ! integral of profile FUNCTION for heat + real(r8), allocatable :: fq (:) ! integral of profile FUNCTION for moisture + + real(r8), allocatable :: irrig_rate (:) ! irrigation rate [mm s-1] + real(r8), allocatable :: actual_irrig (:) ! actual irrigation amount [kg/m2] + real(r8), allocatable :: deficit_irrig (:) ! irrigation amount [kg/m2] + real(r8), allocatable :: sum_irrig (:) ! total irrigation amount [kg/m2] + real(r8), allocatable :: sum_deficit_irrig (:) ! total irrigation amount demand [kg/m2] + real(r8), allocatable :: sum_irrig_count (:) ! total irrigation counts [-] + integer , allocatable :: n_irrig_steps_left (:) ! left steps for once irrigation [-] + real(r8), allocatable :: waterstorage (:) ! water of water storage pool (from reservoir and river) [kg/m2] + real(r8), allocatable :: waterstorage_supply (:) ! irrigation supply from water storage pool [kg/m2] + real(r8), allocatable :: groundwater_demand (:) ! irrigation demand for ground water [kg/m2] + real(r8), allocatable :: groundwater_supply (:) ! irrigation supply from ground water [kg/m2] + real(r8), allocatable :: reservoirriver_demand(:)! irrigation demand for reservoir or river [kg/m2] + real(r8), allocatable :: reservoirriver_supply(:)! irrigation supply from reservoir or river [kg/m2] + real(r8), allocatable :: reservoir_supply (:)! irrigation supply from reservoir [kg/m2] + real(r8), allocatable :: river_supply (:)! irrigation supply from river [kg/m2] + real(r8), allocatable :: runoff_supply (:)! irrigation supply from runoff [kg/m2] + real(r8), allocatable :: tairday (:) ! daily mean temperature [degree C] + real(r8), allocatable :: usday (:) ! daily mean wind component in eastward direction [m/s] + real(r8), allocatable :: vsday (:) ! daily mean wind component in northward direction [m/s] + real(r8), allocatable :: pairday (:) ! daily mean pressure [kPa] + real(r8), allocatable :: rnetday (:) ! daily net radiation flux [MJ/m2/day] + real(r8), allocatable :: fgrndday (:) ! daily ground heat flux [MJ/m2/day] + real(r8), allocatable :: potential_evapotranspiration (:) ! daily potential evapotranspiration [mm/day] + + integer , allocatable :: irrig_method_corn (:) ! irrigation method for corn (0-3) + integer , allocatable :: irrig_method_swheat (:) ! irrigation method for spring wheat (0-3) + integer , allocatable :: irrig_method_wwheat (:) ! irrigation method for winter wheat (0-3) + integer , allocatable :: irrig_method_soybean (:) ! irrigation method for soybean (0-3) + integer , allocatable :: irrig_method_cotton (:) ! irrigation method for cotton (0-3) + integer , allocatable :: irrig_method_rice1 (:) ! irrigation method for rice1 (0-3) + integer , allocatable :: irrig_method_rice2 (:) ! irrigation method for rice2 (0-3) + integer , allocatable :: irrig_method_sugarcane (:) ! irrigation method for sugarcane (0-3) + + real(r8), allocatable :: irrig_gw_alloc (:) ! irrigation demand allocated to groundwater [kg/kg] + real(r8), allocatable :: irrig_sw_alloc (:) ! irrigation demand allocated to surfacewater [kg/kg] + real(r8), allocatable :: zwt_stand (:) ! initial the depth to water table [m] + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_TimeVariables + PUBLIC :: deallocate_TimeVariables + PUBLIC :: READ_TimeVariables + PUBLIC :: WRITE_TimeVariables +#ifdef RangeCheck + PUBLIC :: check_TimeVariables +#endif + + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_TimeVariables + !-------------------------------------------------------------------- + ! Allocates memory for CoLM 1d [numpatch] variables + !-------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_MPAS_MPI + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + allocate (z_sno (maxsnl+1:0, numpatch)); z_sno (:,:) = spval + allocate (dz_sno (maxsnl+1:0, numpatch)); dz_sno (:,:) = spval + allocate (t_soisno (maxsnl+1:nl_soil,numpatch)); t_soisno (:,:) = spval + allocate (wliq_soisno(maxsnl+1:nl_soil,numpatch)); wliq_soisno (:,:) = spval + allocate (wice_soisno(maxsnl+1:nl_soil,numpatch)); wice_soisno (:,:) = spval + allocate (smp (1:nl_soil,numpatch)); smp (:,:) = spval + allocate (hk (1:nl_soil,numpatch)); hk (:,:) = spval + allocate (h2osoi (1:nl_soil,numpatch)); h2osoi (:,:) = spval + allocate (rootr (1:nl_soil,numpatch)); rootr (:,:) = spval + allocate (rootflux (1:nl_soil,numpatch)); rootflux (:,:) = spval +!Plant Hydraulic variables + allocate (vegwp (1:nvegwcs,numpatch)); vegwp (:,:) = spval + allocate (gs0sun (numpatch)); gs0sun (:) = spval + allocate (gs0sha (numpatch)); gs0sha (:) = spval +!END plant hydraulic variables +!Ozone Stress variables + allocate (o3coefv_sun (numpatch)); o3coefv_sun (:) = spval + allocate (o3coefv_sha (numpatch)); o3coefv_sha (:) = spval + allocate (o3coefg_sun (numpatch)); o3coefg_sun (:) = spval + allocate (o3coefg_sha (numpatch)); o3coefg_sha (:) = spval + allocate (lai_old (numpatch)); lai_old (:) = spval + allocate (o3uptakesun (numpatch)); o3uptakesun (:) = spval + allocate (o3uptakesha (numpatch)); o3uptakesha (:) = spval +!END ozone stress variables + + allocate (rstfacsun_out (numpatch)); rstfacsun_out (:) = spval + allocate (rstfacsha_out (numpatch)); rstfacsha_out (:) = spval + allocate (gssun_out (numpatch)); gssun_out (:) = spval + allocate (gssha_out (numpatch)); gssha_out (:) = spval + allocate (assimsun_out (numpatch)); assimsun_out (:) = spval + allocate (assimsha_out (numpatch)); assimsha_out (:) = spval + allocate (etrsun_out (numpatch)); etrsun_out (:) = spval + allocate (etrsha_out (numpatch)); etrsha_out (:) = spval + + allocate (t_grnd (numpatch)); t_grnd (:) = spval + allocate (tleaf (numpatch)); tleaf (:) = spval + allocate (ldew (numpatch)); ldew (:) = spval + allocate (ldew_rain (numpatch)); ldew_rain (:) = spval + allocate (ldew_snow (numpatch)); ldew_snow (:) = spval + allocate (fwet_snow (numpatch)); fwet_snow (:) = spval + allocate (sag (numpatch)); sag (:) = spval + allocate (scv (numpatch)); scv (:) = spval + allocate (snowdp (numpatch)); snowdp (:) = spval + allocate (fveg (numpatch)); fveg (:) = spval + allocate (fsno (numpatch)); fsno (:) = spval + allocate (sigf (numpatch)); sigf (:) = spval + allocate (green (numpatch)); green (:) = spval + allocate (tlai (numpatch)); tlai (:) = spval + allocate (lai (numpatch)); lai (:) = spval + allocate (laisun (numpatch)); laisun (:) = spval + allocate (laisha (numpatch)); laisha (:) = spval + allocate (tsai (numpatch)); tsai (:) = spval + allocate (sai (numpatch)); sai (:) = spval + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + allocate (lai_enftemp (numpatch)); lai_enftemp (:) = spval + allocate (lai_enfboreal (numpatch)); lai_enfboreal (:) = spval + allocate (lai_dnfboreal (numpatch)); lai_dnfboreal (:) = spval + allocate (lai_ebftrop (numpatch)); lai_ebftrop (:) = spval + allocate (lai_ebftemp (numpatch)); lai_ebftemp (:) = spval + allocate (lai_dbftrop (numpatch)); lai_dbftrop (:) = spval + allocate (lai_dbftemp (numpatch)); lai_dbftemp (:) = spval + allocate (lai_dbfboreal (numpatch)); lai_dbfboreal (:) = spval + allocate (lai_ebstemp (numpatch)); lai_ebstemp (:) = spval + allocate (lai_dbstemp (numpatch)); lai_dbstemp (:) = spval + allocate (lai_dbsboreal (numpatch)); lai_dbsboreal (:) = spval + allocate (lai_c3arcgrass (numpatch)); lai_c3arcgrass(:) = spval + allocate (lai_c3grass (numpatch)); lai_c3grass (:) = spval + allocate (lai_c4grass (numpatch)); lai_c4grass (:) = spval +#endif + allocate (coszen (numpatch)); coszen (:) = spval + allocate (alb (2,2,numpatch)); alb (:,:,:) = spval + allocate (ssun (2,2,numpatch)); ssun (:,:,:) = spval + allocate (ssha (2,2,numpatch)); ssha (:,:,:) = spval + allocate (ssoi (2,2,numpatch)); ssoi (:,:,:) = spval + allocate (ssno (2,2,numpatch)); ssno (:,:,:) = spval +#ifdef HYPERSPECTRAL + ! high resolution parameters + allocate (alb_hires (211,2,numpatch)); alb_hires (:,:,:) = spval + allocate (reflectance_out (211,0:15,numpatch)); reflectance_out (:,:,:) = spval + allocate (transmittance_out (211,0:15,numpatch)); transmittance_out(:,:,:) = spval +#endif + allocate (thermk (numpatch)); thermk (:) = spval + allocate (extkb (numpatch)); extkb (:) = spval + allocate (extkd (numpatch)); extkd (:) = spval + allocate (zwt (numpatch)); zwt (:) = spval + allocate (wa (numpatch)); wa (:) = spval + allocate (wetwat (numpatch)); wetwat (:) = spval + allocate (wat (numpatch)); wat (:) = spval + allocate (wdsrf (numpatch)); wdsrf (:) = spval + allocate (rss (numpatch)); rss (:) = spval + allocate (t_lake (nl_lake,numpatch)); t_lake (:,:) = spval + allocate (lake_icefrac (nl_lake,numpatch)); lake_icefrac(:,:) = spval + allocate (savedtke1 (numpatch)); savedtke1 (:) = spval + + allocate (snw_rds (maxsnl+1:0,numpatch)); snw_rds (:,:) = spval + allocate (mss_bcpho (maxsnl+1:0,numpatch)); mss_bcpho (:,:) = spval + allocate (mss_bcphi (maxsnl+1:0,numpatch)); mss_bcphi (:,:) = spval + allocate (mss_ocpho (maxsnl+1:0,numpatch)); mss_ocpho (:,:) = spval + allocate (mss_ocphi (maxsnl+1:0,numpatch)); mss_ocphi (:,:) = spval + allocate (mss_dst1 (maxsnl+1:0,numpatch)); mss_dst1 (:,:) = spval + allocate (mss_dst2 (maxsnl+1:0,numpatch)); mss_dst2 (:,:) = spval + allocate (mss_dst3 (maxsnl+1:0,numpatch)); mss_dst3 (:,:) = spval + allocate (mss_dst4 (maxsnl+1:0,numpatch)); mss_dst4 (:,:) = spval + allocate (ssno_lyr (2,2,maxsnl+1:1,numpatch)); ssno_lyr(:,:,:,:) = spval + + allocate (trad (numpatch)); trad (:) = spval + allocate (tref (numpatch)); tref (:) = spval + allocate (t2m_wmo (numpatch)); t2m_wmo (:) = spval + allocate (qref (numpatch)); qref (:) = spval + allocate (qsfc (numpatch)); qsfc (:) = spval + allocate (rst (numpatch)); rst (:) = spval + allocate (emis (numpatch)); emis (:) = spval + allocate (z0m (numpatch)); z0m (:) = spval + allocate (displa (numpatch)); displa (:) = spval + allocate (zol (numpatch)); zol (:) = spval + allocate (rib (numpatch)); rib (:) = spval + allocate (ustar (numpatch)); ustar (:) = spval + allocate (qstar (numpatch)); qstar (:) = spval + allocate (tstar (numpatch)); tstar (:) = spval + allocate (fm (numpatch)); fm (:) = spval + allocate (fh (numpatch)); fh (:) = spval + allocate (fq (numpatch)); fq (:) = spval + + allocate ( irrig_rate (numpatch)); irrig_rate (:) = spval + allocate ( deficit_irrig (numpatch)); deficit_irrig (:) = spval + allocate ( actual_irrig (numpatch)); actual_irrig (:) = spval + allocate ( sum_irrig (numpatch)); sum_irrig (:) = spval + allocate ( sum_deficit_irrig (numpatch)); sum_deficit_irrig (:) = spval + allocate ( sum_irrig_count (numpatch)); sum_irrig_count (:) = spval + allocate ( n_irrig_steps_left (numpatch)); n_irrig_steps_left (:) = spval_i4 + allocate ( waterstorage (numpatch)); waterstorage (:) = spval + allocate ( waterstorage_supply (numpatch)); waterstorage_supply (:) = spval + allocate ( groundwater_demand (numpatch)); groundwater_demand (:) = spval + allocate ( groundwater_supply (numpatch)); groundwater_supply (:) = spval + allocate ( reservoirriver_demand (numpatch)); reservoirriver_demand (:) = spval + allocate ( reservoirriver_supply (numpatch)); reservoirriver_supply (:) = spval + allocate ( reservoir_supply (numpatch)); reservoir_supply (:) = spval + allocate ( river_supply (numpatch)); river_supply (:) = spval + allocate ( runoff_supply (numpatch)); runoff_supply (:) = spval + allocate ( tairday (numpatch)); tairday (:) = spval + allocate ( usday (numpatch)); usday (:) = spval + allocate ( vsday (numpatch)); vsday (:) = spval + allocate ( pairday (numpatch)); pairday (:) = spval + allocate ( rnetday (numpatch)); rnetday (:) = spval + allocate ( fgrndday (numpatch)); fgrndday (:) = spval + allocate ( potential_evapotranspiration(numpatch)); potential_evapotranspiration(:) = spval + + allocate ( irrig_method_corn (numpatch)); irrig_method_corn (:) = spval_i4 + allocate ( irrig_method_swheat (numpatch)); irrig_method_swheat (:) = spval_i4 + allocate ( irrig_method_wwheat (numpatch)); irrig_method_wwheat (:) = spval_i4 + allocate ( irrig_method_soybean (numpatch)); irrig_method_soybean (:) = spval_i4 + allocate ( irrig_method_cotton (numpatch)); irrig_method_cotton (:) = spval_i4 + allocate ( irrig_method_rice1 (numpatch)); irrig_method_rice1 (:) = spval_i4 + allocate ( irrig_method_rice2 (numpatch)); irrig_method_rice2 (:) = spval_i4 + allocate ( irrig_method_sugarcane (numpatch)); irrig_method_sugarcane (:) = spval_i4 + + allocate ( irrig_gw_alloc (numpatch)); irrig_gw_alloc (:) = spval + allocate ( irrig_sw_alloc (numpatch)); irrig_sw_alloc (:) = spval + allocate ( zwt_stand (numpatch)); zwt_stand (:) = spval + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL allocate_PFTimeVariables +#endif + +#ifdef BGC + CALL allocate_BGCTimeVariables +#endif + +#ifdef CatchLateralFlow + CALL allocate_CatchTimeVariables +#endif + +#ifdef GridRiverLakeFlow + CALL allocate_GridRiverLakeTimeVars +#endif + +#ifdef URBAN_MODEL + CALL allocate_UrbanTimeVariables +#endif + +#ifdef EXTERNAL_LAKE + CALL allocate_LakeTimeVars +#endif + +#ifdef DataAssimilation + CALL allocate_DATimeVariables +#endif + + END SUBROUTINE allocate_TimeVariables + + + + SUBROUTINE deallocate_TimeVariables () + + USE MOD_MPAS_MPI + USE MOD_LandPatch, only: numpatch + IMPLICIT NONE + + !-------------------------------------------------------------------- + ! Deallocates memory for CoLM 1d [numpatch] variables + !-------------------------------------------------------------------- + + IF (.true.) THEN + + IF (numpatch > 0) THEN + + deallocate (z_sno ) + deallocate (dz_sno ) + deallocate (t_soisno ) + deallocate (wliq_soisno ) + deallocate (wice_soisno ) + deallocate (smp ) + deallocate (hk ) + deallocate (h2osoi ) + deallocate (rootr ) + deallocate (rootflux ) +!Plant Hydraulic variables + deallocate (vegwp ) + deallocate (gs0sun ) + deallocate (gs0sha ) +!END plant hydraulic variables +!Ozone stress variables + deallocate (o3coefv_sun ) ! Ozone stress factor for photosynthesis on sunlit leaf + deallocate (o3coefv_sha ) ! Ozone stress factor for photosynthesis on shaded leaf + deallocate (o3coefg_sun ) ! Ozone stress factor for stomata on sunlit leaf + deallocate (o3coefg_sha ) ! Ozone stress factor for stomata on shaded leaf + deallocate (lai_old ) ! lai in last time step + deallocate (o3uptakesun ) ! Ozone does, sunlit leaf (mmol O3/m^2) + deallocate (o3uptakesha ) ! Ozone does, shaded leaf (mmol O3/m^2) +!END Ozone stress variables + deallocate (rstfacsun_out ) + deallocate (rstfacsha_out ) + deallocate (gssun_out ) + deallocate (gssha_out ) + deallocate (assimsun_out ) + deallocate (assimsha_out ) + deallocate (etrsun_out ) + deallocate (etrsha_out ) + + deallocate (t_grnd ) + deallocate (tleaf ) + deallocate (ldew ) + deallocate (ldew_rain ) + deallocate (ldew_snow ) + deallocate (fwet_snow ) + deallocate (sag ) + deallocate (scv ) + deallocate (snowdp ) + deallocate (fveg ) + deallocate (fsno ) + deallocate (sigf ) + deallocate (green ) + deallocate (tlai ) + deallocate (lai ) + deallocate (laisun ) + deallocate (laisha ) + deallocate (tsai ) + deallocate (sai ) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + deallocate (lai_enftemp ) + deallocate (lai_enfboreal ) + deallocate (lai_dnfboreal ) + deallocate (lai_ebftrop ) + deallocate (lai_ebftemp ) + deallocate (lai_dbftrop ) + deallocate (lai_dbftemp ) + deallocate (lai_dbfboreal ) + deallocate (lai_ebstemp ) + deallocate (lai_dbstemp ) + deallocate (lai_dbsboreal ) + deallocate (lai_c3arcgrass ) + deallocate (lai_c3grass ) + deallocate (lai_c4grass ) +#endif + deallocate (coszen ) + deallocate (alb ) + deallocate (ssun ) + deallocate (ssha ) + deallocate (ssoi ) + deallocate (ssno ) + deallocate (thermk ) + deallocate (extkb ) + deallocate (extkd ) + deallocate (zwt ) + deallocate (wa ) + deallocate (wetwat ) + deallocate (wat ) + deallocate (wdsrf ) + deallocate (rss ) + + deallocate (t_lake ) ! new lake scheme + deallocate (lake_icefrac ) ! new lake scheme + deallocate (savedtke1 ) ! new lake scheme + + deallocate (snw_rds ) + deallocate (mss_bcpho ) + deallocate (mss_bcphi ) + deallocate (mss_ocpho ) + deallocate (mss_ocphi ) + deallocate (mss_dst1 ) + deallocate (mss_dst2 ) + deallocate (mss_dst3 ) + deallocate (mss_dst4 ) + deallocate (ssno_lyr ) + + deallocate (trad ) + deallocate (tref ) + deallocate (t2m_wmo ) + deallocate (qref ) + deallocate (qsfc ) + deallocate (rst ) + deallocate (emis ) + deallocate (z0m ) + deallocate (displa ) + deallocate (zol ) + deallocate (rib ) + deallocate (ustar ) + deallocate (qstar ) + deallocate (tstar ) + deallocate (fm ) + deallocate (fh ) + deallocate (fq ) + + deallocate (irrig_rate ) + deallocate (deficit_irrig ) + deallocate (actual_irrig ) + deallocate (sum_irrig ) + deallocate (sum_deficit_irrig ) + deallocate (sum_irrig_count ) + deallocate (n_irrig_steps_left ) + deallocate (waterstorage ) + deallocate (waterstorage_supply ) + deallocate (groundwater_demand ) + deallocate (groundwater_supply ) + deallocate (reservoirriver_demand ) + deallocate (reservoirriver_supply ) + deallocate (reservoir_supply ) + deallocate (river_supply ) + deallocate (runoff_supply ) + deallocate (tairday ) + deallocate (usday ) + deallocate (vsday ) + deallocate (pairday ) + deallocate (rnetday ) + deallocate (fgrndday ) + deallocate (potential_evapotranspiration) + + deallocate (irrig_method_corn ) + deallocate (irrig_method_swheat ) + deallocate (irrig_method_wwheat ) + deallocate (irrig_method_soybean ) + deallocate (irrig_method_cotton ) + deallocate (irrig_method_rice1 ) + deallocate (irrig_method_rice2 ) + deallocate (irrig_method_sugarcane ) + + deallocate (irrig_gw_alloc ) + deallocate (irrig_sw_alloc ) + deallocate (zwt_stand ) + + ENDIF + ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL deallocate_PFTimeVariables +#endif + +#if (defined BGC) + CALL deallocate_BGCTimeVariables +#endif + +#ifdef CatchLateralFlow + CALL deallocate_CatchTimeVariables +#endif + +#ifdef GridRiverLakeFlow + CALL deallocate_GridRiverLakeTimeVars +#endif + +#if (defined URBAN_MODEL) + CALL deallocate_UrbanTimeVariables +#endif + +#ifdef EXTERNAL_LAKE + CALL deallocate_LakeTimeVars +#endif + +#ifdef DataAssimilation + CALL deallocate_DATimeVariables +#endif + + END SUBROUTINE deallocate_TimeVariables + + + !--------------------------------------- + FUNCTION save_to_restart (idate, deltim, itstamp, ptstamp, etstamp) result(rwrite) + + USE MOD_Namelist + IMPLICIT NONE + + logical :: rwrite + + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + type(timestamp), intent(in) :: itstamp, ptstamp, etstamp + + + ! added by yuan, 08/31/2014 + SELECTCASE (trim(adjustl(DEF_WRST_FREQ))) + CASE ('TIMESTEP') + rwrite = .true. + CASE ('HOURLY') + rwrite = isendofhour (idate, deltim) + CASE ('DAILY') + rwrite = isendofday(idate, deltim) + CASE ('MONTHLY') + rwrite = isendofmonth(idate, deltim) + CASE ('YEARLY') + rwrite = isendofyear(idate, deltim) + CASE default + rwrite = .false. + write(*,*) 'Warning: Please USE one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for restart frequency.' + write(*,*) ' Set to FALSE by default. ' + ENDSELECT + + IF (rwrite) THEN + rwrite = ((ptstamp <= itstamp) .or. isendofyear(idate,deltim)) + ENDIF + + rwrite = rwrite .or. (.not. (itstamp < etstamp)) + + END FUNCTION save_to_restart + + + SUBROUTINE WRITE_TimeVariables (idate, lc_year, site, dir_restart) + + !==================================================================== + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !==================================================================== + + USE MOD_MPAS_MPI + USE MOD_Namelist, only: DEF_REST_CompressLevel, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, & + DEF_USE_IRRIGATION, DEF_USE_Dynamic_Lake, SITE_landtype + USE MOD_LandPatch + USE MOD_NetCDFVector + USE MOD_Utils, only: make_directory + USE MOD_Vars_Global + USE MOD_Vars_TimeInvariants, only: dz_lake + USE MOD_Const_LC, only: patchtypes + IMPLICIT NONE + + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year !year of land cover type data + character(len=*), intent(in) :: site + character(len=*), intent(in) :: dir_restart + + ! Local variables + character(len=256) :: file_restart + character(len=256) :: file_restart_vector +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef MPAS_EMBEDDED_COLM + character(len=256) :: file_restart_pft +#endif +#endif + character(len=14) :: cdate + character(len=256) :: cyear !character for lc_year + integer :: compress + + compress = DEF_REST_CompressLevel + + ! land cover type year + write(cyear,'(i4.4)') lc_year + write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) + + IF (mpas_is_root) THEN + CALL make_directory(trim(dir_restart)//'/'//trim(cdate)) + ENDIF +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-variable restart directory creation') +#endif + + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + file_restart_vector = file_restart + CALL ncio_begin_distributed_write(file_restart_vector) +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef MPAS_EMBEDDED_COLM + file_restart_pft = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'// & + trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL ncio_begin_distributed_write(file_restart_pft) +#endif +#endif + +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif + + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snow', -maxsnl ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'snowp1', -maxsnl+1 ) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soilsnow', nl_soil-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'soil', nl_soil) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'lake', nl_lake) + +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_define_dimension_vector (file_restart, landpatch, 'vegnodes', nvegwcs) +ENDIF + + CALL ncio_define_dimension_vector (file_restart, landpatch, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2) +#ifdef HYPERSPECTRAL + CALL ncio_define_dimension_vector (file_restart, landpatch, 'wavelength', 211) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'PFT', 16) +#endif + ! Time-varying state variables which required by restart run + CALL ncio_write_vector (file_restart, 'z_sno ' , 'snow', -maxsnl, 'patch', landpatch, z_sno , compress) ! node depth [m] + CALL ncio_write_vector (file_restart, 'dz_sno ' , 'snow', -maxsnl, 'patch', landpatch, dz_sno, compress) ! interface depth [m] + CALL ncio_write_vector (file_restart, 't_soisno' , 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, t_soisno , compress) ! soil temperature [K] + CALL ncio_write_vector (file_restart, 'wliq_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wliq_soisno, compress) ! liquid water in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'wice_soisno', 'soilsnow', nl_soil-maxsnl, 'patch', landpatch, wice_soisno, compress) ! ice lens in layers [kg/m2] + CALL ncio_write_vector (file_restart, 'smp', 'soil', nl_soil, 'patch', landpatch, smp, compress) ! soil matrix potential [mm] + CALL ncio_write_vector (file_restart, 'hk', 'soil', nl_soil, 'patch', landpatch, hk, compress) ! hydraulic conductivity [mm h2o/s] +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_write_vector (file_restart, 'vegwp', 'vegnodes', nvegwcs, 'patch', landpatch, vegwp, compress) ! vegetation water potential [mm] + CALL ncio_write_vector (file_restart, 'gs0sun', 'patch', landpatch, gs0sun, compress) ! working copy of sunlit stomata conductance + CALL ncio_write_vector (file_restart, 'gs0sha', 'patch', landpatch, gs0sha, compress) ! working copy of shalit stomata conductance +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_write_vector (file_restart, 'lai_old ', 'patch', landpatch, lai_old , compress) + CALL ncio_write_vector (file_restart, 'o3uptakesun', 'patch', landpatch, o3uptakesun, compress) + CALL ncio_write_vector (file_restart, 'o3uptakesha', 'patch', landpatch, o3uptakesha, compress) + CALL ncio_write_vector (file_restart, 'o3coefv_sun', 'patch', landpatch, o3coefv_sun, compress) + CALL ncio_write_vector (file_restart, 'o3coefv_sha', 'patch', landpatch, o3coefv_sha, compress) + CALL ncio_write_vector (file_restart, 'o3coefg_sun', 'patch', landpatch, o3coefg_sun, compress) + CALL ncio_write_vector (file_restart, 'o3coefg_sha', 'patch', landpatch, o3coefg_sha, compress) +ENDIF + CALL ncio_write_vector (file_restart, 't_grnd ' , 'patch', landpatch, t_grnd , compress) ! ground surface temperature [K] + CALL ncio_write_vector (file_restart, 'tleaf ' , 'patch', landpatch, tleaf , compress) ! leaf temperature [K] + CALL ncio_write_vector (file_restart, 'ldew ' , 'patch', landpatch, ldew , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_rain' , 'patch', landpatch, ldew_rain , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'ldew_snow' , 'patch', landpatch, ldew_snow , compress) ! depth of water on foliage [mm] + CALL ncio_write_vector (file_restart, 'fwet_snow' , 'patch', landpatch, fwet_snow , compress) ! vegetation snow fractional cover [-] + CALL ncio_write_vector (file_restart, 'sag ' , 'patch', landpatch, sag , compress) ! non dimensional snow age [-] + CALL ncio_write_vector (file_restart, 'scv ' , 'patch', landpatch, scv , compress) ! snow cover, water equivalent [mm] + CALL ncio_write_vector (file_restart, 'snowdp ' , 'patch', landpatch, snowdp , compress) ! snow depth [meter] + CALL ncio_write_vector (file_restart, 'fveg ' , 'patch', landpatch, fveg , compress) ! fraction of vegetation cover + CALL ncio_write_vector (file_restart, 'fsno ' , 'patch', landpatch, fsno , compress) ! fraction of snow cover on ground + CALL ncio_write_vector (file_restart, 'sigf ' , 'patch', landpatch, sigf , compress) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_write_vector (file_restart, 'green ' , 'patch', landpatch, green , compress) ! leaf greenness + CALL ncio_write_vector (file_restart, 'lai ' , 'patch', landpatch, lai , compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'tlai ' , 'patch', landpatch, tlai , compress) ! leaf area index + CALL ncio_write_vector (file_restart, 'sai ' , 'patch', landpatch, sai , compress) ! stem area index + CALL ncio_write_vector (file_restart, 'tsai ' , 'patch', landpatch, tsai , compress) ! stem area index + CALL ncio_write_vector (file_restart, 'coszen ' , 'patch', landpatch, coszen , compress) ! cosine of solar zenith angle + CALL ncio_write_vector (file_restart, 'alb ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, alb , compress) ! averaged albedo [-] + CALL ncio_write_vector (file_restart, 'ssun ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssun, compress) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssha ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssha, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssoi ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssoi, compress) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_write_vector (file_restart, 'ssno ' , 'band', 2, 'rtyp', 2, 'patch', landpatch, ssno, compress) ! shaded canopy absorption for solar radiation (0-1) +#ifdef HYPERSPECTRAL + CALL ncio_write_vector (file_restart, 'alb_hires' , 'wavelength', 211, 'rtyp', 2, 'patch', landpatch, alb_hires , compress) ! averaged albedo [-] + CALL ncio_write_vector (file_restart, 'reflectance_out' , 'wavelength', 211, 'PFT', 16, 'patch', landpatch, reflectance_out , compress) ! averaged albedo [-] + CALL ncio_write_vector (file_restart, 'transmittance_out', 'wavelength', 211, 'PFT', 16, 'patch', landpatch, transmittance_out, compress) ! averaged albedo [-] +#endif + + CALL ncio_write_vector (file_restart, 'thermk ' , 'patch', landpatch, thermk , compress) ! canopy gap fraction for tir radiation + CALL ncio_write_vector (file_restart, 'extkb ' , 'patch', landpatch, extkb , compress) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_write_vector (file_restart, 'extkd ' , 'patch', landpatch, extkd , compress) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_write_vector (file_restart, 'zwt ' , 'patch', landpatch, zwt , compress) ! the depth to water table [m] + CALL ncio_write_vector (file_restart, 'wa ' , 'patch', landpatch, wa , compress) ! water storage in aquifer [mm] + CALL ncio_write_vector (file_restart, 'wetwat ' , 'patch', landpatch, wetwat , compress) ! water storage in wetland [mm] + CALL ncio_write_vector (file_restart, 'wdsrf ' , 'patch', landpatch, wdsrf , compress) ! depth of surface water [mm] + CALL ncio_write_vector (file_restart, 'rss ' , 'patch', landpatch, rss , compress) ! soil surface resistance [s/m] + +IF (DEF_USE_Dynamic_Lake) THEN + CALL ncio_write_vector (file_restart, 'dz_lake' , 'lake', nl_lake, 'patch', landpatch, dz_lake , compress) +ENDIF + CALL ncio_write_vector (file_restart, 't_lake ' , 'lake', nl_lake, 'patch', landpatch, t_lake , compress) + CALL ncio_write_vector (file_restart, 'lake_icefrc', 'lake', nl_lake, 'patch', landpatch, lake_icefrac, compress) + CALL ncio_write_vector (file_restart, 'savedtke1 ', 'patch', landpatch, savedtke1 , compress) + CALL ncio_write_vector (file_restart, 'snw_rds ', 'snow', -maxsnl, 'patch', landpatch, snw_rds , compress) + CALL ncio_write_vector (file_restart, 'mss_bcpho', 'snow', -maxsnl, 'patch', landpatch, mss_bcpho, compress) + CALL ncio_write_vector (file_restart, 'mss_bcphi', 'snow', -maxsnl, 'patch', landpatch, mss_bcphi, compress) + CALL ncio_write_vector (file_restart, 'mss_ocpho', 'snow', -maxsnl, 'patch', landpatch, mss_ocpho, compress) + CALL ncio_write_vector (file_restart, 'mss_ocphi', 'snow', -maxsnl, 'patch', landpatch, mss_ocphi, compress) + CALL ncio_write_vector (file_restart, 'mss_dst1 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst1 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst2 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst2 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst3 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst3 , compress) + CALL ncio_write_vector (file_restart, 'mss_dst4 ', 'snow', -maxsnl, 'patch', landpatch, mss_dst4 , compress) + CALL ncio_write_vector (file_restart, 'ssno_lyr', 'band', 2, 'rtyp', 2, 'snowp1', -maxsnl+1, 'patch', landpatch, ssno_lyr, compress) + + ! Additional va_vectorriables required by regional model (such as WRF ) RSM) + CALL ncio_write_vector (file_restart, 'trad ', 'patch', landpatch, trad , compress) ! radiative temperature of surface [K] + CALL ncio_write_vector (file_restart, 'tref ', 'patch', landpatch, tref , compress) ! 2 m height air temperature [kelvin] + CALL ncio_write_vector (file_restart, 'qref ', 'patch', landpatch, qref , compress) ! 2 m height air specific humidity + CALL ncio_write_vector (file_restart, 'rst ', 'patch', landpatch, rst , compress) ! canopy stomatal resistance (s/m) + CALL ncio_write_vector (file_restart, 'emis ', 'patch', landpatch, emis , compress) ! averaged bulk surface emissivity + CALL ncio_write_vector (file_restart, 'z0m ', 'patch', landpatch, z0m , compress) ! effective roughness [m] + CALL ncio_write_vector (file_restart, 'zol ', 'patch', landpatch, zol , compress) ! dimensionless height (z/L) used in Monin-Obukhov theory + CALL ncio_write_vector (file_restart, 'rib ', 'patch', landpatch, rib , compress) ! bulk Richardson number in surface layer + CALL ncio_write_vector (file_restart, 'ustar', 'patch', landpatch, ustar, compress) ! u* in similarity theory [m/s] + CALL ncio_write_vector (file_restart, 'qstar', 'patch', landpatch, qstar, compress) ! q* in similarity theory [kg/kg] + CALL ncio_write_vector (file_restart, 'tstar', 'patch', landpatch, tstar, compress) ! t* in similarity theory [K] + CALL ncio_write_vector (file_restart, 'fm ', 'patch', landpatch, fm , compress) ! integral of profile FUNCTION for momentum + CALL ncio_write_vector (file_restart, 'fh ', 'patch', landpatch, fh , compress) ! integral of profile FUNCTION for heat + CALL ncio_write_vector (file_restart, 'fq ', 'patch', landpatch, fq , compress) ! integral of profile FUNCTION for moisture + +IF (DEF_USE_IRRIGATION) THEN + CALL ncio_write_vector (file_restart, 'irrig_rate ' , 'patch',landpatch,irrig_rate , compress) + CALL ncio_write_vector (file_restart, 'sum_irrig ' , 'patch',landpatch,sum_irrig , compress) + CALL ncio_write_vector (file_restart, 'sum_deficit_irrig ' , 'patch',landpatch,sum_deficit_irrig , compress) + CALL ncio_write_vector (file_restart, 'sum_irrig_count ' , 'patch',landpatch,sum_irrig_count , compress) + CALL ncio_write_vector (file_restart, 'n_irrig_steps_left ' , 'patch',landpatch,n_irrig_steps_left , compress) + CALL ncio_write_vector (file_restart, 'waterstorage ' , 'patch',landpatch,waterstorage , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_corn ' , 'patch',landpatch,irrig_method_corn , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_swheat ' , 'patch',landpatch,irrig_method_swheat , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_wwheat ' , 'patch',landpatch,irrig_method_wwheat , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_soybean ' , 'patch',landpatch,irrig_method_soybean , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_cotton ' , 'patch',landpatch,irrig_method_cotton , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_rice1 ' , 'patch',landpatch,irrig_method_rice1 , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_rice2 ' , 'patch',landpatch,irrig_method_rice2 , compress) + CALL ncio_write_vector (file_restart, 'irrig_method_sugarcane' , 'patch',landpatch,irrig_method_sugarcane, compress) + CALL ncio_write_vector (file_restart, 'irrig_gw_alloc ' , 'patch',landpatch,irrig_gw_alloc , compress) + CALL ncio_write_vector (file_restart, 'irrig_sw_alloc ' , 'patch',landpatch,irrig_sw_alloc , compress) + CALL ncio_write_vector (file_restart, 'zwt_stand ' , 'patch',landpatch,zwt_stand , compress) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef SinglePoint + IF (patchtypes(SITE_landtype) == 0) THEN +#ifdef MPAS_EMBEDDED_COLM + file_restart = file_restart_pft +#else + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#endif + CALL WRITE_PFTimeVariables (file_restart) + ENDIF +#else +#ifdef MPAS_EMBEDDED_COLM + file_restart = file_restart_pft +#else + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#endif + CALL WRITE_PFTimeVariables (file_restart) +#endif +#endif + +#if (defined BGC) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_BGCTimeVariables (file_restart) +#endif + +#if (defined CatchLateralFlow) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_CatchTimeVariables (file_restart) +#endif + +#if (defined URBAN_MODEL) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_UrbanTimeVariables (file_restart) +#endif + +#ifdef EXTERNAL_LAKE + CALL WRITE_LakeTimeVars (idate, lc_year, site, dir_restart) +#endif + +#ifdef DataAssimilation + CALL WRITE_DATimeVariables (idate, lc_year, site, dir_restart) +#endif + +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL ncio_complete_distributed_write(file_restart_pft) +#endif +#endif + +#ifdef GridRiverLakeFlow + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL WRITE_GridRiverLakeTimeVars (file_restart) +#endif + + CALL ncio_complete_distributed_write(file_restart_vector) + + END SUBROUTINE WRITE_TimeVariables + + + SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart, require_complete_restart) + + !==================================================================== + ! Original version: Yongjiu Dai, September 15, 1999, 03/2014 + !==================================================================== + + USE MOD_Namelist + USE MOD_MPAS_MPI + USE MOD_NetCDFVector +#ifdef RangeCheck + USE MOD_RangeCheck +#endif + USE MOD_LandPatch + USE MOD_Vars_Global + USE MOD_Vars_TimeInvariants, only: dz_lake + USE MOD_Const_LC, only: patchtypes + + IMPLICIT NONE + + integer, intent(in) :: idate(3) + integer, intent(in) :: lc_year !year of land cover type data + character(len=*), intent(in) :: site + character(len=*), intent(in) :: dir_restart + logical, intent(in) :: require_complete_restart + + ! Local variables + character(len=256) :: file_restart + character(len=14) :: cdate, cyear +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: complete_marker + logical :: marker_exists +#endif + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-variable restart read entry') +#endif + + IF (mpas_is_root) THEN + write(*,*) 'Loading Time Variables ...' + ENDIF + + ! land cover type year + write(cyear,'(i4.4)') lc_year + + write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') idate(1), idate(2), idate(3) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + +#ifdef MPAS_EMBEDDED_COLM + IF (require_complete_restart) THEN + complete_marker = trim(file_restart)//'.mpas_complete' + inquire(file=trim(complete_marker), exist=marker_exists) + IF (.not. marker_exists) THEN + CALL CoLM_stop('MPAS restart requires a completed CoLM patch checkpoint: '//trim(complete_marker)) + ENDIF + ENDIF +#endif + +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif + + ! Time-varying state variables which required by restart run + CALL ncio_read_vector (file_restart, 'z_sno ' , -maxsnl, landpatch, z_sno ) ! node depth [m] + CALL ncio_read_vector (file_restart, 'dz_sno ' , -maxsnl, landpatch, dz_sno) ! interface depth [m] + CALL ncio_read_vector (file_restart, 't_soisno' , nl_soil-maxsnl, landpatch, t_soisno ) ! soil temperature [K] + CALL ncio_read_vector (file_restart, 'wliq_soisno', nl_soil-maxsnl, landpatch, wliq_soisno) ! liquid water in layers [kg/m2] + CALL ncio_read_vector (file_restart, 'wice_soisno', nl_soil-maxsnl, landpatch, wice_soisno) ! ice lens in layers [kg/m2] + CALL ncio_read_vector (file_restart, 'smp', nl_soil, landpatch, smp ) ! soil matrix potential [mm] + CALL ncio_read_vector (file_restart, 'hk', nl_soil, landpatch, hk ) ! hydraulic conductivity [mm h2o/s] +IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL ncio_read_vector (file_restart, 'vegwp', nvegwcs, landpatch, vegwp ) ! vegetation water potential [mm] + CALL ncio_read_vector (file_restart, 'gs0sun ', landpatch, gs0sun ) ! working copy of sunlit stomata conductance + CALL ncio_read_vector (file_restart, 'gs0sha ', landpatch, gs0sha ) ! working copy of shaded stomata conductance +ENDIF + CALL ncio_read_vector (file_restart, 't_grnd ' , landpatch, t_grnd ) ! ground surface temperature [K] + CALL ncio_read_vector (file_restart, 'tleaf ' , landpatch, tleaf ) ! leaf temperature [K] + CALL ncio_read_vector (file_restart, 'ldew ' , landpatch, ldew ) ! depth of water on foliage [mm] + CALL ncio_read_vector (file_restart, 'ldew_rain' , landpatch, ldew_rain ) ! depth of rain on foliage [mm] + CALL ncio_read_vector (file_restart, 'ldew_snow' , landpatch, ldew_snow ) ! depth of snow on foliage [mm] + CALL ncio_read_vector (file_restart, 'fwet_snow' , landpatch, fwet_snow ) ! vegetation snow fractional cover [-] + CALL ncio_read_vector (file_restart, 'sag ' , landpatch, sag ) ! non dimensional snow age [-] + CALL ncio_read_vector (file_restart, 'scv ' , landpatch, scv ) ! snow cover, water equivalent [mm] + CALL ncio_read_vector (file_restart, 'snowdp ' , landpatch, snowdp ) ! snow depth [meter] + CALL ncio_read_vector (file_restart, 'fveg ' , landpatch, fveg ) ! fraction of vegetation cover + CALL ncio_read_vector (file_restart, 'fsno ' , landpatch, fsno ) ! fraction of snow cover on ground + CALL ncio_read_vector (file_restart, 'sigf ' , landpatch, sigf ) ! fraction of veg cover, excluding snow-covered veg [-] + CALL ncio_read_vector (file_restart, 'green ' , landpatch, green ) ! leaf greenness + CALL ncio_read_vector (file_restart, 'lai ' , landpatch, lai ) ! leaf area index + CALL ncio_read_vector (file_restart, 'tlai ' , landpatch, tlai ) ! leaf area index + CALL ncio_read_vector (file_restart, 'sai ' , landpatch, sai ) ! stem area index + CALL ncio_read_vector (file_restart, 'tsai ' , landpatch, tsai ) ! stem area index + CALL ncio_read_vector (file_restart, 'coszen ' , landpatch, coszen ) ! cosine of solar zenith angle +IF(DEF_USE_OZONESTRESS)THEN + CALL ncio_read_vector (file_restart, 'lai_old ', landpatch, lai_old ) + CALL ncio_read_vector (file_restart, 'o3uptakesun', landpatch, o3uptakesun) + CALL ncio_read_vector (file_restart, 'o3uptakesha', landpatch, o3uptakesha) + CALL ncio_read_vector (file_restart, 'o3coefv_sun', landpatch, o3coefv_sun) + CALL ncio_read_vector (file_restart, 'o3coefv_sha', landpatch, o3coefv_sha) + CALL ncio_read_vector (file_restart, 'o3coefg_sun', landpatch, o3coefg_sun) + CALL ncio_read_vector (file_restart, 'o3coefg_sha', landpatch, o3coefg_sha) +ENDIF + CALL ncio_read_vector (file_restart, 'alb ' , 2, 2, landpatch, alb ) ! averaged albedo [-] + CALL ncio_read_vector (file_restart, 'ssun ' , 2, 2, landpatch, ssun ) ! sunlit canopy absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssha ' , 2, 2, landpatch, ssha ) ! shaded canopy absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssoi ' , 2, 2, landpatch, ssoi ) ! soil absorption for solar radiation (0-1) + CALL ncio_read_vector (file_restart, 'ssno ' , 2, 2, landpatch, ssno ) ! snow absorption for solar radiation (0-1) +#ifdef HYPERSPECTRAL + CALL ncio_read_vector (file_restart, 'alb_hires ' , 211, 2, landpatch, alb_hires ) ! averaged albedo [-] + CALL ncio_read_vector (file_restart, 'reflectance_out' , 211, 16, landpatch, reflectance_out ) ! averaged albedo [-] + CALL ncio_read_vector (file_restart, 'transmittance_out', 211, 16, landpatch, transmittance_out) ! averaged albedo [-] +#endif + + CALL ncio_read_vector (file_restart, 'thermk ' , landpatch, thermk ) ! canopy gap fraction for tir radiation + CALL ncio_read_vector (file_restart, 'extkb ' , landpatch, extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL ncio_read_vector (file_restart, 'extkd ' , landpatch, extkd ) ! diffuse and scattered diffuse PAR extinction coefficient + CALL ncio_read_vector (file_restart, 'zwt ' , landpatch, zwt ) ! the depth to water table [m] + CALL ncio_read_vector (file_restart, 'wa ' , landpatch, wa ) ! water storage in aquifer [mm] + CALL ncio_read_vector (file_restart, 'wetwat ' , landpatch, wetwat ) ! water storage in wetland [mm] + CALL ncio_read_vector (file_restart, 'wdsrf ' , landpatch, wdsrf ) ! depth of surface water [mm] + CALL ncio_read_vector (file_restart, 'rss ' , landpatch, rss ) ! soil surface resistance [s/m] + +IF (DEF_USE_Dynamic_Lake) THEN + CALL ncio_read_vector (file_restart, 'dz_lake' , nl_lake, landpatch, dz_lake ) +ENDIF + CALL ncio_read_vector (file_restart, 't_lake ' , nl_lake, landpatch, t_lake ) + CALL ncio_read_vector (file_restart, 'lake_icefrc', nl_lake, landpatch, lake_icefrac) + CALL ncio_read_vector (file_restart, 'savedtke1', landpatch, savedtke1) + + CALL ncio_read_vector (file_restart, 'snw_rds ', -maxsnl, landpatch, snw_rds ) + CALL ncio_read_vector (file_restart, 'mss_bcpho', -maxsnl, landpatch, mss_bcpho) + CALL ncio_read_vector (file_restart, 'mss_bcphi', -maxsnl, landpatch, mss_bcphi) + CALL ncio_read_vector (file_restart, 'mss_ocpho', -maxsnl, landpatch, mss_ocpho) + CALL ncio_read_vector (file_restart, 'mss_ocphi', -maxsnl, landpatch, mss_ocphi) + CALL ncio_read_vector (file_restart, 'mss_dst1 ', -maxsnl, landpatch, mss_dst1 ) + CALL ncio_read_vector (file_restart, 'mss_dst2 ', -maxsnl, landpatch, mss_dst2 ) + CALL ncio_read_vector (file_restart, 'mss_dst3 ', -maxsnl, landpatch, mss_dst3 ) + CALL ncio_read_vector (file_restart, 'mss_dst4 ', -maxsnl, landpatch, mss_dst4 ) + CALL ncio_read_vector (file_restart, 'ssno_lyr', 2,2, -maxsnl+1, landpatch, ssno_lyr) + + ! Additional variables required by regional model (such as WRF ) RSM) + CALL ncio_read_vector (file_restart, 'trad ', landpatch, trad ) ! radiative temperature of surface [K] + CALL ncio_read_vector (file_restart, 'tref ', landpatch, tref ) ! 2 m height air temperature [kelvin] + CALL ncio_read_vector (file_restart, 'qref ', landpatch, qref ) ! 2 m height air specific humidity + CALL ncio_read_vector (file_restart, 'rst ', landpatch, rst ) ! canopy stomatal resistance (s/m) + CALL ncio_read_vector (file_restart, 'emis ', landpatch, emis ) ! averaged bulk surface emissivity + CALL ncio_read_vector (file_restart, 'z0m ', landpatch, z0m ) ! effective roughness [m] + CALL ncio_read_vector (file_restart, 'zol ', landpatch, zol ) ! dimensionless height (z/L) used in Monin-Obukhov theory + CALL ncio_read_vector (file_restart, 'rib ', landpatch, rib ) ! bulk Richardson number in surface layer + CALL ncio_read_vector (file_restart, 'ustar', landpatch, ustar) ! u* in similarity theory [m/s] + CALL ncio_read_vector (file_restart, 'qstar', landpatch, qstar) ! q* in similarity theory [kg/kg] + CALL ncio_read_vector (file_restart, 'tstar', landpatch, tstar) ! t* in similarity theory [K] + CALL ncio_read_vector (file_restart, 'fm ', landpatch, fm ) ! integral of profile FUNCTION for momentum + CALL ncio_read_vector (file_restart, 'fh ', landpatch, fh ) ! integral of profile FUNCTION for heat + CALL ncio_read_vector (file_restart, 'fq ', landpatch, fq ) ! integral of profile FUNCTION for moisture + +IF (DEF_USE_IRRIGATION) THEN + CALL ncio_read_vector (file_restart, 'irrig_rate ' , landpatch, irrig_rate ) + CALL ncio_read_vector (file_restart, 'sum_irrig ' , landpatch, sum_irrig ) + CALL ncio_read_vector (file_restart, 'sum_deficit_irrig ' , landpatch, sum_deficit_irrig ) + CALL ncio_read_vector (file_restart, 'sum_irrig_count ' , landpatch, sum_irrig_count ) + CALL ncio_read_vector (file_restart, 'n_irrig_steps_left ' , landpatch, n_irrig_steps_left ) + CALL ncio_read_vector (file_restart, 'waterstorage ' , landpatch, waterstorage ) + CALL ncio_read_vector (file_restart, 'irrig_method_corn ' , landpatch, irrig_method_corn ) + CALL ncio_read_vector (file_restart, 'irrig_method_swheat ' , landpatch, irrig_method_swheat ) + CALL ncio_read_vector (file_restart, 'irrig_method_wwheat ' , landpatch, irrig_method_wwheat ) + CALL ncio_read_vector (file_restart, 'irrig_method_soybean ' , landpatch, irrig_method_soybean ) + CALL ncio_read_vector (file_restart, 'irrig_method_cotton ' , landpatch, irrig_method_cotton ) + CALL ncio_read_vector (file_restart, 'irrig_method_rice1 ' , landpatch, irrig_method_rice1 ) + CALL ncio_read_vector (file_restart, 'irrig_method_rice2 ' , landpatch, irrig_method_rice2 ) + CALL ncio_read_vector (file_restart, 'irrig_method_sugarcane' , landpatch, irrig_method_sugarcane) + CALL ncio_read_vector (file_restart, 'irrig_gw_alloc ' , landpatch, irrig_gw_alloc ) + CALL ncio_read_vector (file_restart, 'irrig_sw_alloc ' , landpatch, irrig_sw_alloc ) + CALL ncio_read_vector (file_restart, 'zwt_stand ' , landpatch, zwt_stand ) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) +#ifdef SinglePoint + IF (patchtypes(SITE_landtype) == 0) THEN + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_PFTimeVariables (file_restart) + ENDIF +#else + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' +#ifdef MPAS_EMBEDDED_COLM + IF (require_complete_restart) THEN + complete_marker = trim(file_restart)//'.mpas_complete' + inquire(file=trim(complete_marker), exist=marker_exists) + IF (.not. marker_exists) THEN + CALL CoLM_stop('MPAS restart requires a completed CoLM PFT checkpoint: '//trim(complete_marker)) + ENDIF + ENDIF +#endif + CALL READ_PFTimeVariables (file_restart) +#endif +#endif + +#if (defined BGC) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_bgc_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_BGCTimeVariables (file_restart) +#endif + +#if (defined CatchLateralFlow) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_basin_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_CatchTimeVariables (file_restart) +#endif + +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#endif + +#ifdef GridRiverLakeFlow + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_GridRiverLakeTimeVars (file_restart, require_complete_restart) +#endif + +#ifdef MPAS_EMBEDDED_COLM + IF (numpatch > 0) THEN +#endif + +#if (defined URBAN_MODEL) + file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_urban_'//trim(cdate)//'_lc'//trim(cyear)//'.nc' + CALL READ_UrbanTimeVariables (file_restart) +#endif + +#ifdef EXTERNAL_LAKE + CALL READ_LakeTimeVars(idate, lc_year, site, dir_restart) +#endif + +#ifdef DataAssimilation + CALL READ_DATimeVariables (idate, lc_year, site, dir_restart) +#endif + +#ifdef RangeCheck + CALL check_TimeVariables +#endif + +#ifdef MPAS_EMBEDDED_COLM + ENDIF +#endif + + IF (mpas_is_root) THEN + write(*,*) 'Loading Time Variables done.' + ENDIF + + END SUBROUTINE READ_TimeVariables + + +#ifdef RangeCheck + SUBROUTINE check_TimeVariables () + + USE MOD_MPAS_MPI + USE MOD_RangeCheck + USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION, & + DEF_USE_SNICAR, DEF_USE_Dynamic_Lake + USE MOD_Vars_TimeInvariants, only: dz_lake + + IMPLICIT NONE + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-variable range-check entry') +#endif + IF (mpas_is_root) THEN + write(*,'(/,A27)') 'Checking Time Variables ...' + ENDIF + + CALL check_vector_data ('t_grnd [K] ', t_grnd ) ! ground surface temperature [K] + CALL check_vector_data ('tleaf [K] ', tleaf ) ! leaf temperature [K] + CALL check_vector_data ('ldew [mm] ', ldew ) ! depth of water on foliage [mm] + CALL check_vector_data ('ldew_rain [mm] ', ldew_rain ) ! depth of rain on foliage [mm] + CALL check_vector_data ('ldew_snow [mm] ', ldew_snow ) ! depth of snow on foliage [mm] + CALL check_vector_data ('fwet_snow [mm] ', fwet_snow ) ! vegetation snow fractional cover [-] + CALL check_vector_data ('sag [-] ', sag ) ! non dimensional snow age [-] + CALL check_vector_data ('scv [mm] ', scv ) ! snow cover, water equivalent [mm] + CALL check_vector_data ('snowdp [m] ', snowdp ) ! snow depth [meter] + CALL check_vector_data ('fveg [-] ', fveg ) ! fraction of vegetation cover + CALL check_vector_data ('fsno [-] ', fsno ) ! fraction of snow cover on ground + CALL check_vector_data ('sigf [-] ', sigf ) ! fraction of veg cover, excluding snow-covered veg [-] + CALL check_vector_data ('green [-] ', green ) ! leaf greenness + CALL check_vector_data ('lai [-] ', lai ) ! leaf area index + CALL check_vector_data ('tlai [-] ', tlai ) ! leaf area index + CALL check_vector_data ('sai [-] ', sai ) ! stem area index + CALL check_vector_data ('tsai [-] ', tsai ) ! stem area index + CALL check_vector_data ('coszen [-] ', coszen ) ! cosine of solar zenith angle + CALL check_vector_data ('alb [-] ', alb ) ! averaged albedo [-] + CALL check_vector_data ('ssun [-] ', ssun ) ! sunlit canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssha [-] ', ssha ) ! shaded canopy absorption for solar radiation (0-1) + CALL check_vector_data ('ssoi [-] ', ssoi ) ! soil absorption for solar radiation (0-1) + CALL check_vector_data ('ssno [-] ', ssno ) ! snow absorption for solar radiation (0-1) + CALL check_vector_data ('thermk [-] ', thermk ) ! canopy gap fraction for tir radiation + CALL check_vector_data ('extkb [-] ', extkb ) ! (k, g(mu)/mu) direct solar extinction coefficient + CALL check_vector_data ('extkd [-] ', extkd ) ! diffuse and scattered diffuse PAR extinction coefficient + CALL check_vector_data ('zwt [m] ', zwt ) ! the depth to water table [m] + CALL check_vector_data ('wa [mm] ', wa ) ! water storage in aquifer [mm] + CALL check_vector_data ('wetwat [mm] ', wetwat ) ! water storage in wetland [mm] + CALL check_vector_data ('wdsrf [mm] ', wdsrf ) ! depth of surface water [mm] + CALL check_vector_data ('rss [s/m] ', rss ) ! soil surface resistance [s/m] +IF (DEF_USE_Dynamic_Lake) THEN + CALL check_vector_data ('dz_lake [m] ', dz_lake )! +ENDIF + CALL check_vector_data ('t_lake [K] ', t_lake )! + CALL check_vector_data ('lake_icefrc [-] ', lake_icefrac)! + CALL check_vector_data ('savedtke1 [W/m K]', savedtke1 )! + CALL check_vector_data ('z_sno [m] ', z_sno ) ! node depth [m] + CALL check_vector_data ('dz_sno [m] ', dz_sno) ! interface depth [m] + CALL check_vector_data ('t_soisno [K] ', t_soisno ) ! soil temperature [K] + CALL check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno) ! liquid water in layers [kg/m2] + CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno) ! ice lens in layers [kg/m2] + CALL check_vector_data ('smp [mm] ', smp ) ! soil matrix potential [mm] + CALL check_vector_data ('hk [mm/s] ', hk ) ! hydraulic conductivity [mm h2o/s] + CALL check_vector_data ('qsfc [kg/kg]', qsfc ) ! bulk surface/ground specific humidity + IF(DEF_USE_PLANTHYDRAULICS)THEN + CALL check_vector_data ('vegwp [m] ', vegwp ) ! vegetation water potential [mm] + CALL check_vector_data ('gs0sun [] ', gs0sun ) ! working copy of sunlit stomata conductance + CALL check_vector_data ('gs0sha [] ', gs0sha ) ! working copy of shaded stomata conductance +ENDIF +IF(DEF_USE_OZONESTRESS)THEN + CALL check_vector_data ('o3coefv_sun ', o3coefv_sun) + CALL check_vector_data ('o3coefv_sha ', o3coefv_sha) + CALL check_vector_data ('o3coefg_sun ', o3coefg_sun) + CALL check_vector_data ('o3coefg_sha ', o3coefg_sha) + CALL check_vector_data ('lai_old ', lai_old ) + CALL check_vector_data ('o3uptakesun ', o3uptakesun) + CALL check_vector_data ('o3uptakesha ', o3uptakesha) +ENDIF + +IF (DEF_USE_SNICAR) THEN + CALL check_vector_data ('snw_rds [m-6] ', snw_rds ) + CALL check_vector_data ('mss_bcpho [Kg] ', mss_bcpho ) + CALL check_vector_data ('mss_bcphi [Kg] ', mss_bcphi ) + CALL check_vector_data ('mss_ocpho [Kg] ', mss_ocpho ) + CALL check_vector_data ('mss_ocphi [Kg] ', mss_ocphi ) + CALL check_vector_data ('mss_dst1 [Kg] ', mss_dst1 ) + CALL check_vector_data ('mss_dst2 [Kg] ', mss_dst2 ) + CALL check_vector_data ('mss_dst3 [Kg] ', mss_dst3 ) + CALL check_vector_data ('mss_dst4 [Kg] ', mss_dst4 ) + CALL check_vector_data ('ssno_lyr [-] ', ssno_lyr ) +ENDIF + +IF (DEF_USE_IRRIGATION) THEN + CALL check_vector_data ('irrig_rate ' , irrig_rate ) + CALL check_vector_data ('deficit_irrig ' , deficit_irrig ) + CALL check_vector_data ('actual_irrig ' , actual_irrig ) + CALL check_vector_data ('sum_irrig ' , sum_irrig ) + CALL check_vector_data ('sum_deficit_irrig ' , sum_deficit_irrig ) + CALL check_vector_data ('sum_irrig_count ' , sum_irrig_count ) + CALL check_vector_data ('n_irrig_steps_left ' , n_irrig_steps_left ) + CALL check_vector_data ('waterstorage ' , waterstorage ) + CALL check_vector_data ('waterstorage_supply ' , waterstorage_supply ) + CALL check_vector_data ('groundwater_demand ' , groundwater_demand ) + CALL check_vector_data ('groundwater_supply ' , groundwater_supply ) + CALL check_vector_data ('reservoirriver_demand ' , reservoirriver_demand ) + CALL check_vector_data ('reservoirriver_supply ' , reservoirriver_supply ) + CALL check_vector_data ('irrig_method_corn ' , irrig_method_corn ) + CALL check_vector_data ('irrig_method_swheat ' , irrig_method_swheat ) + CALL check_vector_data ('irrig_method_wwheat ' , irrig_method_wwheat ) + CALL check_vector_data ('irrig_method_soybean ' , irrig_method_soybean ) + CALL check_vector_data ('irrig_method_cotton ' , irrig_method_cotton ) + CALL check_vector_data ('irrig_method_rice1 ' , irrig_method_rice1 ) + CALL check_vector_data ('irrig_method_rice2 ' , irrig_method_rice2 ) + CALL check_vector_data ('irrig_method_sugarcane' , irrig_method_sugarcane) + CALL check_vector_data ('irrig_gw_alloc ' , irrig_gw_alloc ) + CALL check_vector_data ('irrig_sw_alloc ' , irrig_sw_alloc ) + CALL check_vector_data ('zwt_stand ' , zwt_stand ) +ENDIF + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + CALL check_PFTimeVariables +#endif + +#if (defined BGC) + CALL check_BGCTimeVariables +#endif + +#ifdef EXTERNAL_LAKE + CALL CHECK_LakeTimeVars +#endif + +#ifdef DataAssimilation + IF (DEF_DA_ENS_NUM > 1) CALL check_DATimeVariables +#endif + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('time-variable range-check completion') +#endif + + END SUBROUTINE check_TimeVariables +#endif + + +END MODULE MOD_Vars_TimeVariables +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 new file mode 100644 index 0000000000..e844ffea95 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_VicParaReadin.F90 @@ -0,0 +1,146 @@ +#include + +MODULE MOD_VicParaReadin + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + ! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: vicpara_readin +CONTAINS + + SUBROUTINE vicpara_readin () + ! =========================================================== + ! ! DESCRIPTION: + ! Read in vic parameter from data + + ! =========================================================== + + USE MOD_Precision + USE MOD_Namelist + USE MOD_MPAS_MPI + USE MOD_LandPatch + USE MOD_NetCDFSerial + USE MOD_NetCDFBlock + ! USE MOD_Mapping_Grid2Pset + USE MOD_Vars_TimeInvariants + USE MOD_Vars_TimeVariables + ! USE MOD_Grid + ! USE MOD_DataType + USE MOD_SpatialMapping + USE MOD_Vars_Global + USE MOD_LandPatch + USE MOD_RangeCheck + USE MOD_Block + + + IMPLICIT NONE + character(len=256) :: file_vic_para + + type(grid_type) :: grid_b_infilt + type(grid_type) :: grid_Ws + type(grid_type) :: grid_Ds + type(grid_type) :: grid_DsM + + type(block_data_real8_2d) :: f_xy_b_infilt + type(block_data_real8_2d) :: f_xy_Ws + type(block_data_real8_2d) :: f_xy_Ds + type(block_data_real8_2d) :: f_xy_DsM + + type(spatial_mapping_type) :: mg2patch_b_infilt + type(spatial_mapping_type) :: mg2patch_Ws + type(spatial_mapping_type) :: mg2patch_Ds + type(spatial_mapping_type) :: mg2patch_DsM + + real(r8) ,allocatable :: b_infilt_tmp (:) + real(r8) ,allocatable :: Ws_tmp (:) + real(r8) ,allocatable :: Ds_tmp (:) + real(r8) ,allocatable :: DsM_tmp (:) + ! Local variables + real(r8), allocatable :: lat(:), lon(:) + real(r8) :: missing_value + integer :: cft, npatch, ipft + + file_vic_para = trim(DEF_file_VIC_OPT) + + CALL ncio_read_bcast_serial (file_vic_para, 'lat', lat) + CALL ncio_read_bcast_serial (file_vic_para, 'lon', lon) + + + CALL grid_b_infilt%define_by_center (lat, lon) + CALL grid_Ws%define_by_center (lat, lon) + CALL grid_Ds%define_by_center (lat, lon) + CALL grid_DsM%define_by_center (lat, lon) + + IF (.true.) THEN + CALL allocate_block_data (grid_b_infilt, f_xy_b_infilt) + CALL allocate_block_data (grid_Ws, f_xy_Ws) + CALL allocate_block_data (grid_Ds, f_xy_Ds) + CALL allocate_block_data (grid_DsM, f_xy_DsM) + ENDIF + + IF (.true.) THEN + CALL ncio_read_block (file_vic_para,'b', grid_b_infilt, f_xy_b_infilt) + CALL ncio_read_block (file_vic_para,'Ws', grid_Ws, f_xy_Ws) + CALL ncio_read_block (file_vic_para,'Ds', grid_Ds, f_xy_Ds) + CALL ncio_read_block (file_vic_para,'DsM', grid_DsM, f_xy_DsM) + ENDIF + + CALL mg2patch_b_infilt%build_arealweighted (grid_b_infilt, landpatch) + CALL mg2patch_Ws%build_arealweighted (grid_Ws, landpatch) + CALL mg2patch_Ds%build_arealweighted (grid_Ds, landpatch) + CALL mg2patch_DsM%build_arealweighted (grid_DsM, landpatch) + + + + IF (allocated(lon)) deallocate(lon) + IF (allocated(lat)) deallocate(lat) + + IF (.true.) THEN + IF (numpatch > 0) allocate (b_infilt_tmp (numpatch)) + IF (numpatch > 0) allocate (Ws_tmp (numpatch)) + IF (numpatch > 0) allocate (Ds_tmp (numpatch)) + IF (numpatch > 0) allocate (DsM_tmp (numpatch)) + ENDIF + + CALL mg2patch_b_infilt%grid2pset (f_xy_b_infilt, b_infilt_tmp(:)) + CALL mg2patch_Ws%grid2pset (f_xy_Ws, Ws_tmp(:)) + CALL mg2patch_Ds%grid2pset (f_xy_Ds, Ds_tmp(:)) + CALL mg2patch_DsM%grid2pset (f_xy_DsM, DsM_tmp(:)) + + IF (.true.) THEN + vic_b_infilt(:) = -9999 + vic_Dsmax(:) = -9999 + vic_Ds(:) = -9999 + vic_Ws(:) = -9999 + vic_c = 2 + ENDIF + + IF (.true.) THEN + DO ipft = 1, numpatch + !WRITE(*,*) 'Values of vic_b_infilt: ', DsM_tmp(ipft) + vic_b_infilt(ipft) = b_infilt_tmp(ipft) + vic_Ws(ipft) = Ws_tmp(ipft) + vic_Ds(ipft) = Ds_tmp(ipft) + vic_Dsmax(ipft) = DsM_tmp(ipft) + vic_c(ipft)=2 + ENDDO + ! 输出 vic_b_infilt 数组的值 + !WRITE(*,*) 'Values of vic_b_infilt: ', vic_b_infilt + ENDIF + +#ifdef RangeCheck + CALL check_vector_data ('vic_b_infilt', vic_b_infilt) + CALL check_vector_data ('vic_Ws', vic_Ws) + CALL check_vector_data ('vic_Ds', vic_Ds) + CALL check_vector_data ('vic_Dsmax', vic_Dsmax) +#endif + IF (allocated (b_infilt_tmp)) deallocate (b_infilt_tmp) + IF (allocated (Ws_tmp)) deallocate (Ws_tmp) + IF (allocated (Ds_tmp)) deallocate (Ds_tmp) + IF (allocated (DsM_tmp)) deallocate (DsM_tmp) + + END SUBROUTINE vicpara_readin +END MODULE MOD_VicParaReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_WetBulb.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_WetBulb.F90 new file mode 100644 index 0000000000..ca93a95083 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_WetBulb.F90 @@ -0,0 +1,119 @@ +MODULE MOD_WetBulb + +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: wetbulb + + +!----------------------------------------------------------------------- + + CONTAINS + +!----------------------------------------------------------------------- + + + SUBROUTINE wetbulb(t,p,q,twc) + +!======================================================================= +! Wet-bulb temperature +! +! Yongjiu Dai, 07/2013 +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz, hvap, cpair + USE MOD_Qsadv + + IMPLICIT NONE + real(r8), intent(in) :: t ! air temperature [K] + real(r8), intent(in) :: p ! atmos pressure [pa] + real(r8), intent(in) :: q ! air specific humidity [kg/kg] + real(r8), intent(out) :: twc ! wet bulb temperature [K] + + integer i + real(r8) es, esdT, qs, qsdT, r, rws + +! ---------------------------------------------------------- +! real(r8) tcair ! dry-bulb temperature in celsius +! real(r8) bp ! approximate average barometric pressure [mb] +! real(r8) ea ! water vapor pressure in air [mb] +! real(r8) eas ! saturated water vapor pressure in air [mb] +! real(r8) delt ! delt=eas*4278.63/((tcair+242.792)*(tcair+242.792)) +! real(r8) tav ! average of dry-bulb temperature and wet bulb temperature in celsius +! real(r8) eav ! eav=2.7489E8*exp(-4278.63/(tav+242.792)) +! real(r8) rh ! relative humidity +! ---------------------------------------------------------- +! WETBULB computes wet-bulb temperatures from dry-bulb (tkair) and +! vapor pressure of air(ea). routine adapted from e. anderson, p. 188. +! ---------------------------------------------------------- +! CALL qsadv(t,p,es,esdT,qs,qsdT) +! rh = min(1.0,q/qs) +! bp = p/100.0 ! mb +! eas = es/100.0 ! mb +! ea = eas ! mb +! delt = esdT/100. ! mb/K +! +! tcair = t - tfrz +! +!* eas = 2.7489e8*exp(-4278.63/(tcair+242.792)) +!* delt = eas*4278.63/((tcair+242.792)*(tcair+242.792)) +! +! DO i = 1, 3 +! twc = delt*tcair+6.6e-4 *bp*tcair+7.59e-7*bp*tcair*tcair+ea-eas +! twc = twc/(delt+6.6e-4*bp+7.59e-7*bp*tcair) ! in celsius +! +! tav = 0.5*(tcair+twc)+tfrz +! CALL qsadv(tav,p,es,esdT,qs,qsdT) +! eav = es/100. +! delt = esdT/100. +! +!* tav = 0.5*(tcair+twc) +!* eav = 2.7489e8*exp(-4278.63/(tav+242.792)) +!* delt = eav*4278.63/((tav+242.792)*(tav+242.792)) +! ENDDO +! twc = twc + tfrz +! ---------------------------------------------------------- + +! ---------------------------------------------------------- +! the defining equation for the wetbulb temp Twb is +! f(Twb) = Twb-T - Lv/Cp [r-rs(Twb)] = 0, +! WHERE +! T = the dry-bulb temp (K), +! Lv = the latent heat of vaporization (J/kg/K), +! Cp = the specific heat of air at constant pressure, +! r = the water vapor mixing ratio [q/(1-q)], +! rs(Twb) = the saturation mixing ratio at wetbulb temp. +! http://www.asp.ucar.edu/colloquium/1992/notes/paet1/node81.html +! ---------------------------------------------------------- + CALL qsadv(t,p,es,esdT,qs,qsdT) + r = q/(1.0-q) + IF (q >= qs) r = qs/(1.0-qs) + twc = t + DO i = 1, 6 + CALL qsadv(twc,p,es,esdT,qs,qsdT) + rws= qs/(1.0-qs) + twc = (twc + t + hvap/cpair*(r-rws))/2.0 + ENDDO + +!*---------------------------------------------------------- +!*wetbulb temp as air temp and relative humidity at standard sea level pressure. +!*valid for RH% (5%-99%), T (-20C-50C). R. Stull, 2011: Wet-bulb temperature form +!*relative humidity and air temperature. J. Appl. Meteor. and Climatol., vol 50, 2267-2269. +!*---------------------------------------------------------- +!* tcair = t - tfrz +!* CALL qsadv(t,p,es,esdT,qs,qsdT) +!* rh = min(1.0,q/qs) +!* twc = tcair*atan(0.151977*(rh*100.+8.313659)**0.5) & +!* + atan(tcair+rh*100.)-atan(rh*100.-1.676331) & +!* + 0.00391838*(rh*100.)**1.5*atan(0.023101*rh*100.)-4.686035 +!* twc = twc + tfrz +!*---------------------------------------------------------- + + END SUBROUTINE wetbulb + +END MODULE MOD_WetBulb +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_dataSpec_PDB.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_dataSpec_PDB.F90 new file mode 100644 index 0000000000..c66187ab10 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_dataSpec_PDB.F90 @@ -0,0 +1,1181 @@ +! ******************************************************************************** +! dataSpec_PDB.f90 +! ******************************************************************************** +! lambda = wavelength (nm) +! refractive = refractive index of leaf material +! k_Cab = specific absorption coefficient of chlorophyll (a+b) (cm2.�g-1) +! k_Car = specific absorption coefficient of carotenoids (cm2.�g-1) +! k_Anth = specific absorption coefficient of Anthocyanins (cm2.�g-1) +! k_Cw = specific absorption coefficient of water (cm-1) +! k_Cm = specific absorption coefficient of dry matter (cm2.g-1) +! k_Bp = specific absorption coefficient of brown pigments (arbitrary units) +! ******************************************************************************** +! Reference: +! F�ret, Gitelson, Noble & Jacqumoud (2017). PROSPECT-D: Towards modeling +! leaf optical properties through a complete lifecycle +! Remote Sensing of Environment, 193:204�215 +! DOI: http://doi.org/10.1016/j.rse.2017.03.004 +! The specific absorption coefficient of brown pigments is provided by F. Baret +! (EMMAH, INRA Avignon, baret@avignon.inra.fr) and used with his autorization. +! ******************************************************************************** +! version 6.0 (16 January 2017) +! ******************************************************************************** + +module MOD_dataSpec_PDB + +USE MOD_Precision +implicit none +integer, parameter :: nw=2101 +integer i, lambda(nw) +real(r8) refractive(nw), k_Cab(nw), k_Car(nw), k_Anth(nw), k_Brown(nw), k_Cw(nw), k_Cm(nw) + + +! ******************************************************************************** +! Wavelength +! ******************************************************************************** + data (lambda(i),i=1,100)/& +400,401,402,403,404,405,406,407,408,409,& +410,411,412,413,414,415,416,417,418,419,& +420,421,422,423,424,425,426,427,428,429,& +430,431,432,433,434,435,436,437,438,439,& +440,441,442,443,444,445,446,447,448,449,& +450,451,452,453,454,455,456,457,458,459,& +460,461,462,463,464,465,466,467,468,469,& +470,471,472,473,474,475,476,477,478,479,& +480,481,482,483,484,485,486,487,488,489,& +490,491,492,493,494,495,496,497,498,499/ + data (lambda(i),i=101,200)/& +500,501,502,503,504,505,506,507,508,509,& +510,511,512,513,514,515,516,517,518,519,& +520,521,522,523,524,525,526,527,528,529,& +530,531,532,533,534,535,536,537,538,539,& +540,541,542,543,544,545,546,547,548,549,& +550,551,552,553,554,555,556,557,558,559,& +560,561,562,563,564,565,566,567,568,569,& +570,571,572,573,574,575,576,577,578,579,& +580,581,582,583,584,585,586,587,588,589,& +590,591,592,593,594,595,596,597,598,599/ + data (lambda(i),i=201,300)/& +600,601,602,603,604,605,606,607,608,609,& +610,611,612,613,614,615,616,617,618,619,& +620,621,622,623,624,625,626,627,628,629,& +630,631,632,633,634,635,636,637,638,639,& +640,641,642,643,644,645,646,647,648,649,& +650,651,652,653,654,655,656,657,658,659,& +660,661,662,663,664,665,666,667,668,669,& +670,671,672,673,674,675,676,677,678,679,& +680,681,682,683,684,685,686,687,688,689,& +690,691,692,693,694,695,696,697,698,699/ + data (lambda(i),i=301,400)/& +700,701,702,703,704,705,706,707,708,709,& +710,711,712,713,714,715,716,717,718,719,& +720,721,722,723,724,725,726,727,728,729,& +730,731,732,733,734,735,736,737,738,739,& +740,741,742,743,744,745,746,747,748,749,& +750,751,752,753,754,755,756,757,758,759,& +760,761,762,763,764,765,766,767,768,769,& +770,771,772,773,774,775,776,777,778,779,& +780,781,782,783,784,785,786,787,788,789,& +790,791,792,793,794,795,796,797,798,799/ + data (lambda(i),i=401,500)/& +800,801,802,803,804,805,806,807,808,809,& +810,811,812,813,814,815,816,817,818,819,& +820,821,822,823,824,825,826,827,828,829,& +830,831,832,833,834,835,836,837,838,839,& +840,841,842,843,844,845,846,847,848,849,& +850,851,852,853,854,855,856,857,858,859,& +860,861,862,863,864,865,866,867,868,869,& +870,871,872,873,874,875,876,877,878,879,& +880,881,882,883,884,885,886,887,888,889,& +890,891,892,893,894,895,896,897,898,899/ + data (lambda(i),i=501,600)/& +900,901,902,903,904,905,906,907,908,909,& +910,911,912,913,914,915,916,917,918,919,& +920,921,922,923,924,925,926,927,928,929,& +930,931,932,933,934,935,936,937,938,939,& +940,941,942,943,944,945,946,947,948,949,& +950,951,952,953,954,955,956,957,958,959,& +960,961,962,963,964,965,966,967,968,969,& +970,971,972,973,974,975,976,977,978,979,& +980,981,982,983,984,985,986,987,988,989,& +990,991,992,993,994,995,996,997,998,999/ + data (lambda(i),i=601,700)/& +1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,& +1010,1011,1012,1013,1014,1015,1016,1017,1018,1019,& +1020,1021,1022,1023,1024,1025,1026,1027,1028,1029,& +1030,1031,1032,1033,1034,1035,1036,1037,1038,1039,& +1040,1041,1042,1043,1044,1045,1046,1047,1048,1049,& +1050,1051,1052,1053,1054,1055,1056,1057,1058,1059,& +1060,1061,1062,1063,1064,1065,1066,1067,1068,1069,& +1070,1071,1072,1073,1074,1075,1076,1077,1078,1079,& +1080,1081,1082,1083,1084,1085,1086,1087,1088,1089,& +1090,1091,1092,1093,1094,1095,1096,1097,1098,1099/ + data (lambda(i),i=701,800)/& +1100,1101,1102,1103,1104,1105,1106,1107,1108,1109,& +1110,1111,1112,1113,1114,1115,1116,1117,1118,1119,& +1120,1121,1122,1123,1124,1125,1126,1127,1128,1129,& +1130,1131,1132,1133,1134,1135,1136,1137,1138,1139,& +1140,1141,1142,1143,1144,1145,1146,1147,1148,1149,& +1150,1151,1152,1153,1154,1155,1156,1157,1158,1159,& +1160,1161,1162,1163,1164,1165,1166,1167,1168,1169,& +1170,1171,1172,1173,1174,1175,1176,1177,1178,1179,& +1180,1181,1182,1183,1184,1185,1186,1187,1188,1189,& +1190,1191,1192,1193,1194,1195,1196,1197,1198,1199/ + data (lambda(i),i=801,900)/& +1200,1201,1202,1203,1204,1205,1206,1207,1208,1209,& +1210,1211,1212,1213,1214,1215,1216,1217,1218,1219,& +1220,1221,1222,1223,1224,1225,1226,1227,1228,1229,& +1230,1231,1232,1233,1234,1235,1236,1237,1238,1239,& +1240,1241,1242,1243,1244,1245,1246,1247,1248,1249,& +1250,1251,1252,1253,1254,1255,1256,1257,1258,1259,& +1260,1261,1262,1263,1264,1265,1266,1267,1268,1269,& +1270,1271,1272,1273,1274,1275,1276,1277,1278,1279,& +1280,1281,1282,1283,1284,1285,1286,1287,1288,1289,& +1290,1291,1292,1293,1294,1295,1296,1297,1298,1299/ + data (lambda(i),i=901,1000)/& +1300,1301,1302,1303,1304,1305,1306,1307,1308,1309,& +1310,1311,1312,1313,1314,1315,1316,1317,1318,1319,& +1320,1321,1322,1323,1324,1325,1326,1327,1328,1329,& +1330,1331,1332,1333,1334,1335,1336,1337,1338,1339,& +1340,1341,1342,1343,1344,1345,1346,1347,1348,1349,& +1350,1351,1352,1353,1354,1355,1356,1357,1358,1359,& +1360,1361,1362,1363,1364,1365,1366,1367,1368,1369,& +1370,1371,1372,1373,1374,1375,1376,1377,1378,1379,& +1380,1381,1382,1383,1384,1385,1386,1387,1388,1389,& +1390,1391,1392,1393,1394,1395,1396,1397,1398,1399/ + data (lambda(i),i=1001,1100)/& +1400,1401,1402,1403,1404,1405,1406,1407,1408,1409,& +1410,1411,1412,1413,1414,1415,1416,1417,1418,1419,& +1420,1421,1422,1423,1424,1425,1426,1427,1428,1429,& +1430,1431,1432,1433,1434,1435,1436,1437,1438,1439,& +1440,1441,1442,1443,1444,1445,1446,1447,1448,1449,& +1450,1451,1452,1453,1454,1455,1456,1457,1458,1459,& +1460,1461,1462,1463,1464,1465,1466,1467,1468,1469,& +1470,1471,1472,1473,1474,1475,1476,1477,1478,1479,& +1480,1481,1482,1483,1484,1485,1486,1487,1488,1489,& +1490,1491,1492,1493,1494,1495,1496,1497,1498,1499/ + data (lambda(i),i=1101,1200)/& +1500,1501,1502,1503,1504,1505,1506,1507,1508,1509,& +1510,1511,1512,1513,1514,1515,1516,1517,1518,1519,& +1520,1521,1522,1523,1524,1525,1526,1527,1528,1529,& +1530,1531,1532,1533,1534,1535,1536,1537,1538,1539,& +1540,1541,1542,1543,1544,1545,1546,1547,1548,1549,& +1550,1551,1552,1553,1554,1555,1556,1557,1558,1559,& +1560,1561,1562,1563,1564,1565,1566,1567,1568,1569,& +1570,1571,1572,1573,1574,1575,1576,1577,1578,1579,& +1580,1581,1582,1583,1584,1585,1586,1587,1588,1589,& +1590,1591,1592,1593,1594,1595,1596,1597,1598,1599/ + data (lambda(i),i=1201,1300)/& +1600,1601,1602,1603,1604,1605,1606,1607,1608,1609,& +1610,1611,1612,1613,1614,1615,1616,1617,1618,1619,& +1620,1621,1622,1623,1624,1625,1626,1627,1628,1629,& +1630,1631,1632,1633,1634,1635,1636,1637,1638,1639,& +1640,1641,1642,1643,1644,1645,1646,1647,1648,1649,& +1650,1651,1652,1653,1654,1655,1656,1657,1658,1659,& +1660,1661,1662,1663,1664,1665,1666,1667,1668,1669,& +1670,1671,1672,1673,1674,1675,1676,1677,1678,1679,& +1680,1681,1682,1683,1684,1685,1686,1687,1688,1689,& +1690,1691,1692,1693,1694,1695,1696,1697,1698,1699/ + data (lambda(i),i=1301,1400)/& +1700,1701,1702,1703,1704,1705,1706,1707,1708,1709,& +1710,1711,1712,1713,1714,1715,1716,1717,1718,1719,& +1720,1721,1722,1723,1724,1725,1726,1727,1728,1729,& +1730,1731,1732,1733,1734,1735,1736,1737,1738,1739,& +1740,1741,1742,1743,1744,1745,1746,1747,1748,1749,& +1750,1751,1752,1753,1754,1755,1756,1757,1758,1759,& +1760,1761,1762,1763,1764,1765,1766,1767,1768,1769,& +1770,1771,1772,1773,1774,1775,1776,1777,1778,1779,& +1780,1781,1782,1783,1784,1785,1786,1787,1788,1789,& +1790,1791,1792,1793,1794,1795,1796,1797,1798,1799/ + data (lambda(i),i=1401,1500)/& +1800,1801,1802,1803,1804,1805,1806,1807,1808,1809,& +1810,1811,1812,1813,1814,1815,1816,1817,1818,1819,& +1820,1821,1822,1823,1824,1825,1826,1827,1828,1829,& +1830,1831,1832,1833,1834,1835,1836,1837,1838,1839,& +1840,1841,1842,1843,1844,1845,1846,1847,1848,1849,& +1850,1851,1852,1853,1854,1855,1856,1857,1858,1859,& +1860,1861,1862,1863,1864,1865,1866,1867,1868,1869,& +1870,1871,1872,1873,1874,1875,1876,1877,1878,1879,& +1880,1881,1882,1883,1884,1885,1886,1887,1888,1889,& +1890,1891,1892,1893,1894,1895,1896,1897,1898,1899/ + data (lambda(i),i=1501,1600)/& +1900,1901,1902,1903,1904,1905,1906,1907,1908,1909,& +1910,1911,1912,1913,1914,1915,1916,1917,1918,1919,& +1920,1921,1922,1923,1924,1925,1926,1927,1928,1929,& +1930,1931,1932,1933,1934,1935,1936,1937,1938,1939,& +1940,1941,1942,1943,1944,1945,1946,1947,1948,1949,& +1950,1951,1952,1953,1954,1955,1956,1957,1958,1959,& +1960,1961,1962,1963,1964,1965,1966,1967,1968,1969,& +1970,1971,1972,1973,1974,1975,1976,1977,1978,1979,& +1980,1981,1982,1983,1984,1985,1986,1987,1988,1989,& +1990,1991,1992,1993,1994,1995,1996,1997,1998,1999/ + data (lambda(i),i=1601,1700)/& +2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,& +2010,2011,2012,2013,2014,2015,2016,2017,2018,2019,& +2020,2021,2022,2023,2024,2025,2026,2027,2028,2029,& +2030,2031,2032,2033,2034,2035,2036,2037,2038,2039,& +2040,2041,2042,2043,2044,2045,2046,2047,2048,2049,& +2050,2051,2052,2053,2054,2055,2056,2057,2058,2059,& +2060,2061,2062,2063,2064,2065,2066,2067,2068,2069,& +2070,2071,2072,2073,2074,2075,2076,2077,2078,2079,& +2080,2081,2082,2083,2084,2085,2086,2087,2088,2089,& +2090,2091,2092,2093,2094,2095,2096,2097,2098,2099/ + data (lambda(i),i=1701,1800)/& +2100,2101,2102,2103,2104,2105,2106,2107,2108,2109,& +2110,2111,2112,2113,2114,2115,2116,2117,2118,2119,& +2120,2121,2122,2123,2124,2125,2126,2127,2128,2129,& +2130,2131,2132,2133,2134,2135,2136,2137,2138,2139,& +2140,2141,2142,2143,2144,2145,2146,2147,2148,2149,& +2150,2151,2152,2153,2154,2155,2156,2157,2158,2159,& +2160,2161,2162,2163,2164,2165,2166,2167,2168,2169,& +2170,2171,2172,2173,2174,2175,2176,2177,2178,2179,& +2180,2181,2182,2183,2184,2185,2186,2187,2188,2189,& +2190,2191,2192,2193,2194,2195,2196,2197,2198,2199/ + data (lambda(i),i=1801,1900)/& +2200,2201,2202,2203,2204,2205,2206,2207,2208,2209,& +2210,2211,2212,2213,2214,2215,2216,2217,2218,2219,& +2220,2221,2222,2223,2224,2225,2226,2227,2228,2229,& +2230,2231,2232,2233,2234,2235,2236,2237,2238,2239,& +2240,2241,2242,2243,2244,2245,2246,2247,2248,2249,& +2250,2251,2252,2253,2254,2255,2256,2257,2258,2259,& +2260,2261,2262,2263,2264,2265,2266,2267,2268,2269,& +2270,2271,2272,2273,2274,2275,2276,2277,2278,2279,& +2280,2281,2282,2283,2284,2285,2286,2287,2288,2289,& +2290,2291,2292,2293,2294,2295,2296,2297,2298,2299/ + data (lambda(i),i=1901,2000)/& +2300,2301,2302,2303,2304,2305,2306,2307,2308,2309,& +2310,2311,2312,2313,2314,2315,2316,2317,2318,2319,& +2320,2321,2322,2323,2324,2325,2326,2327,2328,2329,& +2330,2331,2332,2333,2334,2335,2336,2337,2338,2339,& +2340,2341,2342,2343,2344,2345,2346,2347,2348,2349,& +2350,2351,2352,2353,2354,2355,2356,2357,2358,2359,& +2360,2361,2362,2363,2364,2365,2366,2367,2368,2369,& +2370,2371,2372,2373,2374,2375,2376,2377,2378,2379,& +2380,2381,2382,2383,2384,2385,2386,2387,2388,2389,& +2390,2391,2392,2393,2394,2395,2396,2397,2398,2399/ + data (lambda(i),i=2001,2101)/& +2400,2401,2402,2403,2404,2405,2406,2407,2408,2409,& +2410,2411,2412,2413,2414,2415,2416,2417,2418,2419,& +2420,2421,2422,2423,2424,2425,2426,2427,2428,2429,& +2430,2431,2432,2433,2434,2435,2436,2437,2438,2439,& +2440,2441,2442,2443,2444,2445,2446,2447,2448,2449,& +2450,2451,2452,2453,2454,2455,2456,2457,2458,2459,& +2460,2461,2462,2463,2464,2465,2466,2467,2468,2469,& +2470,2471,2472,2473,2474,2475,2476,2477,2478,2479,& +2480,2481,2482,2483,2484,2485,2486,2487,2488,2489,& +2490,2491,2492,2493,2494,2495,2496,2497,2498,2499,& +2500./ + +! ******************************************************************************** +! Refractive index +! ******************************************************************************** + + data (refractive(i),i=1,100)/& +1.5115,1.5115,1.5115,1.5115,1.5115,1.5115,1.5108,1.5101,1.5095,1.5088,& +1.5081,1.5076,1.5071,1.5065,1.506,1.5055,1.505,1.5046,1.5041,1.5037,& +1.5032,1.5029,1.5026,1.5022,1.5019,1.5016,1.5013,1.501,1.5008,1.5005,& +1.5002,1.5,1.4997,1.4995,1.4992,1.499,1.4988,1.4986,1.4984,1.4982,& +1.498,1.4977,1.4974,1.4972,1.4969,1.4966,1.4964,1.4962,1.4959,1.4957,& +1.4955,1.4953,1.4951,1.4949,1.4947,1.4945,1.4943,1.4942,1.494,1.4939,& +1.4937,1.4935,1.4934,1.4932,1.4931,1.4929,1.4928,1.4927,1.4925,1.4924,& +1.4923,1.4922,1.492,1.4919,1.4917,1.4916,1.4915,1.4914,1.4912,1.4911,& +1.491,1.4909,1.4907,1.4906,1.4904,1.4903,1.4902,1.49,1.4899,1.4897,& +1.4896,1.4895,1.4893,1.4892,1.489,1.4889,1.4887,1.4885,1.4884,1.4882/ + data (refractive(i),i=101,200)/& +1.488,1.4878,1.4876,1.4875,1.4873,1.4871,1.4869,1.4867,1.4865,1.4863,& +1.4861,1.4859,1.4856,1.4854,1.4851,1.4849,1.4846,1.4844,1.4841,1.4839,& +1.4836,1.4833,1.483,1.4828,1.4825,1.4822,1.4819,1.4816,1.4813,1.481,& +1.4807,1.4804,1.4801,1.4797,1.4794,1.4791,1.4788,1.4784,1.4781,1.4777,& +1.4774,1.4771,1.4767,1.4764,1.476,1.4757,1.4753,1.475,1.4746,1.4743,& +1.4739,1.4735,1.4732,1.4728,1.4725,1.4721,1.4717,1.4713,1.4709,1.4705,& +1.4701,1.4697,1.4693,1.4689,1.4685,1.4681,1.4677,1.4673,1.467,1.4666,& +1.4662,1.4658,1.4654,1.4651,1.4647,1.4643,1.4639,1.4635,1.4632,1.4628,& +1.4624,1.462,1.4616,1.4613,1.4609,1.4605,1.4602,1.4598,1.4595,1.4591,& +1.4588,1.4585,1.4582,1.4579,1.4576,1.4573,1.457,1.4567,1.4565,1.4562/ + data (refractive(i),i=201,300)/& +1.4559,1.4556,1.4553,1.4551,1.4548,1.4545,1.4543,1.454,1.4538,1.4535,& +1.4533,1.4531,1.4528,1.4526,1.4523,1.4521,1.4519,1.4517,1.4514,1.4512,& +1.451,1.4508,1.4506,1.4504,1.4502,1.45,1.4498,1.4497,1.4495,1.4494,& +1.4492,1.4491,1.4489,1.4488,1.4486,1.4485,1.4484,1.4483,1.4482,1.4481,& +1.448,1.4479,1.4478,1.4478,1.4477,1.4476,1.4475,1.4475,1.4474,1.4474,& +1.4473,1.4473,1.4472,1.4472,1.4471,1.4471,1.447,1.447,1.4469,1.4469,& +1.4468,1.4468,1.4468,1.4467,1.4467,1.4467,1.4466,1.4466,1.4465,1.4465,& +1.4464,1.4464,1.4463,1.4463,1.4462,1.4462,1.4461,1.446,1.446,1.4459,& +1.4458,1.4457,1.4457,1.4456,1.4456,1.4455,1.4454,1.4453,1.4453,1.4452,& +1.4451,1.445,1.445,1.4449,1.4449,1.4448,1.4447,1.4446,1.4446,1.4445/ + data (refractive(i),i=301,400)/& +1.4444,1.4443,1.4442,1.4441,1.444,1.4439,1.4438,1.4437,1.4435,1.4434,& +1.4433,1.4431,1.443,1.4428,1.4427,1.4425,1.4423,1.4422,1.442,1.4419,& +1.4417,1.4415,1.4413,1.4411,1.4409,1.4407,1.4405,1.4403,1.4402,1.44,& +1.4398,1.4396,1.4394,1.4393,1.4391,1.4389,1.4387,1.4385,1.4384,1.4382,& +1.438,1.4378,1.4377,1.4375,1.4374,1.4372,1.4371,1.437,1.4368,1.4367,& +1.4366,1.4364,1.4363,1.4361,1.436,1.4358,1.4357,1.4356,1.4354,1.4353,& +1.4352,1.4351,1.435,1.4349,1.4348,1.4347,1.4346,1.4345,1.4345,1.4344,& +1.4343,1.4343,1.4342,1.4342,1.4341,1.4341,1.4341,1.4341,1.434,1.434,& +1.434,1.434,1.434,1.434,1.434,1.434,1.434,1.4341,1.4341,1.4342,& +1.4342,1.4342,1.4342,1.4343,1.4343,1.4343,1.4343,1.4344,1.4344,1.4345/ + data (refractive(i),i=401,500)/& +1.4345,1.4345,1.4346,1.4346,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,& +1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,& +1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4348,1.4348,& +1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,& +1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4348,1.4347,1.4347,& +1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4347,1.4346,1.4346,& +1.4346,1.4346,1.4346,1.4345,1.4345,1.4345,1.4345,1.4345,1.4345,1.4345,& +1.4345,1.4345,1.4345,1.4344,1.4344,1.4344,1.4344,1.4343,1.4343,1.4342,& +1.4342,1.4342,1.4342,1.4341,1.4341,1.4341,1.4341,1.4341,1.434,1.434,& +1.434,1.434,1.4339,1.4339,1.4338,1.4338,1.4338,1.4338,1.4337,1.4337/ + data (refractive(i),i=501,600)/& +1.4337,1.4337,1.4336,1.4336,1.4335,1.4335,1.4335,1.4335,1.4334,1.4334,& +1.4334,1.4334,1.4333,1.4333,1.4332,1.4332,1.4332,1.4332,1.4331,1.4331,& +1.4331,1.4331,1.433,1.433,1.4329,1.4329,1.4329,1.4328,1.4328,1.4327,& +1.4327,1.4326,1.4326,1.4325,1.4325,1.4324,1.4324,1.4323,1.4323,1.4322,& +1.4322,1.4322,1.4321,1.4321,1.432,1.432,1.432,1.4319,1.4319,1.4318,& +1.4318,1.4318,1.4317,1.4317,1.4316,1.4316,1.4316,1.4315,1.4315,1.4314,& +1.4314,1.4313,1.4313,1.4312,1.4312,1.4311,1.431,1.431,1.4309,1.4309,& +1.4308,1.4307,1.4307,1.4306,1.4306,1.4305,1.4304,1.4304,1.4303,1.4303,& +1.4302,1.4301,1.43,1.43,1.4299,1.4298,1.4297,1.4297,1.4296,1.4296,& +1.4295,1.4294,1.4293,1.4293,1.4292,1.4291,1.429,1.4289,1.4289,1.4288/ + data (refractive(i),i=601,700)/& +1.4287,1.4286,1.4285,1.4285,1.4284,1.4283,1.4282,1.4281,1.4281,1.428,& +1.4279,1.4278,1.4277,1.4276,1.4275,1.4274,1.4273,1.4272,1.4272,1.4271,& +1.427,1.4269,1.4268,1.4267,1.4266,1.4265,1.4264,1.4263,1.4263,1.4262,& +1.4261,1.426,1.4259,1.4258,1.4257,1.4256,1.4255,1.4254,1.4253,1.4252,& +1.4251,1.425,1.4249,1.4248,1.4247,1.4246,1.4245,1.4244,1.4242,1.4241,& +1.424,1.4239,1.4238,1.4237,1.4236,1.4235,1.4234,1.4233,1.4232,1.4231,& +1.423,1.4229,1.4228,1.4226,1.4225,1.4224,1.4223,1.4222,1.422,1.4219,& +1.4218,1.4217,1.4216,1.4215,1.4214,1.4213,1.4212,1.4211,1.4209,1.4208,& +1.4207,1.4206,1.4205,1.4203,1.4202,1.4201,1.42,1.4199,1.4197,1.4196,& +1.4195,1.4194,1.4193,1.4191,1.419,1.4189,1.4188,1.4187,1.4185,1.4184/ + data (refractive(i),i=701,800)/& +1.4183,1.4182,1.4181,1.4179,1.4178,1.4177,1.4176,1.4175,1.4173,1.4172,& +1.4171,1.417,1.4169,1.4167,1.4166,1.4165,1.4164,1.4163,1.4161,1.416,& +1.4159,1.4158,1.4157,1.4156,1.4155,1.4154,1.4153,1.4152,1.415,1.4149,& +1.4148,1.4147,1.4146,1.4145,1.4144,1.4143,1.4142,1.4141,1.4139,1.4138,& +1.4137,1.4136,1.4135,1.4133,1.4132,1.4131,1.413,1.4129,1.4128,1.4127,& +1.4126,1.4125,1.4124,1.4122,1.4121,1.412,1.4119,1.4118,1.4117,1.4116,& +1.4115,1.4114,1.4113,1.4111,1.411,1.4109,1.4108,1.4107,1.4106,1.4105,& +1.4104,1.4103,1.4102,1.4101,1.41,1.4099,1.4098,1.4097,1.4096,1.4095,& +1.4094,1.4093,1.4092,1.409,1.4089,1.4088,1.4087,1.4086,1.4085,1.4084,& +1.4083,1.4082,1.4081,1.408,1.4079,1.4078,1.4077,1.4076,1.4075,1.4074/ + data (refractive(i),i=801,900)/& +1.4073,1.4072,1.4071,1.407,1.4069,1.4068,1.4067,1.4066,1.4065,1.4064,& +1.4063,1.4062,1.4061,1.406,1.4059,1.4058,1.4057,1.4056,1.4054,1.4053,& +1.4052,1.4051,1.405,1.4049,1.4048,1.4047,1.4046,1.4045,1.4044,1.4043,& +1.4042,1.4041,1.404,1.4038,1.4037,1.4036,1.4035,1.4034,1.4033,1.4032,& +1.4031,1.403,1.4029,1.4028,1.4027,1.4026,1.4025,1.4024,1.4023,1.4022,& +1.4021,1.402,1.4019,1.4017,1.4016,1.4015,1.4014,1.4013,1.4012,1.4011,& +1.401,1.4009,1.4008,1.4007,1.4006,1.4005,1.4004,1.4003,1.4001,1.4,& +1.3999,1.3998,1.3997,1.3996,1.3995,1.3994,1.3993,1.3992,1.3991,1.399,& +1.3989,1.3988,1.3987,1.3985,1.3984,1.3983,1.3982,1.3981,1.398,1.3979,& +1.3978,1.3977,1.3976,1.3975,1.3974,1.3973,1.3972,1.3971,1.397,1.3969/ + data (refractive(i),i=901,1000)/& +1.3968,1.3967,1.3966,1.3965,1.3964,1.3963,1.3962,1.3961,1.396,1.3959,& +1.3958,1.3957,1.3956,1.3955,1.3954,1.3953,1.3952,1.3951,1.3949,1.3948,& +1.3947,1.3946,1.3945,1.3944,1.3943,1.3942,1.3941,1.394,1.3939,1.3938,& +1.3937,1.3936,1.3935,1.3934,1.3933,1.3932,1.3931,1.393,1.3929,1.3928,& +1.3927,1.3926,1.3925,1.3924,1.3923,1.3922,1.3921,1.392,1.3919,1.3918,& +1.3917,1.3916,1.3915,1.3914,1.3913,1.3912,1.3911,1.391,1.3909,1.3908,& +1.3907,1.3906,1.3905,1.3904,1.3903,1.3902,1.3901,1.39,1.3899,1.3898,& +1.3897,1.3896,1.3895,1.3893,1.3892,1.3891,1.389,1.3889,1.3888,1.3887,& +1.3886,1.3885,1.3884,1.3883,1.3882,1.3881,1.388,1.3879,1.3877,1.3876,& +1.3875,1.3874,1.3873,1.3872,1.3871,1.387,1.3869,1.3868,1.3867,1.3866/ + data (refractive(i),i=1001,1100)/& +1.3865,1.3864,1.3863,1.3861,1.386,1.3859,1.3858,1.3857,1.3855,1.3854,& +1.3853,1.3852,1.3851,1.3849,1.3848,1.3847,1.3846,1.3845,1.3843,1.3842,& +1.3841,1.384,1.3839,1.3837,1.3836,1.3835,1.3834,1.3833,1.3831,1.383,& +1.3829,1.3828,1.3826,1.3825,1.3823,1.3822,1.3821,1.382,1.3818,1.3817,& +1.3816,1.3815,1.3813,1.3812,1.381,1.3809,1.3808,1.3807,1.3805,1.3804,& +1.3803,1.3802,1.38,1.3799,1.3797,1.3796,1.3794,1.3793,1.3791,1.379,& +1.3788,1.3787,1.3785,1.3784,1.3782,1.3781,1.3779,1.3778,1.3776,1.3775,& +1.3773,1.3772,1.377,1.3769,1.3767,1.3766,1.3764,1.3763,1.3761,1.376,& +1.3758,1.3756,1.3755,1.3753,1.3752,1.375,1.3748,1.3747,1.3745,1.3744,& +1.3742,1.374,1.3739,1.3737,1.3736,1.3734,1.3732,1.3731,1.3729,1.3728/ + data (refractive(i),i=1101,1200)/& +1.3726,1.3724,1.3723,1.3721,1.372,1.3718,1.3716,1.3715,1.3713,1.3712,& +1.371,1.3708,1.3706,1.3705,1.3703,1.3701,1.3699,1.3698,1.3696,1.3695,& +1.3693,1.3692,1.369,1.3689,1.3687,1.3686,1.3684,1.3683,1.3681,1.368,& +1.3678,1.3676,1.3675,1.3673,1.3672,1.367,1.3668,1.3666,1.3665,1.3663,& +1.3661,1.3659,1.3658,1.3656,1.3655,1.3653,1.3651,1.365,1.3648,1.3647,& +1.3645,1.3643,1.3641,1.364,1.3638,1.3636,1.3634,1.3633,1.3631,1.363,& +1.3628,1.3626,1.3625,1.3623,1.3622,1.362,1.3618,1.3617,1.3615,1.3614,& +1.3612,1.361,1.3608,1.3607,1.3605,1.3603,1.3601,1.36,1.3598,1.3597,& +1.3595,1.3593,1.3592,1.359,1.3589,1.3587,1.3585,1.3584,1.3582,1.3581,& +1.3579,1.3577,1.3576,1.3574,1.3573,1.3571,1.3569,1.3568,1.3566,1.3565/ + data (refractive(i),i=1201,1300)/& +1.3563,1.3561,1.356,1.3558,1.3557,1.3555,1.3553,1.3552,1.355,1.3549,& +1.3547,1.3545,1.3544,1.3542,1.3541,1.3539,1.3537,1.3536,1.3534,1.3533,& +1.3531,1.3529,1.3528,1.3526,1.3525,1.3523,1.3521,1.352,1.3518,1.3517,& +1.3515,1.3513,1.3512,1.351,1.3509,1.3507,1.3505,1.3504,1.3502,1.3501,& +1.3499,1.3498,1.3496,1.3495,1.3493,1.3492,1.349,1.3489,1.3487,1.3486,& +1.3484,1.3482,1.3481,1.3479,1.3478,1.3476,1.3475,1.3473,1.3472,1.347,& +1.3469,1.3467,1.3466,1.3464,1.3463,1.3461,1.3459,1.3458,1.3456,1.3455,& +1.3453,1.3452,1.345,1.3449,1.3447,1.3446,1.3445,1.3443,1.3442,1.344,& +1.3439,1.3438,1.3436,1.3435,1.3433,1.3432,1.3431,1.3429,1.3428,1.3426,& +1.3425,1.3424,1.3422,1.3421,1.3419,1.3418,1.3417,1.3415,1.3414,1.3412/ + data (refractive(i),i=1301,1400)/& +1.3411,1.341,1.3409,1.3407,1.3406,1.3405,1.3404,1.3402,1.3401,1.3399,& +1.3398,1.3397,1.3396,1.3394,1.3393,1.3392,1.3391,1.339,1.3388,1.3387,& +1.3386,1.3385,1.3383,1.3382,1.338,1.3379,1.3378,1.3377,1.3376,1.3375,& +1.3374,1.3373,1.3372,1.337,1.3369,1.3368,1.3367,1.3366,1.3365,1.3364,& +1.3363,1.3362,1.3361,1.3359,1.3358,1.3357,1.3356,1.3355,1.3354,1.3353,& +1.3352,1.3351,1.335,1.3349,1.3348,1.3347,1.3346,1.3345,1.3344,1.3343,& +1.3342,1.3341,1.334,1.3339,1.3338,1.3337,1.3336,1.3335,1.3334,1.3333,& +1.3332,1.3331,1.333,1.3329,1.3328,1.3327,1.3326,1.3325,1.3324,1.3323,& +1.3322,1.3321,1.332,1.332,1.3319,1.3318,1.3317,1.3316,1.3316,1.3315,& +1.3314,1.3313,1.3312,1.3311,1.331,1.3309,1.3308,1.3307,1.3307,1.3306/ + data (refractive(i),i=1401,1500)/& +1.3305,1.3304,1.3303,1.3303,1.3302,1.3301,1.33,1.3299,1.3299,1.3298,& +1.3297,1.3296,1.3295,1.3295,1.3294,1.3293,1.3292,1.3291,1.3291,1.329,& +1.3289,1.3288,1.3287,1.3287,1.3286,1.3285,1.3284,1.3283,1.3283,1.3282,& +1.3281,1.328,1.3279,1.3279,1.3278,1.3277,1.3276,1.3275,1.3275,1.3274,& +1.3273,1.3272,1.3271,1.3271,1.327,1.3269,1.3268,1.3268,1.3267,1.3267,& +1.3266,1.3265,1.3264,1.3264,1.3263,1.3262,1.3261,1.3261,1.326,1.326,& +1.3259,1.3258,1.3257,1.3257,1.3256,1.3255,1.3254,1.3254,1.3253,1.3253,& +1.3252,1.3251,1.325,1.325,1.3249,1.3248,1.3247,1.3247,1.3246,1.3246,& +1.3245,1.3244,1.3243,1.3243,1.3242,1.3241,1.324,1.324,1.3239,1.3239,& +1.3238,1.3237,1.3236,1.3236,1.3235,1.3234,1.3233,1.3233,1.3232,1.3232/ + data (refractive(i),i=1501,1600)/& +1.3231,1.323,1.323,1.3229,1.3229,1.3228,1.3227,1.3227,1.3226,1.3226,& +1.3225,1.3224,1.3224,1.3223,1.3223,1.3222,1.3221,1.322,1.322,1.3219,& +1.3218,1.3217,1.3217,1.3216,1.3216,1.3215,1.3214,1.3213,1.3213,1.3212,& +1.3211,1.321,1.321,1.3209,1.3209,1.3208,1.3207,1.3206,1.3206,1.3205,& +1.3204,1.3203,1.3203,1.3202,1.3202,1.3201,1.32,1.32,1.3199,1.3199,& +1.3198,1.3197,1.3197,1.3196,1.3196,1.3195,1.3194,1.3193,1.3193,1.3192,& +1.3191,1.319,1.319,1.3189,1.3189,1.3188,1.3187,1.3186,1.3186,1.3185,& +1.3184,1.3183,1.3183,1.3182,1.3182,1.3181,1.318,1.3179,1.3179,1.3178,& +1.3177,1.3176,1.3175,1.3175,1.3174,1.3173,1.3172,1.3171,1.3171,1.317,& +1.3169,1.3168,1.3167,1.3167,1.3166,1.3165,1.3164,1.3163,1.3163,1.3162/ + data (refractive(i),i=1601,1700)/& +1.3161,1.316,1.3159,1.3159,1.3158,1.3157,1.3156,1.3155,1.3154,1.3153,& +1.3152,1.3151,1.315,1.315,1.3149,1.3148,1.3147,1.3146,1.3146,1.3145,& +1.3144,1.3143,1.3142,1.3141,1.314,1.3139,1.3138,1.3137,1.3136,1.3135,& +1.3134,1.3133,1.3132,1.3131,1.313,1.3129,1.3128,1.3127,1.3126,1.3125,& +1.3124,1.3123,1.3122,1.3121,1.312,1.3119,1.3118,1.3117,1.3116,1.3115,& +1.3114,1.3113,1.3112,1.311,1.3109,1.3108,1.3107,1.3106,1.3105,1.3104,& +1.3103,1.3102,1.3101,1.3099,1.3098,1.3097,1.3096,1.3095,1.3094,1.3093,& +1.3092,1.3091,1.309,1.3088,1.3087,1.3086,1.3085,1.3084,1.3082,1.3081,& +1.308,1.3079,1.3078,1.3076,1.3075,1.3074,1.3073,1.3072,1.307,1.3069,& +1.3068,1.3067,1.3066,1.3064,1.3063,1.3062,1.3061,1.306,1.3059,1.3058/ + data (refractive(i),i=1701,1800)/& +1.3057,1.3056,1.3055,1.3053,1.3052,1.3051,1.305,1.3049,1.3047,1.3046,& +1.3045,1.3044,1.3043,1.3041,1.304,1.3039,1.3038,1.3037,1.3035,1.3034,& +1.3033,1.3032,1.3031,1.3029,1.3028,1.3027,1.3026,1.3025,1.3023,1.3022,& +1.3021,1.302,1.3019,1.3017,1.3016,1.3015,1.3014,1.3013,1.3011,1.301,& +1.3009,1.3008,1.3007,1.3005,1.3004,1.3003,1.3002,1.3001,1.2999,1.2998,& +1.2997,1.2996,1.2995,1.2993,1.2992,1.2991,1.299,1.2989,1.2987,1.2986,& +1.2985,1.2984,1.2983,1.2981,1.298,1.2979,1.2978,1.2977,1.2975,1.2974,& +1.2973,1.2972,1.297,1.2969,1.2967,1.2966,1.2965,1.2964,1.2962,1.2961,& +1.296,1.2959,1.2958,1.2957,1.2956,1.2955,1.2954,1.2953,1.2951,1.295,& +1.2949,1.2948,1.2947,1.2945,1.2944,1.2943,1.2942,1.2941,1.2939,1.2938/ + data (refractive(i),i=1801,1900)/& +1.2937,1.2936,1.2935,1.2933,1.2932,1.2931,1.293,1.2928,1.2927,1.2925,& +1.2924,1.2923,1.2922,1.292,1.2919,1.2918,1.2917,1.2916,1.2914,1.2913,& +1.2912,1.2911,1.291,1.2908,1.2907,1.2906,1.2905,1.2904,1.2902,1.2901,& +1.29,1.2899,1.2898,1.2896,1.2895,1.2894,1.2893,1.2892,1.289,1.2889,& +1.2888,1.2887,1.2886,1.2884,1.2883,1.2882,1.2881,1.288,1.2878,1.2877,& +1.2876,1.2875,1.2874,1.2873,1.2872,1.2871,1.287,1.2869,1.2867,1.2866,& +1.2865,1.2864,1.2863,1.2862,1.2861,1.286,1.2859,1.2858,1.2856,1.2855,& +1.2854,1.2853,1.2852,1.285,1.2849,1.2848,1.2847,1.2846,1.2845,1.2844,& +1.2843,1.2842,1.2841,1.284,1.2839,1.2838,1.2837,1.2836,1.2834,1.2833,& +1.2832,1.2831,1.283,1.2829,1.2828,1.2827,1.2826,1.2825,1.2824,1.2823/ + data (refractive(i),i=1901,2000)/& +1.2822,1.2821,1.282,1.2818,1.2817,1.2816,1.2815,1.2814,1.2813,1.2812,& +1.2811,1.281,1.2809,1.2808,1.2807,1.2806,1.2805,1.2804,1.2803,1.2802,& +1.2801,1.28,1.2799,1.2799,1.2798,1.2797,1.2796,1.2795,1.2795,1.2794,& +1.2793,1.2792,1.2791,1.2791,1.279,1.2789,1.2788,1.2788,1.2787,1.2787,& +1.2786,1.2785,1.2785,1.2784,1.2784,1.2783,1.2782,1.2781,1.278,1.2779,& +1.2778,1.2777,1.2776,1.2776,1.2775,1.2774,1.2773,1.2772,1.2771,1.277,& +1.2769,1.2768,1.2767,1.2766,1.2765,1.2764,1.2763,1.2762,1.2761,1.276,& +1.2759,1.2758,1.2757,1.2757,1.2756,1.2755,1.2754,1.2753,1.2753,1.2752,& +1.2751,1.275,1.2749,1.2749,1.2748,1.2747,1.2746,1.2745,1.2745,1.2744,& +1.2743,1.2742,1.2742,1.2741,1.2741,1.274,1.2739,1.2739,1.2738,1.2738/ + data (refractive(i),i=2001,2101)/& +1.2737,1.2736,1.2736,1.2735,1.2735,1.2734,1.2733,1.2733,1.2732,1.2732,& +1.2731,1.273,1.273,1.2729,1.2729,1.2728,1.2727,1.2727,1.2726,1.2726,& +1.2725,1.2725,1.2724,1.2724,1.2723,1.2723,1.2722,1.2722,1.2721,1.2721,& +1.272,1.272,1.2719,1.2719,1.2718,1.2718,1.2717,1.2717,1.2716,1.2716,& +1.2715,1.2715,1.2714,1.2714,1.2713,1.2713,1.2713,1.2713,1.2712,1.2712,& +1.2712,1.2712,1.2711,1.2711,1.271,1.271,1.271,1.271,1.2709,1.2709,& +1.2709,1.2709,1.2709,1.2708,1.2708,1.2708,1.2708,1.2708,1.2708,1.2708,& +1.2708,1.2708,1.2708,1.2708,1.2708,1.2708,1.2708,1.2709,1.2709,1.271,& +1.271,1.2711,1.2712,1.2712,1.2713,1.2714,1.2715,1.2716,1.2717,1.2718,& +1.2719,1.272,1.2722,1.2723,1.2725,1.2726,1.2728,1.273,1.2732,1.2734,& +1.2736/ + +! ******************************************************************************** +! Specific absorption coefficient of chlorophyll +! ******************************************************************************** + + data (k_Cab(i),i=1,100)/& +0.064881,0.066732,0.068551,0.069982,0.0709,0.071333,0.07132,0.07126,0.071223,0.071228,& +0.071491,0.071888,0.072018,0.071827,0.071493,0.071132,0.070763,0.070437,0.070094,0.06984,& +0.069819,0.070054,0.070281,0.070503,0.070473,0.070528,0.070809,0.071312,0.071622,0.071905,& +0.072449,0.073091,0.073652,0.074047,0.074335,0.074542,0.074691,0.074653,0.07457,0.074285,& +0.073794,0.072818,0.071622,0.070459,0.069105,0.067568,0.066026,0.064492,0.062668,0.060755,& +0.058775,0.056778,0.054732,0.052844,0.051125,0.049573,0.048139,0.046801,0.045645,0.044691,& +0.043873,0.043162,0.042653,0.042206,0.041774,0.041297,0.040911,0.040571,0.040302,0.040009,& +0.039727,0.039521,0.039292,0.039035,0.038773,0.038523,0.03826,0.037881,0.03751,0.037149,& +0.036776,0.0363,0.035761,0.03521,0.034583,0.033909,0.033184,0.032377,0.031519,0.030584,& +0.029662,0.028699,0.027692,0.02664,0.02559,0.024517,0.023428,0.022328,0.021224,0.020137/ + data (k_Cab(i),i=101,200)/& +0.019048,0.01798,0.016943,0.015923,0.014934,0.013979,0.01305,0.012154,0.011296,0.01048,& +0.0097008,0.008954,0.0082461,0.00758,0.0069574,0.0063867,0.005868,0.0054015,0.0049913,0.0046349,& +0.0043338,0.004085,0.0038874,0.0037421,0.0036525,0.0036118,0.0036193,0.0036728,0.0037697,0.0039032,& +0.004069,0.0042637,0.0044843,0.00473,0.0049935,0.0052728,0.0055645,0.0058662,0.0061706,0.0064792,& +0.0067864,0.00709,0.007388,0.0076742,0.0079483,0.0082083,0.0084536,0.008685,0.0089037,0.0091119,& +0.0093094,0.0095001,0.0096821,0.0098639,0.01004,0.010214,0.010386,0.010556,0.010724,0.010889,& +0.011048,0.011217,0.011402,0.011605,0.011827,0.012075,0.01234,0.012628,0.012933,0.01326,& +0.013598,0.013947,0.014301,0.014658,0.01501,0.015357,0.015693,0.016023,0.01634,0.016648,& +0.016945,0.017241,0.017527,0.017801,0.018066,0.018325,0.018568,0.0188,0.019019,0.019228,& +0.019419,0.019599,0.019766,0.019922,0.020066,0.020199,0.020327,0.020458,0.020585,0.020715/ + data (k_Cab(i),i=201,300)/& +0.020854,0.021007,0.021172,0.021348,0.021546,0.021764,0.022003,0.022268,0.022553,0.022859,& +0.023177,0.023502,0.023842,0.024199,0.024561,0.024917,0.025269,0.025617,0.02595,0.026255,& +0.02653,0.026786,0.02701,0.027207,0.027379,0.027523,0.027645,0.027739,0.027821,0.027895,& +0.027978,0.028072,0.028194,0.02836,0.028573,0.028846,0.029181,0.029599,0.030077,0.030634,& +0.031248,0.031927,0.032659,0.033441,0.034255,0.035101,0.035949,0.036779,0.037588,0.038323,& +0.039014,0.039631,0.040222,0.040804,0.041418,0.042107,0.04288,0.043808,0.044861,0.046107,& +0.047495,0.049113,0.050849,0.05273,0.0547,0.056761,0.058868,0.06083,0.06275,0.064472,& +0.066112,0.067471,0.068675,0.069635,0.070465,0.070995,0.071402,0.071358,0.071127,0.070185,& +0.068921,0.066576,0.063948,0.060482,0.056858,0.052747,0.048726,0.044707,0.040858,0.037141,& +0.033671,0.030459,0.027502,0.024787,0.02233,0.020144,0.018173,0.016421,0.014852,0.013471/ + data (k_Cab(i),i=301,400)/& +0.012241,0.011155,0.010193,0.009343,0.0085869,0.007915,0.0073126,0.0067711,0.0062803,0.0058322,& +0.0054214,0.0050449,0.0046965,0.0043735,0.004072,0.0037922,0.0035302,0.0032856,0.0030575,0.0028435,& +0.0026434,0.0024563,0.0022809,0.0021168,0.0019636,0.0018206,0.0016869,0.0015628,0.0014468,0.0013388,& +0.0012386,0.0011459,0.0010591,0.00097828,0.00090409,0.00083609,0.00077289,0.00071503,0.00066162,0.00061235,& +0.00056764,0.00052722,0.00048994,0.00045636,0.00042566,0.00039812,0.00037316,0.00035104,0.00033141,0.00031371,& +0.00029841,0.00028315,0.00026796,0.00025289,0.00023795,0.00022319,0.00020864,0.00019431,0.00018026,0.00016649,& +0.00015306,0.00013998,0.00012729,0.00011501,0.00010319,9.1841e-05,8.1005e-05,7.0709e-05,6.0985e-05,5.1862e-05,& +4.3372e-05,3.5545e-05,2.8412e-05,2.2003e-05,1.6349e-05,1.1481e-05,7.4298e-06,4.2252e-06,1.8983e-06,4.7969e-07,& +1.0525e-13,0,0,0,0,0,0,0,0,0,& +0,0,0,0,0,0,0,0,0,0/ + data (k_Cab(i),i=401,2101)/1701*0./ + +! ******************************************************************************** +! Specific absorption coefficient of carotenoids +! ******************************************************************************** + + data (k_Car(i),i=1,100)/& +0.16734,0.16761,0.16718,0.16721,0.16761,0.1676,0.16751,0.16743,0.16724,0.16668,& +0.16588,0.16552,0.16545,0.16569,0.16609,0.16619,0.16629,0.16646,0.16662,0.16687,& +0.16716,0.16754,0.16798,0.16844,0.1686,0.16847,0.16814,0.168,0.16773,0.16741,& +0.16755,0.16774,0.16791,0.16797,0.16794,0.16797,0.16818,0.16832,0.1687,0.16916,& +0.16957,0.16968,0.16963,0.1699,0.16991,0.16981,0.16977,0.16973,0.16935,0.16857,& +0.16744,0.16602,0.16446,0.1629,0.16136,0.15978,0.15822,0.15656,0.15497,0.1533,& +0.15167,0.14997,0.14832,0.14677,0.14508,0.14349,0.142,0.14055,0.13919,0.13802,& +0.13701,0.13614,0.13548,0.135,0.13464,0.13437,0.13417,0.13394,0.13375,0.13356,& +0.13327,0.13279,0.13217,0.13141,0.13042,0.12922,0.12782,0.12631,0.12457,0.12269,& +0.12066,0.1186,0.11652,0.11441,0.11227,0.11011,0.10793,0.10573,0.1035,0.10126/ + data (k_Car(i),i=101,200)/& +0.099004,0.096734,0.09445,0.092156,0.089854,0.087544,0.085228,0.082909,0.080588,0.078267,& +0.075947,0.073631,0.071319,0.069014,0.066717,0.064431,0.062156,0.059895,0.057649,0.055421,& +0.053211,0.051021,0.048854,0.04671,0.044592,0.042502,0.040441,0.03841,0.036412,0.034449,& +0.032521,0.030631,0.028781,0.026971,0.025205,0.023483,0.021808,0.020181,0.018603,0.017077,& +0.015605,0.014187,0.012826,0.011524,0.010282,0.0091015,0.0079848,0.0069335,0.0059492,0.0050338,& +0.004189,0.0034164,0.0027178,0.0020949,0.0015495,0.0010832,0.00069786,0.00039514,0.00017677,4.448e-05,& +2.1316e-13,0,0,0,0,0,0,0,0,0,& +0,0,0,0,0,0,0,0,0,0,& +0,0,0,0,0,0,0,0,0,0,& +0,0,0,0,0,0,0,0,0,0/ + data (k_Car(i),i=201,2101)/1901*0./ + +! ******************************************************************************** +! Specific absorption coefficient of anthocyanins +! ******************************************************************************** + + data (k_Anth(i),i=1,100)/& +0.066675,0.064056,0.061933,0.059922,0.058277,0.056699,0.055366,0.054163,0.053116,0.05198,& +0.050951,0.050117,0.049387,0.048604,0.047876,0.047379,0.046899,0.046532,0.046157,0.045792,& +0.045429,0.045144,0.044845,0.044536,0.044249,0.044116,0.043958,0.043874,0.043805,0.043858,& +0.043861,0.043912,0.043959,0.044037,0.04411,0.044203,0.044277,0.044399,0.04451,0.044647,& +0.044787,0.044919,0.045061,0.045227,0.045415,0.045589,0.045753,0.045857,0.045994,0.046195,& +0.046414,0.04668,0.046953,0.047162,0.04736,0.047593,0.047814,0.048082,0.048335,0.048595,& +0.048839,0.049123,0.04937,0.049608,0.049841,0.050136,0.05042,0.050784,0.05115,0.051557,& +0.051941,0.052387,0.05282,0.053409,0.05399,0.054462,0.05494,0.055543,0.056155,0.056638,& +0.057152,0.057689,0.058265,0.058847,0.059478,0.060054,0.06067,0.061221,0.061809,0.062358,& +0.062922,0.063434,0.06397,0.064462,0.064964,0.065431,0.06591,0.066378,0.066852,0.067309/ + data (k_Anth(i),i=101,200)/& +0.067771,0.068133,0.068479,0.068815,0.06914,0.069362,0.069563,0.069828,0.070073,0.070279,& +0.070472,0.070679,0.070872,0.071025,0.071165,0.071285,0.07139,0.071486,0.071573,0.07163,& +0.071682,0.071739,0.071775,0.071815,0.071864,0.071959,0.07206,0.072153,0.07224,0.072295,& +0.072349,0.072414,0.072476,0.07251,0.072528,0.072529,0.072506,0.072433,0.07234,0.07221,& +0.072063,0.071837,0.071602,0.071343,0.071067,0.070707,0.070307,0.06984,0.069355,0.068756,& +0.06814,0.06744,0.066733,0.065904,0.065061,0.06421,0.063357,0.062437,0.061518,0.060579,& +0.059652,0.058611,0.057591,0.056554,0.055543,0.054379,0.053243,0.052056,0.0509,0.049671,& +0.048481,0.047309,0.046174,0.045,0.043871,0.042781,0.041734,0.040618,0.039543,0.038457,& +0.037412,0.0362,0.035043,0.033919,0.032846,0.031701,0.030606,0.029616,0.028665,0.027715,& +0.026803,0.025951,0.025134,0.024293,0.023487,0.022687,0.021918,0.021085,0.020284,0.019497/ + data (k_Anth(i),i=201,300)/& +0.01874,0.017977,0.017242,0.016604,0.015987,0.01541,0.014845,0.014317,0.0138,0.013295,& +0.012801,0.012336,0.011884,0.011394,0.010918,0.010464,0.010022,0.0095808,0.0091553,0.0087766,& +0.008411,0.0080523,0.0077073,0.0073755,0.0070567,0.0067504,0.0064566,0.0061747,0.0059044,0.0056455,& +0.0053977,0.0051604,0.0049336,0.0047168,0.0045097,0.004312,0.0041234,0.0039435,0.003772,0.0036087,& +0.003453,0.0033048,0.0031638,0.0030295,0.0029017,0.00278,0.0026642,0.0025538,0.0024487,0.0023483,& +0.0022525,0.0021608,0.0020731,0.0019889,0.0019079,0.0018298,0.0017542,0.0016809,0.0016096,0.0015398,& +0.0014713,0.0014037,0.0013368,0.0012702,0.0012035,0.0011365,0.0010688,0.0010001,0.00093008,0.00085841,& +0.00078476,0.00071002,0.00063884,0.00057124,0.00050727,0.00044695,0.0003903,0.00033737,0.00028817,0.00024273,& +0.0002011,0.00016329,0.00012933,9.9259e-05,7.3102e-05,5.0888e-05,3.2647e-05,1.8408e-05,8.2009e-06,2.0551e-06,& +0,0,0,0,0,0,0,0,0,0/ + data (k_Anth(i),i=301,2101)/1801*0./ + +! ******************************************************************************** +! Specific absorption coefficient of brown pigments +! ******************************************************************************** + + data (k_Brown(i),i=1,100)/& +5.272e-01,5.262e-01,5.252e-01,5.242e-01,5.232e-01,5.222e-01,5.212e-01,5.202e-01,5.192e-01,5.182e-01,& +5.172e-01,5.162e-01,5.152e-01,5.142e-01,5.132e-01,5.122e-01,5.112e-01,5.102e-01,5.092e-01,5.082e-01,& +5.072e-01,5.062e-01,5.052e-01,5.042e-01,5.032e-01,5.022e-01,5.012e-01,5.002e-01,4.992e-01,4.982e-01,& +4.972e-01,4.960e-01,4.948e-01,4.936e-01,4.924e-01,4.912e-01,4.900e-01,4.888e-01,4.876e-01,4.864e-01,& +4.852e-01,4.840e-01,4.829e-01,4.817e-01,4.805e-01,4.793e-01,4.781e-01,4.769e-01,4.757e-01,4.745e-01,& +4.733e-01,4.720e-01,4.708e-01,4.695e-01,4.683e-01,4.670e-01,4.658e-01,4.645e-01,4.633e-01,4.620e-01,& +4.608e-01,4.597e-01,4.587e-01,4.577e-01,4.566e-01,4.556e-01,4.546e-01,4.535e-01,4.525e-01,4.515e-01,& +4.504e-01,4.494e-01,4.484e-01,4.473e-01,4.463e-01,4.453e-01,4.442e-01,4.432e-01,4.422e-01,4.411e-01,& +4.401e-01,4.388e-01,4.375e-01,4.362e-01,4.350e-01,4.337e-01,4.324e-01,4.311e-01,4.298e-01,4.285e-01,& +4.272e-01,4.260e-01,4.247e-01,4.234e-01,4.221e-01,4.208e-01,4.195e-01,4.183e-01,4.170e-01,4.157e-01/ + data (k_Brown(i),i=101,200)/& +4.144e-01,4.135e-01,4.127e-01,4.118e-01,4.109e-01,4.100e-01,4.092e-01,4.083e-01,4.074e-01,4.065e-01,& +4.057e-01,4.047e-01,4.038e-01,4.028e-01,4.019e-01,4.009e-01,4.000e-01,3.990e-01,3.981e-01,3.971e-01,& +3.962e-01,3.952e-01,3.943e-01,3.933e-01,3.924e-01,3.914e-01,3.905e-01,3.895e-01,3.886e-01,3.876e-01,& +3.867e-01,3.846e-01,3.824e-01,3.803e-01,3.782e-01,3.760e-01,3.739e-01,3.718e-01,3.696e-01,3.675e-01,& +3.654e-01,3.639e-01,3.625e-01,3.611e-01,3.597e-01,3.582e-01,3.568e-01,3.554e-01,3.540e-01,3.525e-01,& +3.511e-01,3.500e-01,3.489e-01,3.478e-01,3.467e-01,3.456e-01,3.445e-01,3.434e-01,3.423e-01,3.412e-01,& +3.401e-01,3.383e-01,3.366e-01,3.348e-01,3.330e-01,3.312e-01,3.294e-01,3.276e-01,3.258e-01,3.241e-01,& +3.223e-01,3.202e-01,3.182e-01,3.162e-01,3.141e-01,3.121e-01,3.100e-01,3.080e-01,3.059e-01,3.039e-01,& +3.019e-01,2.999e-01,2.979e-01,2.959e-01,2.940e-01,2.920e-01,2.900e-01,2.881e-01,2.861e-01,2.841e-01,& +2.821e-01,2.803e-01,2.784e-01,2.766e-01,2.747e-01,2.728e-01,2.710e-01,2.691e-01,2.673e-01,2.654e-01/ + data (k_Brown(i),i=201,300)/& +2.636e-01,2.618e-01,2.601e-01,2.584e-01,2.566e-01,2.549e-01,2.532e-01,2.515e-01,2.497e-01,2.480e-01,& +2.463e-01,2.447e-01,2.431e-01,2.414e-01,2.398e-01,2.382e-01,2.366e-01,2.350e-01,2.334e-01,2.318e-01,& +2.302e-01,2.288e-01,2.273e-01,2.258e-01,2.244e-01,2.229e-01,2.215e-01,2.200e-01,2.185e-01,2.171e-01,& +2.156e-01,2.143e-01,2.129e-01,2.115e-01,2.102e-01,2.088e-01,2.074e-01,2.061e-01,2.047e-01,2.033e-01,& +2.020e-01,2.007e-01,1.994e-01,1.981e-01,1.968e-01,1.955e-01,1.942e-01,1.929e-01,1.916e-01,1.903e-01,& +1.890e-01,1.878e-01,1.865e-01,1.853e-01,1.841e-01,1.829e-01,1.816e-01,1.804e-01,1.792e-01,1.780e-01,& +1.768e-01,1.755e-01,1.742e-01,1.729e-01,1.717e-01,1.704e-01,1.691e-01,1.679e-01,1.666e-01,1.653e-01,& +1.641e-01,1.627e-01,1.613e-01,1.600e-01,1.586e-01,1.572e-01,1.559e-01,1.545e-01,1.532e-01,1.518e-01,& +1.504e-01,1.491e-01,1.478e-01,1.464e-01,1.451e-01,1.437e-01,1.424e-01,1.411e-01,1.397e-01,1.384e-01,& +1.370e-01,1.358e-01,1.345e-01,1.333e-01,1.320e-01,1.308e-01,1.295e-01,1.283e-01,1.270e-01,1.258e-01/ + data (k_Brown(i),i=301,400)/& +1.245e-01,1.234e-01,1.223e-01,1.212e-01,1.200e-01,1.189e-01,1.178e-01,1.167e-01,1.156e-01,1.144e-01,& +1.133e-01,1.122e-01,1.111e-01,1.100e-01,1.089e-01,1.078e-01,1.067e-01,1.056e-01,1.046e-01,1.035e-01,& +1.024e-01,1.013e-01,1.003e-01,9.931e-02,9.829e-02,9.727e-02,9.625e-02,9.524e-02,9.422e-02,9.320e-02,& +9.218e-02,9.120e-02,9.022e-02,8.924e-02,8.827e-02,8.729e-02,8.631e-02,8.533e-02,8.435e-02,8.337e-02,& +8.239e-02,8.155e-02,8.070e-02,7.985e-02,7.901e-02,7.816e-02,7.732e-02,7.647e-02,7.562e-02,7.478e-02,& +7.393e-02,7.319e-02,7.245e-02,7.171e-02,7.097e-02,7.023e-02,6.949e-02,6.875e-02,6.801e-02,6.727e-02,& +6.653e-02,6.586e-02,6.519e-02,6.452e-02,6.385e-02,6.318e-02,6.251e-02,6.184e-02,6.117e-02,6.050e-02,& +5.983e-02,5.913e-02,5.843e-02,5.773e-02,5.704e-02,5.634e-02,5.564e-02,5.494e-02,5.424e-02,5.354e-02,& +5.284e-02,5.226e-02,5.167e-02,5.109e-02,5.050e-02,4.992e-02,4.933e-02,4.874e-02,4.816e-02,4.757e-02,& +4.699e-02,4.646e-02,4.594e-02,4.542e-02,4.490e-02,4.437e-02,4.385e-02,4.333e-02,4.281e-02,4.228e-02/ + data (k_Brown(i),i=401,500)/& +4.176e-02,4.128e-02,4.081e-02,4.033e-02,3.985e-02,3.937e-02,3.889e-02,3.841e-02,3.793e-02,3.746e-02,& +3.698e-02,3.657e-02,3.615e-02,3.574e-02,3.533e-02,3.492e-02,3.451e-02,3.409e-02,3.368e-02,3.327e-02,& +3.286e-02,3.249e-02,3.212e-02,3.175e-02,3.139e-02,3.102e-02,3.065e-02,3.028e-02,2.991e-02,2.954e-02,& +2.918e-02,2.885e-02,2.852e-02,2.819e-02,2.786e-02,2.753e-02,2.720e-02,2.688e-02,2.655e-02,2.622e-02,& +2.589e-02,2.559e-02,2.529e-02,2.499e-02,2.469e-02,2.440e-02,2.410e-02,2.380e-02,2.350e-02,2.320e-02,& +2.290e-02,2.264e-02,2.238e-02,2.212e-02,2.186e-02,2.159e-02,2.133e-02,2.107e-02,2.081e-02,2.055e-02,& +2.029e-02,2.006e-02,1.983e-02,1.961e-02,1.938e-02,1.915e-02,1.893e-02,1.870e-02,1.847e-02,1.825e-02,& +1.802e-02,1.782e-02,1.762e-02,1.742e-02,1.723e-02,1.703e-02,1.683e-02,1.663e-02,1.643e-02,1.623e-02,& +1.604e-02,1.586e-02,1.568e-02,1.551e-02,1.533e-02,1.516e-02,1.498e-02,1.481e-02,1.463e-02,1.446e-02,& +1.428e-02,1.414e-02,1.400e-02,1.385e-02,1.371e-02,1.357e-02,1.343e-02,1.328e-02,1.314e-02,1.300e-02/ + data (k_Brown(i),i=501,600)/& +1.286e-02,1.275e-02,1.265e-02,1.255e-02,1.245e-02,1.235e-02,1.225e-02,1.215e-02,1.205e-02,1.195e-02,& +1.185e-02,1.175e-02,1.165e-02,1.155e-02,1.145e-02,1.135e-02,1.125e-02,1.115e-02,1.105e-02,1.096e-02,& +1.086e-02,1.076e-02,1.066e-02,1.056e-02,1.047e-02,1.037e-02,1.027e-02,1.017e-02,1.008e-02,9.980e-03,& +9.884e-03,9.787e-03,9.691e-03,9.595e-03,9.500e-03,9.404e-03,9.309e-03,9.214e-03,9.120e-03,9.025e-03,& +8.931e-03,8.837e-03,8.743e-03,8.650e-03,8.557e-03,8.464e-03,8.371e-03,8.279e-03,8.187e-03,8.095e-03,& +8.004e-03,7.913e-03,7.822e-03,7.732e-03,7.641e-03,7.552e-03,7.462e-03,7.373e-03,7.284e-03,7.195e-03,& +7.107e-03,7.019e-03,6.932e-03,6.844e-03,6.758e-03,6.671e-03,6.585e-03,6.499e-03,6.414e-03,6.329e-03,& +6.244e-03,6.160e-03,6.076e-03,5.993e-03,5.910e-03,5.827e-03,5.745e-03,5.663e-03,5.581e-03,5.500e-03,& +5.419e-03,5.339e-03,5.259e-03,5.180e-03,5.101e-03,5.023e-03,4.945e-03,4.867e-03,4.790e-03,4.713e-03,& +4.637e-03,4.561e-03,4.486e-03,4.411e-03,4.337e-03,4.263e-03,4.190e-03,4.117e-03,4.044e-03,3.972e-03/ + data (k_Brown(i),i=601,700)/& +3.901e-03,3.830e-03,3.760e-03,3.690e-03,3.620e-03,3.552e-03,3.483e-03,3.416e-03,3.348e-03,3.282e-03,& +3.215e-03,3.150e-03,3.085e-03,3.020e-03,2.956e-03,2.893e-03,2.830e-03,2.768e-03,2.706e-03,2.645e-03,& +2.585e-03,2.525e-03,2.465e-03,2.407e-03,2.348e-03,2.291e-03,2.234e-03,2.178e-03,2.122e-03,2.067e-03,& +2.012e-03,1.959e-03,1.905e-03,1.853e-03,1.801e-03,1.750e-03,1.699e-03,1.649e-03,1.600e-03,1.551e-03,& +1.503e-03,1.456e-03,1.409e-03,1.363e-03,1.318e-03,1.274e-03,1.230e-03,1.187e-03,1.144e-03,1.102e-03,& +1.061e-03,1.021e-03,9.811e-04,9.422e-04,9.040e-04,8.665e-04,8.297e-04,7.937e-04,7.584e-04,7.239e-04,& +6.901e-04,6.571e-04,6.248e-04,5.933e-04,5.626e-04,5.326e-04,5.034e-04,4.750e-04,4.473e-04,4.205e-04,& +3.944e-04,3.691e-04,3.446e-04,3.210e-04,2.981e-04,2.760e-04,2.548e-04,2.344e-04,2.148e-04,1.960e-04,& +1.780e-04,1.609e-04,1.446e-04,1.292e-04,1.146e-04,1.009e-04,8.804e-05,7.603e-05,6.488e-05,5.460e-05,& +4.519e-05,3.666e-05,2.901e-05,2.225e-05,1.637e-05,1.138e-05,7.297e-06,4.111e-06,1.830e-06,4.581e-07/ + data (k_Brown(i),i=701,2101)/1401*0./ + +! ******************************************************************************** +! Specific absorption coefficient of water +! ******************************************************************************** + + data (k_Cw(i),i=1,100)/& +5.800E-05,5.852E-05,5.900E-05,5.989E-05,6.100E-05,6.203E-05,6.300E-05,6.399E-05,6.500E-05,6.603E-05,& +6.700E-05,6.790E-05,6.900E-05,7.050E-05,7.200E-05,7.312E-05,7.400E-05,7.490E-05,7.600E-05,7.740E-05,& +7.900E-05,8.063E-05,8.200E-05,8.297E-05,8.400E-05,8.551E-05,8.700E-05,8.800E-05,8.900E-05,9.050E-05,& +9.200E-05,9.300E-05,9.400E-05,9.550E-05,9.700E-05,9.801E-05,9.900E-05,1.005E-04,1.020E-04,1.031E-04,& +1.040E-04,1.050E-04,1.060E-04,1.070E-04,1.080E-04,1.090E-04,1.100E-04,1.110E-04,1.120E-04,1.130E-04,& +1.140E-04,1.150E-04,1.160E-04,1.170E-04,1.180E-04,1.190E-04,1.200E-04,1.210E-04,1.220E-04,1.230E-04,& +1.240E-04,1.250E-04,1.260E-04,1.270E-04,1.280E-04,1.289E-04,1.300E-04,1.315E-04,1.330E-04,1.340E-04,& +1.350E-04,1.364E-04,1.380E-04,1.396E-04,1.410E-04,1.424E-04,1.440E-04,1.459E-04,1.480E-04,1.499E-04,& +1.520E-04,1.544E-04,1.570E-04,1.596E-04,1.620E-04,1.643E-04,1.670E-04,1.704E-04,1.740E-04,1.775E-04,& +1.810E-04,1.849E-04,1.890E-04,1.934E-04,1.980E-04,2.031E-04,2.090E-04,2.158E-04,2.230E-04,2.303E-04/ + data (k_Cw(i),i=101,200)/& +2.380E-04,2.463E-04,2.550E-04,2.640E-04,2.730E-04,2.819E-04,2.910E-04,3.004E-04,3.100E-04,3.194E-04,& +3.290E-04,3.390E-04,3.490E-04,3.588E-04,3.680E-04,3.767E-04,3.860E-04,3.962E-04,4.040E-04,4.069E-04,& +4.090E-04,4.138E-04,4.160E-04,4.112E-04,4.090E-04,4.176E-04,4.270E-04,4.268E-04,4.230E-04,4.237E-04,& +4.290E-04,4.371E-04,4.450E-04,4.506E-04,4.560E-04,4.631E-04,4.700E-04,4.748E-04,4.800E-04,4.879E-04,& +4.950E-04,4.983E-04,5.030E-04,5.141E-04,5.270E-04,5.363E-04,5.440E-04,5.532E-04,5.640E-04,5.759E-04,& +5.880E-04,5.998E-04,6.110E-04,6.215E-04,6.310E-04,6.391E-04,6.460E-04,6.520E-04,6.580E-04,6.647E-04,& +6.720E-04,6.793E-04,6.860E-04,6.920E-04,6.990E-04,7.084E-04,7.180E-04,7.257E-04,7.340E-04,7.455E-04,& +7.590E-04,7.729E-04,7.870E-04,8.020E-04,8.190E-04,8.386E-04,8.580E-04,8.754E-04,8.960E-04,9.238E-04,& +9.520E-04,9.745E-04,1.000E-03,1.037E-03,1.079E-03,1.119E-03,1.159E-03,1.204E-03,1.253E-03,1.304E-03,& +1.356E-03,1.408E-03,1.459E-03,1.510E-03,1.567E-03,1.635E-03,1.700E-03,1.758E-03,1.860E-03,2.042E-03/ + data (k_Cw(i),i=201,300)/& +2.224E-03,2.323E-03,2.366E-03,2.400E-03,2.448E-03,2.519E-03,2.587E-03,2.629E-03,2.653E-03,2.674E-03,& +2.691E-03,2.704E-03,2.715E-03,2.727E-03,2.740E-03,2.753E-03,2.764E-03,2.775E-03,2.785E-03,2.797E-03,& +2.810E-03,2.824E-03,2.839E-03,2.854E-03,2.868E-03,2.881E-03,2.893E-03,2.907E-03,2.922E-03,2.938E-03,& +2.955E-03,2.972E-03,2.988E-03,3.000E-03,3.011E-03,3.023E-03,3.038E-03,3.057E-03,3.076E-03,3.094E-03,& +3.111E-03,3.127E-03,3.144E-03,3.162E-03,3.181E-03,3.202E-03,3.223E-03,3.242E-03,3.263E-03,3.289E-03,& +3.315E-03,3.338E-03,3.362E-03,3.390E-03,3.423E-03,3.461E-03,3.508E-03,3.567E-03,3.636E-03,3.712E-03,& +3.791E-03,3.866E-03,3.931E-03,3.981E-03,4.019E-03,4.049E-03,4.072E-03,4.087E-03,4.098E-03,4.109E-03,& +4.122E-03,4.137E-03,4.150E-03,4.160E-03,4.173E-03,4.196E-03,4.223E-03,4.248E-03,4.270E-03,4.293E-03,& +4.318E-03,4.347E-03,4.381E-03,4.418E-03,4.458E-03,4.500E-03,4.545E-03,4.594E-03,4.646E-03,4.701E-03,& +4.760E-03,4.827E-03,4.903E-03,4.986E-03,5.071E-03,5.154E-03,5.244E-03,5.351E-03,5.470E-03,5.594E-03/ + data (k_Cw(i),i=301,400)/& +5.722E-03,5.855E-03,5.995E-03,6.146E-03,6.303E-03,6.463E-03,6.628E-03,6.804E-03,6.993E-03,7.197E-03,& +7.415E-03,7.647E-03,7.893E-03,8.157E-03,8.445E-03,8.763E-03,9.109E-03,9.479E-03,9.871E-03,1.029E-02,& +1.072E-02,1.119E-02,1.168E-02,1.218E-02,1.268E-02,1.319E-02,1.372E-02,1.428E-02,1.487E-02,1.551E-02,& +1.621E-02,1.699E-02,1.787E-02,1.886E-02,1.992E-02,2.101E-02,2.207E-02,2.306E-02,2.394E-02,2.469E-02,& +2.532E-02,2.583E-02,2.623E-02,2.652E-02,2.672E-02,2.689E-02,2.702E-02,2.713E-02,2.722E-02,2.728E-02,& +2.733E-02,2.738E-02,2.741E-02,2.745E-02,2.748E-02,2.751E-02,2.754E-02,2.758E-02,2.763E-02,2.767E-02,& +2.771E-02,2.773E-02,2.773E-02,2.774E-02,2.774E-02,2.773E-02,2.770E-02,2.766E-02,2.761E-02,2.757E-02,& +2.754E-02,2.752E-02,2.748E-02,2.741E-02,2.731E-02,2.720E-02,2.710E-02,2.701E-02,2.690E-02,2.675E-02,& +2.659E-02,2.645E-02,2.633E-02,2.624E-02,2.613E-02,2.593E-02,2.558E-02,2.523E-02,2.513E-02,2.501E-02,& +2.466E-02,2.447E-02,2.412E-02,2.389E-02,2.374E-02,2.355E-02,2.337E-02,2.318E-02,2.304E-02,2.281E-02/ + data (k_Cw(i),i=401,500)/& +2.246E-02,2.243E-02,2.238E-02,2.222E-02,2.204E-02,2.201E-02,2.204E-02,2.196E-02,2.177E-02,2.190E-02,& +2.188E-02,2.188E-02,2.198E-02,2.210E-02,2.223E-02,2.233E-02,2.248E-02,2.276E-02,2.304E-02,2.311E-02,& +2.329E-02,2.388E-02,2.446E-02,2.475E-02,2.516E-02,2.620E-02,2.769E-02,2.830E-02,2.914E-02,3.108E-02,& +3.214E-02,3.297E-02,3.459E-02,3.606E-02,3.662E-02,3.702E-02,3.788E-02,3.829E-02,3.854E-02,3.909E-02,& +3.949E-02,3.972E-02,4.000E-02,4.040E-02,4.057E-02,4.075E-02,4.115E-02,4.127E-02,4.149E-02,4.204E-02,& +4.199E-02,4.223E-02,4.254E-02,4.272E-02,4.280E-02,4.306E-02,4.360E-02,4.369E-02,4.379E-02,4.433E-02,& +4.454E-02,4.466E-02,4.505E-02,4.527E-02,4.552E-02,4.605E-02,4.658E-02,4.691E-02,4.705E-02,4.713E-02,& +4.752E-02,4.833E-02,4.867E-02,4.894E-02,4.960E-02,5.006E-02,5.050E-02,5.115E-02,5.153E-02,5.204E-02,& +5.298E-02,5.346E-02,5.386E-02,5.465E-02,5.528E-02,5.566E-02,5.596E-02,5.653E-02,5.745E-02,5.789E-02,& +5.831E-02,5.924E-02,5.982E-02,6.009E-02,6.035E-02,6.094E-02,6.185E-02,6.226E-02,6.269E-02,6.360E-02/ + data (k_Cw(i),i=501,600)/& +6.407E-02,6.458E-02,6.562E-02,6.636E-02,6.672E-02,6.699E-02,6.769E-02,6.900E-02,6.989E-02,7.037E-02,& +7.085E-02,7.187E-02,7.358E-02,7.486E-02,7.562E-02,7.630E-02,7.792E-02,8.085E-02,8.292E-02,8.410E-02,& +8.528E-02,8.801E-02,9.268E-02,9.584E-02,9.819E-02,1.012E-01,1.042E-01,1.066E-01,1.113E-01,1.194E-01,& +1.246E-01,1.281E-01,1.327E-01,1.374E-01,1.410E-01,1.465E-01,1.557E-01,1.635E-01,1.688E-01,1.732E-01,& +1.818E-01,1.963E-01,2.050E-01,2.106E-01,2.187E-01,2.287E-01,2.386E-01,2.468E-01,2.542E-01,2.701E-01,& +2.976E-01,3.153E-01,3.274E-01,3.438E-01,3.622E-01,3.785E-01,3.930E-01,4.068E-01,4.184E-01,4.273E-01,& +4.385E-01,4.538E-01,4.611E-01,4.633E-01,4.663E-01,4.701E-01,4.733E-01,4.756E-01,4.772E-01,4.785E-01,& +4.800E-01,4.814E-01,4.827E-01,4.843E-01,4.864E-01,4.870E-01,4.867E-01,4.864E-01,4.857E-01,4.841E-01,& +4.821E-01,4.804E-01,4.786E-01,4.764E-01,4.738E-01,4.710E-01,4.677E-01,4.641E-01,4.604E-01,4.570E-01,& +4.532E-01,4.482E-01,4.434E-01,4.397E-01,4.362E-01,4.316E-01,4.265E-01,4.215E-01,4.168E-01,4.121E-01/ + data (k_Cw(i),i=601,700)/& +4.072E-01,4.017E-01,3.963E-01,3.915E-01,3.868E-01,3.816E-01,3.760E-01,3.701E-01,3.640E-01,3.581E-01,& +3.521E-01,3.461E-01,3.402E-01,3.349E-01,3.297E-01,3.243E-01,3.191E-01,3.141E-01,3.086E-01,3.022E-01,& +2.957E-01,2.897E-01,2.840E-01,2.782E-01,2.724E-01,2.672E-01,2.621E-01,2.566E-01,2.506E-01,2.444E-01,& +2.391E-01,2.357E-01,2.331E-01,2.299E-01,2.251E-01,2.198E-01,2.151E-01,2.109E-01,2.064E-01,2.020E-01,& +1.981E-01,1.944E-01,1.904E-01,1.868E-01,1.841E-01,1.818E-01,1.790E-01,1.752E-01,1.715E-01,1.687E-01,& +1.664E-01,1.639E-01,1.613E-01,1.586E-01,1.562E-01,1.545E-01,1.532E-01,1.522E-01,1.510E-01,1.495E-01,& +1.475E-01,1.457E-01,1.447E-01,1.442E-01,1.438E-01,1.433E-01,1.426E-01,1.418E-01,1.412E-01,1.410E-01,& +1.409E-01,1.408E-01,1.406E-01,1.405E-01,1.408E-01,1.414E-01,1.426E-01,1.435E-01,1.438E-01,1.439E-01,& +1.443E-01,1.456E-01,1.475E-01,1.498E-01,1.519E-01,1.534E-01,1.547E-01,1.561E-01,1.580E-01,1.604E-01,& +1.632E-01,1.659E-01,1.677E-01,1.693E-01,1.712E-01,1.739E-01,1.777E-01,1.824E-01,1.866E-01,1.890E-01/ + data (k_Cw(i),i=701,800)/& +1.906E-01,1.929E-01,1.967E-01,2.005E-01,2.031E-01,2.051E-01,2.079E-01,2.123E-01,2.166E-01,2.196E-01,& +2.219E-01,2.251E-01,2.298E-01,2.337E-01,2.346E-01,2.342E-01,2.353E-01,2.397E-01,2.450E-01,2.491E-01,& +2.528E-01,2.578E-01,2.650E-01,2.719E-01,2.765E-01,2.811E-01,2.891E-01,3.023E-01,3.164E-01,3.271E-01,& +3.378E-01,3.533E-01,3.770E-01,4.037E-01,4.281E-01,4.502E-01,4.712E-01,4.932E-01,5.202E-01,5.572E-01,& +6.052E-01,6.520E-01,6.863E-01,7.159E-01,7.535E-01,8.064E-01,8.597E-01,8.981E-01,9.253E-01,9.493E-01,& +9.769E-01,1.008E+00,1.041E+00,1.073E+00,1.100E+00,1.119E+00,1.131E+00,1.140E+00,1.150E+00,1.160E+00,& +1.170E+00,1.181E+00,1.190E+00,1.194E+00,1.196E+00,1.197E+00,1.200E+00,1.203E+00,1.205E+00,1.206E+00,& +1.207E+00,1.213E+00,1.223E+00,1.232E+00,1.234E+00,1.232E+00,1.229E+00,1.230E+00,1.233E+00,1.236E+00,& +1.239E+00,1.241E+00,1.244E+00,1.248E+00,1.252E+00,1.256E+00,1.258E+00,1.260E+00,1.262E+00,1.265E+00,& +1.267E+00,1.270E+00,1.272E+00,1.275E+00,1.277E+00,1.280E+00,1.282E+00,1.283E+00,1.283E+00,1.279E+00/ + data (k_Cw(i),i=801,900)/& +1.272E+00,1.266E+00,1.267E+00,1.271E+00,1.273E+00,1.271E+00,1.265E+00,1.260E+00,1.258E+00,1.258E+00,& +1.257E+00,1.252E+00,1.247E+00,1.243E+00,1.243E+00,1.243E+00,1.240E+00,1.233E+00,1.224E+00,1.216E+00,& +1.214E+00,1.214E+00,1.213E+00,1.210E+00,1.205E+00,1.200E+00,1.199E+00,1.198E+00,1.197E+00,1.194E+00,& +1.189E+00,1.184E+00,1.180E+00,1.176E+00,1.171E+00,1.166E+00,1.161E+00,1.158E+00,1.157E+00,1.157E+00,& +1.155E+00,1.152E+00,1.148E+00,1.142E+00,1.138E+00,1.133E+00,1.130E+00,1.126E+00,1.123E+00,1.120E+00,& +1.116E+00,1.111E+00,1.107E+00,1.103E+00,1.101E+00,1.101E+00,1.101E+00,1.101E+00,1.100E+00,1.098E+00,& +1.094E+00,1.089E+00,1.085E+00,1.084E+00,1.083E+00,1.083E+00,1.082E+00,1.081E+00,1.080E+00,1.079E+00,& +1.080E+00,1.083E+00,1.087E+00,1.093E+00,1.099E+00,1.104E+00,1.107E+00,1.109E+00,1.111E+00,1.115E+00,& +1.121E+00,1.129E+00,1.137E+00,1.147E+00,1.156E+00,1.164E+00,1.170E+00,1.175E+00,1.181E+00,1.188E+00,& +1.196E+00,1.206E+00,1.216E+00,1.227E+00,1.239E+00,1.252E+00,1.267E+00,1.283E+00,1.297E+00,1.310E+00/ + data (k_Cw(i),i=901,1000)/& +1.323E+00,1.336E+00,1.351E+00,1.370E+00,1.392E+00,1.416E+00,1.440E+00,1.465E+00,1.489E+00,1.511E+00,& +1.532E+00,1.555E+00,1.580E+00,1.610E+00,1.642E+00,1.672E+00,1.701E+00,1.728E+00,1.758E+00,1.791E+00,& +1.831E+00,1.872E+00,1.911E+00,1.943E+00,1.974E+00,2.007E+00,2.047E+00,2.098E+00,2.153E+00,2.203E+00,& +2.243E+00,2.277E+00,2.312E+00,2.357E+00,2.415E+00,2.479E+00,2.540E+00,2.590E+00,2.631E+00,2.666E+00,& +2.701E+00,2.738E+00,2.780E+00,2.829E+00,2.889E+00,2.960E+00,3.033E+00,3.097E+00,3.146E+00,3.181E+00,& +3.226E+00,3.267E+00,3.319E+00,3.363E+00,3.412E+00,3.449E+00,3.504E+00,3.544E+00,3.600E+00,3.648E+00,& +3.701E+00,3.752E+00,3.802E+00,3.871E+00,3.927E+00,3.985E+00,4.064E+00,4.125E+00,4.216E+00,4.302E+00,& +4.389E+00,4.504E+00,4.630E+00,4.737E+00,4.904E+00,5.092E+00,5.260E+00,5.479E+00,5.720E+00,6.006E+00,& +6.242E+00,6.580E+00,6.927E+00,7.313E+00,7.633E+00,8.089E+00,8.545E+00,9.030E+00,9.591E+00,1.002E+01,& +1.063E+01,1.122E+01,1.184E+01,1.245E+01,1.316E+01,1.369E+01,1.434E+01,1.509E+01,1.578E+01,1.646E+01/ + data (k_Cw(i),i=1001,1100)/& +1.714E+01,1.781E+01,1.854E+01,1.919E+01,1.980E+01,2.029E+01,2.089E+01,2.146E+01,2.202E+01,2.260E+01,& +2.313E+01,2.360E+01,2.407E+01,2.450E+01,2.493E+01,2.533E+01,2.571E+01,2.606E+01,2.641E+01,2.673E+01,& +2.701E+01,2.729E+01,2.756E+01,2.782E+01,2.806E+01,2.835E+01,2.856E+01,2.875E+01,2.892E+01,2.908E+01,& +2.926E+01,2.940E+01,2.956E+01,2.966E+01,2.982E+01,2.993E+01,3.003E+01,3.014E+01,3.023E+01,3.029E+01,& +3.036E+01,3.042E+01,3.046E+01,3.049E+01,3.052E+01,3.053E+01,3.055E+01,3.056E+01,3.056E+01,3.055E+01,& +3.054E+01,3.051E+01,3.049E+01,3.045E+01,3.041E+01,3.035E+01,3.029E+01,3.023E+01,3.014E+01,3.006E+01,& +2.998E+01,2.983E+01,2.971E+01,2.957E+01,2.936E+01,2.917E+01,2.899E+01,2.872E+01,2.851E+01,2.829E+01,& +2.800E+01,2.777E+01,2.754E+01,2.722E+01,2.699E+01,2.664E+01,2.638E+01,2.611E+01,2.581E+01,2.555E+01,& +2.522E+01,2.497E+01,2.468E+01,2.443E+01,2.413E+01,2.388E+01,2.364E+01,2.332E+01,2.307E+01,2.274E+01,& +2.250E+01,2.218E+01,2.193E+01,2.163E+01,2.139E+01,2.107E+01,2.082E+01,2.052E+01,2.025E+01,2.001E+01/ + data (k_Cw(i),i=1101,1200)/& +1.972E+01,1.951E+01,1.924E+01,1.900E+01,1.874E+01,1.847E+01,1.827E+01,1.802E+01,1.784E+01,1.758E+01,& +1.734E+01,1.712E+01,1.688E+01,1.671E+01,1.647E+01,1.623E+01,1.606E+01,1.583E+01,1.562E+01,1.545E+01,& +1.525E+01,1.504E+01,1.489E+01,1.468E+01,1.447E+01,1.432E+01,1.413E+01,1.395E+01,1.381E+01,1.364E+01,& +1.348E+01,1.329E+01,1.316E+01,1.298E+01,1.282E+01,1.265E+01,1.254E+01,1.238E+01,1.223E+01,1.206E+01,& +1.193E+01,1.181E+01,1.166E+01,1.152E+01,1.137E+01,1.126E+01,1.114E+01,1.100E+01,1.088E+01,1.075E+01,& +1.064E+01,1.054E+01,1.044E+01,1.032E+01,1.022E+01,1.011E+01,1.001E+01,9.912E+00,9.839E+00,9.754E+00,& +9.660E+00,9.563E+00,9.477E+00,9.383E+00,9.305E+00,9.202E+00,9.133E+00,9.047E+00,8.977E+00,8.898E+00,& +8.820E+00,8.742E+00,8.665E+00,8.588E+00,8.509E+00,8.448E+00,8.364E+00,8.295E+00,8.234E+00,8.157E+00,& +8.104E+00,8.036E+00,7.959E+00,7.890E+00,7.834E+00,7.773E+00,7.712E+00,7.654E+00,7.609E+00,7.548E+00,& +7.495E+00,7.432E+00,7.374E+00,7.315E+00,7.252E+00,7.203E+00,7.164E+00,7.124E+00,7.084E+00,7.041E+00/ + data (k_Cw(i),i=1201,1300)/& +6.987E+00,6.943E+00,6.910E+00,6.865E+00,6.828E+00,6.776E+00,6.742E+00,6.714E+00,6.695E+00,6.654E+00,& +6.630E+00,6.599E+00,6.567E+00,6.526E+00,6.501E+00,6.474E+00,6.449E+00,6.420E+00,6.401E+00,6.363E+00,& +6.345E+00,6.309E+00,6.282E+00,6.250E+00,6.214E+00,6.186E+00,6.163E+00,6.130E+00,6.121E+00,6.091E+00,& +6.076E+00,6.053E+00,6.048E+00,6.016E+00,6.005E+00,5.982E+00,5.973E+00,5.947E+00,5.940E+00,5.919E+00,& +5.911E+00,5.887E+00,5.875E+00,5.846E+00,5.826E+00,5.798E+00,5.787E+00,5.751E+00,5.746E+00,5.718E+00,& +5.705E+00,5.685E+00,5.684E+00,5.657E+00,5.658E+00,5.644E+00,5.648E+00,5.626E+00,5.626E+00,5.619E+00,& +5.618E+00,5.603E+00,5.614E+00,5.597E+00,5.603E+00,5.582E+00,5.584E+00,5.564E+00,5.563E+00,5.547E+00,& +5.545E+00,5.536E+00,5.542E+00,5.529E+00,5.532E+00,5.525E+00,5.533E+00,5.528E+00,5.529E+00,5.516E+00,& +5.524E+00,5.516E+00,5.526E+00,5.520E+00,5.520E+00,5.516E+00,5.522E+00,5.511E+00,5.527E+00,5.511E+00,& +5.519E+00,5.515E+00,5.520E+00,5.510E+00,5.518E+00,5.523E+00,5.538E+00,5.535E+00,5.544E+00,5.557E+00/ + data (k_Cw(i),i=1301,1400)/& +5.571E+00,5.583E+00,5.606E+00,5.607E+00,5.629E+00,5.636E+00,5.664E+00,5.670E+00,5.693E+00,5.702E+00,& +5.733E+00,5.752E+00,5.766E+00,5.776E+00,5.797E+00,5.811E+00,5.829E+00,5.842E+00,5.877E+00,5.891E+00,& +5.930E+00,5.945E+00,5.972E+00,5.999E+00,6.025E+00,6.051E+00,6.087E+00,6.096E+00,6.136E+00,6.166E+00,& +6.198E+00,6.219E+00,6.256E+00,6.284E+00,6.335E+00,6.369E+00,6.392E+00,6.445E+00,6.493E+00,6.517E+00,& +6.571E+00,6.617E+00,6.658E+00,6.689E+00,6.748E+00,6.796E+00,6.842E+00,6.897E+00,6.955E+00,7.003E+00,& +7.054E+00,7.111E+00,7.179E+00,7.235E+00,7.274E+00,7.339E+00,7.414E+00,7.481E+00,7.536E+00,7.594E+00,& +7.669E+00,7.734E+00,7.776E+00,7.833E+00,7.893E+00,7.952E+00,8.000E+00,8.045E+00,8.103E+00,8.155E+00,& +8.205E+00,8.241E+00,8.264E+00,8.321E+00,8.352E+00,8.394E+00,8.430E+00,8.448E+00,8.477E+00,8.512E+00,& +8.535E+00,8.562E+00,8.593E+00,8.618E+00,8.640E+00,8.670E+00,8.689E+00,8.720E+00,8.738E+00,8.755E+00,& +8.777E+00,8.778E+00,8.778E+00,8.794E+00,8.805E+00,8.807E+00,8.809E+00,8.811E+00,8.799E+00,8.795E+00/ + data (k_Cw(i),i=1401,1500)/& +8.789E+00,8.779E+00,8.767E+00,8.754E+00,8.750E+00,8.738E+00,8.739E+00,8.735E+00,8.744E+00,8.753E+00,& +8.755E+00,8.780E+00,8.787E+00,8.790E+00,8.798E+00,8.794E+00,8.811E+00,8.820E+00,8.836E+00,8.845E+00,& +8.854E+00,8.858E+00,8.868E+00,8.869E+00,8.884E+00,8.888E+00,8.900E+00,8.922E+00,8.951E+00,8.973E+00,& +9.010E+00,9.034E+00,9.110E+00,9.146E+00,9.195E+00,9.259E+00,9.315E+00,9.380E+00,9.457E+00,9.535E+00,& +9.633E+00,9.723E+00,9.824E+00,9.935E+00,1.005E+01,1.018E+01,1.031E+01,1.042E+01,1.059E+01,1.075E+01,& +1.094E+01,1.110E+01,1.139E+01,1.160E+01,1.184E+01,1.208E+01,1.235E+01,1.266E+01,1.301E+01,1.334E+01,& +1.375E+01,1.412E+01,1.478E+01,1.529E+01,1.586E+01,1.641E+01,1.709E+01,1.774E+01,1.853E+01,1.925E+01,& +2.051E+01,2.148E+01,2.250E+01,2.367E+01,2.483E+01,2.622E+01,2.751E+01,2.972E+01,3.144E+01,3.317E+01,& +3.504E+01,3.725E+01,3.927E+01,4.269E+01,4.530E+01,4.789E+01,5.060E+01,5.360E+01,5.761E+01,6.088E+01,& +6.401E+01,6.720E+01,7.059E+01,7.497E+01,7.841E+01,8.157E+01,8.469E+01,8.752E+01,9.189E+01,9.456E+01/ + data (k_Cw(i),i=1501,1600)/& +9.722E+01,9.995E+01,1.033E+02,1.057E+02,1.078E+02,1.097E+02,1.123E+02,1.140E+02,1.157E+02,1.171E+02,& +1.190E+02,1.203E+02,1.215E+02,1.226E+02,1.240E+02,1.248E+02,1.257E+02,1.265E+02,1.275E+02,1.281E+02,& +1.286E+02,1.292E+02,1.296E+02,1.299E+02,1.303E+02,1.304E+02,1.306E+02,1.306E+02,1.306E+02,1.305E+02,& +1.304E+02,1.301E+02,1.299E+02,1.296E+02,1.291E+02,1.287E+02,1.282E+02,1.275E+02,1.270E+02,1.264E+02,& +1.256E+02,1.249E+02,1.242E+02,1.232E+02,1.224E+02,1.216E+02,1.206E+02,1.197E+02,1.190E+02,1.178E+02,& +1.170E+02,1.157E+02,1.149E+02,1.140E+02,1.128E+02,1.118E+02,1.110E+02,1.097E+02,1.088E+02,1.076E+02,& +1.066E+02,1.058E+02,1.044E+02,1.036E+02,1.023E+02,1.014E+02,1.005E+02,9.928E+01,9.831E+01,9.711E+01,& +9.631E+01,9.488E+01,9.412E+01,9.341E+01,9.206E+01,9.121E+01,9.009E+01,8.929E+01,8.804E+01,8.725E+01,& +8.611E+01,8.532E+01,8.460E+01,8.336E+01,8.262E+01,8.151E+01,8.076E+01,7.973E+01,7.904E+01,7.800E+01,& +7.723E+01,7.628E+01,7.557E+01,7.463E+01,7.392E+01,7.298E+01,7.234E+01,7.141E+01,7.082E+01,6.986E+01/ + data (k_Cw(i),i=1601,1700)/& +6.924E+01,6.865E+01,6.779E+01,6.688E+01,6.634E+01,6.548E+01,6.490E+01,6.412E+01,6.358E+01,6.281E+01,& +6.232E+01,6.156E+01,6.105E+01,6.029E+01,5.980E+01,5.907E+01,5.857E+01,5.788E+01,5.746E+01,5.680E+01,& +5.632E+01,5.566E+01,5.503E+01,5.463E+01,5.398E+01,5.356E+01,5.294E+01,5.256E+01,5.197E+01,5.138E+01,& +5.098E+01,5.047E+01,5.006E+01,4.951E+01,4.915E+01,4.860E+01,4.806E+01,4.773E+01,4.718E+01,4.685E+01,& +4.635E+01,4.584E+01,4.553E+01,4.503E+01,4.473E+01,4.426E+01,4.379E+01,4.348E+01,4.302E+01,4.273E+01,& +4.228E+01,4.186E+01,4.155E+01,4.115E+01,4.072E+01,4.046E+01,4.002E+01,3.975E+01,3.934E+01,3.894E+01,& +3.868E+01,3.827E+01,3.790E+01,3.762E+01,3.726E+01,3.687E+01,3.664E+01,3.628E+01,3.592E+01,3.568E+01,& +3.536E+01,3.499E+01,3.479E+01,3.447E+01,3.413E+01,3.392E+01,3.363E+01,3.329E+01,3.309E+01,3.280E+01,& +3.251E+01,3.231E+01,3.200E+01,3.172E+01,3.154E+01,3.127E+01,3.097E+01,3.071E+01,3.052E+01,3.025E+01,& +2.999E+01,2.980E+01,2.958E+01,2.929E+01,2.906E+01,2.888E+01,2.865E+01,2.840E+01,2.822E+01,2.799E+01/ + data (k_Cw(i),i=1701,1800)/& +2.776E+01,2.751E+01,2.737E+01,2.713E+01,2.692E+01,2.671E+01,2.657E+01,2.637E+01,2.617E+01,2.597E+01,& +2.584E+01,2.565E+01,2.547E+01,2.528E+01,2.518E+01,2.501E+01,2.485E+01,2.466E+01,2.455E+01,2.438E+01,& +2.420E+01,2.401E+01,2.386E+01,2.374E+01,2.358E+01,2.342E+01,2.328E+01,2.318E+01,2.304E+01,2.289E+01,& +2.275E+01,2.262E+01,2.252E+01,2.239E+01,2.227E+01,2.214E+01,2.202E+01,2.194E+01,2.183E+01,2.172E+01,& +2.162E+01,2.150E+01,2.140E+01,2.133E+01,2.123E+01,2.112E+01,2.102E+01,2.091E+01,2.085E+01,2.077E+01,& +2.067E+01,2.058E+01,2.049E+01,2.040E+01,2.033E+01,2.027E+01,2.018E+01,2.010E+01,2.002E+01,1.995E+01,& +1.987E+01,1.983E+01,1.976E+01,1.969E+01,1.963E+01,1.958E+01,1.952E+01,1.946E+01,1.942E+01,1.938E+01,& +1.933E+01,1.928E+01,1.923E+01,1.918E+01,1.913E+01,1.909E+01,1.904E+01,1.900E+01,1.896E+01,1.889E+01,& +1.884E+01,1.880E+01,1.874E+01,1.870E+01,1.866E+01,1.860E+01,1.856E+01,1.852E+01,1.849E+01,1.845E+01,& +1.843E+01,1.839E+01,1.837E+01,1.837E+01,1.838E+01,1.837E+01,1.836E+01,1.835E+01,1.835E+01,1.835E+01/ + data (k_Cw(i),i=1801,1900)/& +1.834E+01,1.833E+01,1.833E+01,1.833E+01,1.834E+01,1.833E+01,1.834E+01,1.834E+01,1.832E+01,1.831E+01,& +1.829E+01,1.828E+01,1.828E+01,1.829E+01,1.829E+01,1.830E+01,1.832E+01,1.835E+01,1.836E+01,1.837E+01,& +1.837E+01,1.838E+01,1.837E+01,1.840E+01,1.842E+01,1.843E+01,1.846E+01,1.849E+01,1.851E+01,1.854E+01,& +1.857E+01,1.858E+01,1.860E+01,1.864E+01,1.865E+01,1.867E+01,1.870E+01,1.875E+01,1.879E+01,1.883E+01,& +1.888E+01,1.893E+01,1.897E+01,1.903E+01,1.908E+01,1.913E+01,1.919E+01,1.924E+01,1.929E+01,1.934E+01,& +1.940E+01,1.946E+01,1.951E+01,1.961E+01,1.966E+01,1.973E+01,1.980E+01,1.985E+01,1.991E+01,1.997E+01,& +2.004E+01,2.013E+01,2.020E+01,2.027E+01,2.038E+01,2.046E+01,2.054E+01,2.062E+01,2.071E+01,2.079E+01,& +2.087E+01,2.094E+01,2.103E+01,2.111E+01,2.126E+01,2.135E+01,2.145E+01,2.153E+01,2.164E+01,2.174E+01,& +2.183E+01,2.192E+01,2.202E+01,2.212E+01,2.223E+01,2.234E+01,2.245E+01,2.264E+01,2.276E+01,2.287E+01,& +2.301E+01,2.313E+01,2.327E+01,2.338E+01,2.351E+01,2.363E+01,2.377E+01,2.385E+01,2.409E+01,2.418E+01/ + data (k_Cw(i),i=1901,2000)/& +2.433E+01,2.444E+01,2.459E+01,2.470E+01,2.485E+01,2.495E+01,2.523E+01,2.534E+01,2.549E+01,2.564E+01,& +2.579E+01,2.592E+01,2.611E+01,2.623E+01,2.653E+01,2.664E+01,2.681E+01,2.695E+01,2.712E+01,2.727E+01,& +2.744E+01,2.756E+01,2.789E+01,2.802E+01,2.819E+01,2.838E+01,2.855E+01,2.869E+01,2.903E+01,2.916E+01,& +2.934E+01,2.951E+01,2.969E+01,2.988E+01,3.002E+01,3.038E+01,3.054E+01,3.073E+01,3.092E+01,3.107E+01,& +3.145E+01,3.160E+01,3.180E+01,3.199E+01,3.219E+01,3.238E+01,3.272E+01,3.290E+01,3.311E+01,3.331E+01,& +3.348E+01,3.388E+01,3.404E+01,3.426E+01,3.447E+01,3.468E+01,3.486E+01,3.528E+01,3.547E+01,3.570E+01,& +3.592E+01,3.610E+01,3.656E+01,3.675E+01,3.697E+01,3.716E+01,3.761E+01,3.777E+01,3.801E+01,3.827E+01,& +3.848E+01,3.892E+01,3.913E+01,3.938E+01,3.957E+01,4.007E+01,4.024E+01,4.050E+01,4.078E+01,4.096E+01,& +4.147E+01,4.167E+01,4.196E+01,4.220E+01,4.268E+01,4.293E+01,4.319E+01,4.342E+01,4.388E+01,4.413E+01,& +4.439E+01,4.464E+01,4.513E+01,4.538E+01,4.565E+01,4.590E+01,4.638E+01,4.663E+01,4.690E+01,4.714E+01/ + data (k_Cw(i),i=2001,2101)/& +4.764E+01,4.787E+01,4.817E+01,4.836E+01,4.894E+01,4.917E+01,4.940E+01,4.997E+01,5.021E+01,5.050E+01,& +5.078E+01,5.131E+01,5.159E+01,5.191E+01,5.246E+01,5.275E+01,5.310E+01,5.339E+01,5.401E+01,5.429E+01,& +5.462E+01,5.523E+01,5.555E+01,5.588E+01,5.618E+01,5.686E+01,5.713E+01,5.746E+01,5.808E+01,5.841E+01,& +5.878E+01,5.946E+01,5.976E+01,6.009E+01,6.039E+01,6.107E+01,6.146E+01,6.180E+01,6.250E+01,6.286E+01,& +6.316E+01,6.392E+01,6.427E+01,6.462E+01,6.539E+01,6.574E+01,6.609E+01,6.685E+01,6.725E+01,6.759E+01,& +6.842E+01,6.881E+01,6.918E+01,7.009E+01,7.046E+01,7.084E+01,7.174E+01,7.212E+01,7.249E+01,7.340E+01,& +7.381E+01,7.423E+01,7.514E+01,7.554E+01,7.591E+01,7.675E+01,7.718E+01,7.801E+01,7.839E+01,7.880E+01,& +7.970E+01,8.005E+01,8.046E+01,8.136E+01,8.173E+01,8.215E+01,8.295E+01,8.338E+01,8.423E+01,8.474E+01,& +8.510E+01,8.584E+01,8.617E+01,8.637E+01,8.708E+01,8.762E+01,8.884E+01,8.904E+01,8.945E+01,9.055E+01,& +9.089E+01,9.134E+01,9.204E+01,9.244E+01,9.308E+01,9.333E+01,9.358E+01,9.416E+01,9.448E+01,9.499E+01,& +9.530E+01/ + + +! ******************************************************************************** +! Specific absorption coefficient of dry matter +! ******************************************************************************** + + data (k_Cm(i),i=1,100)/& +1.097E+02,1.037E+02,9.798E+01,9.244E+01,8.713E+01,8.231E+01,7.806E+01,7.404E+01,7.013E+01,6.654E+01,& +6.300E+01,5.954E+01,5.616E+01,5.301E+01,5.001E+01,4.723E+01,4.463E+01,4.220E+01,3.996E+01,3.780E+01,& +3.567E+01,3.362E+01,3.170E+01,2.993E+01,2.832E+01,2.679E+01,2.535E+01,2.402E+01,2.276E+01,2.150E+01,& +2.024E+01,1.901E+01,1.785E+01,1.676E+01,1.575E+01,1.481E+01,1.392E+01,1.312E+01,1.233E+01,1.161E+01,& +1.096E+01,1.041E+01,9.924E+00,9.410E+00,8.947E+00,8.508E+00,8.087E+00,7.640E+00,7.269E+00,6.939E+00,& +6.660E+00,6.422E+00,6.222E+00,6.010E+00,5.782E+00,5.573E+00,5.370E+00,5.173E+00,4.946E+00,4.761E+00,& +4.575E+00,4.419E+00,4.259E+00,4.117E+00,4.006E+00,3.945E+00,3.853E+00,3.784E+00,3.671E+00,3.554E+00,& +3.462E+00,3.364E+00,3.282E+00,3.184E+00,3.102E+00,3.051E+00,2.983E+00,2.947E+00,2.913E+00,2.869E+00,& +2.803E+00,2.777E+00,2.751E+00,2.726E+00,2.702E+00,2.679E+00,2.656E+00,2.634E+00,2.613E+00,2.593E+00,& +2.573E+00,2.554E+00,2.536E+00,2.519E+00,2.502E+00,2.486E+00,2.471E+00,2.457E+00,2.443E+00,2.430E+00/ + data (k_Cm(i),i=101,200)/& +2.417E+00,2.405E+00,2.394E+00,2.384E+00,2.374E+00,2.365E+00,2.356E+00,2.348E+00,2.341E+00,2.334E+00,& +2.328E+00,2.323E+00,2.318E+00,2.314E+00,2.310E+00,2.307E+00,2.304E+00,2.303E+00,2.301E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=201,300)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=301,400)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=401,500)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=501,600)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=601,700)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=701,800)/& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,& +2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00,2.300E+00/ + data (k_Cm(i),i=801,900)/& +2.300E+00,2.300E+00,2.301E+00,2.301E+00,2.302E+00,2.303E+00,2.305E+00,2.306E+00,2.308E+00,2.310E+00,& +2.312E+00,2.315E+00,2.318E+00,2.320E+00,2.323E+00,2.327E+00,2.330E+00,2.334E+00,2.338E+00,2.342E+00,& +2.346E+00,2.350E+00,2.354E+00,2.359E+00,2.364E+00,2.369E+00,2.374E+00,2.379E+00,2.384E+00,2.389E+00,& +2.395E+00,2.400E+00,2.406E+00,2.412E+00,2.418E+00,2.424E+00,2.430E+00,2.436E+00,2.442E+00,2.448E+00,& +2.454E+00,2.461E+00,2.467E+00,2.473E+00,2.480E+00,2.486E+00,2.493E+00,2.499E+00,2.506E+00,2.512E+00,& +2.519E+00,2.525E+00,2.532E+00,2.538E+00,2.545E+00,2.551E+00,2.558E+00,2.564E+00,2.570E+00,2.577E+00,& +2.583E+00,2.589E+00,2.595E+00,2.601E+00,2.607E+00,2.613E+00,2.619E+00,2.625E+00,2.631E+00,2.636E+00,& +2.642E+00,2.647E+00,2.652E+00,2.657E+00,2.662E+00,2.667E+00,2.672E+00,2.677E+00,2.681E+00,2.685E+00,& +2.689E+00,2.693E+00,2.697E+00,2.701E+00,2.704E+00,2.708E+00,2.711E+00,2.714E+00,2.716E+00,2.719E+00,& +2.721E+00,2.723E+00,2.725E+00,2.726E+00,2.728E+00,2.729E+00,2.730E+00,2.730E+00,2.731E+00,2.731E+00/ + data (k_Cm(i),i=901,1000)/& +2.721E+00,2.736E+00,2.728E+00,2.719E+00,2.712E+00,2.698E+00,2.702E+00,2.691E+00,2.688E+00,2.686E+00,& +2.682E+00,2.676E+00,2.675E+00,2.677E+00,2.670E+00,2.671E+00,2.668E+00,2.670E+00,2.674E+00,2.674E+00,& +2.683E+00,2.674E+00,2.675E+00,2.682E+00,2.683E+00,2.665E+00,2.661E+00,2.668E+00,2.670E+00,2.674E+00,& +2.664E+00,2.661E+00,2.665E+00,2.668E+00,2.681E+00,2.686E+00,2.684E+00,2.697E+00,2.712E+00,2.720E+00,& +2.717E+00,2.726E+00,2.744E+00,2.743E+00,2.751E+00,2.763E+00,2.778E+00,2.793E+00,2.818E+00,2.835E+00,& +2.865E+00,2.879E+00,2.899E+00,2.918E+00,2.936E+00,2.953E+00,2.966E+00,2.977E+00,2.981E+00,2.942E+00,& +2.888E+00,2.864E+00,2.877E+00,2.886E+00,2.888E+00,2.891E+00,2.899E+00,2.887E+00,2.884E+00,2.900E+00,& +2.929E+00,2.969E+00,3.014E+00,3.053E+00,3.075E+00,3.111E+00,3.128E+00,3.130E+00,3.103E+00,3.051E+00,& +2.980E+00,2.941E+00,2.920E+00,2.931E+00,2.950E+00,2.979E+00,3.025E+00,3.048E+00,3.066E+00,3.087E+00,& +3.099E+00,3.090E+00,3.088E+00,3.081E+00,3.086E+00,3.071E+00,3.065E+00,3.069E+00,3.067E+00,3.085E+00/ + data (k_Cm(i),i=1001,1100)/& +3.094E+00,3.110E+00,3.136E+00,3.149E+00,3.158E+00,3.191E+00,3.230E+00,3.266E+00,3.298E+00,3.356E+00,& +3.419E+00,3.476E+00,3.534E+00,3.584E+00,3.632E+00,3.708E+00,3.775E+00,3.847E+00,3.931E+00,3.987E+00,& +4.071E+00,4.156E+00,4.242E+00,4.320E+00,4.395E+00,4.480E+00,4.561E+00,4.638E+00,4.708E+00,4.782E+00,& +4.846E+00,4.906E+00,4.974E+00,5.026E+00,5.071E+00,5.131E+00,5.179E+00,5.220E+00,5.271E+00,5.322E+00,& +5.358E+00,5.403E+00,5.441E+00,5.460E+00,5.481E+00,5.500E+00,5.523E+00,5.548E+00,5.560E+00,5.575E+00,& +5.582E+00,5.597E+00,5.611E+00,5.639E+00,5.653E+00,5.675E+00,5.682E+00,5.685E+00,5.680E+00,5.689E+00,& +5.711E+00,5.723E+00,5.715E+00,5.716E+00,5.732E+00,5.741E+00,5.743E+00,5.752E+00,5.745E+00,5.744E+00,& +5.757E+00,5.766E+00,5.781E+00,5.787E+00,5.798E+00,5.810E+00,5.808E+00,5.815E+00,5.825E+00,5.824E+00,& +5.827E+00,5.854E+00,5.878E+00,5.900E+00,5.908E+00,5.922E+00,5.940E+00,5.962E+00,5.963E+00,5.966E+00,& +5.982E+00,5.990E+00,5.994E+00,6.016E+00,6.014E+00,6.025E+00,6.008E+00,6.022E+00,6.021E+00,6.027E+00/ + data (k_Cm(i),i=1101,1200)/& +6.027E+00,6.035E+00,6.025E+00,6.009E+00,5.990E+00,5.987E+00,5.984E+00,5.971E+00,5.971E+00,5.973E+00,& +5.951E+00,5.952E+00,5.939E+00,5.933E+00,5.931E+00,5.925E+00,5.909E+00,5.897E+00,5.884E+00,5.881E+00,& +5.876E+00,5.856E+00,5.843E+00,5.830E+00,5.818E+00,5.807E+00,5.799E+00,5.792E+00,5.776E+00,5.783E+00,& +5.776E+00,5.767E+00,5.762E+00,5.769E+00,5.756E+00,5.762E+00,5.737E+00,5.740E+00,5.757E+00,5.756E+00,& +5.751E+00,5.754E+00,5.751E+00,5.750E+00,5.744E+00,5.744E+00,5.754E+00,5.744E+00,5.735E+00,5.740E+00,& +5.732E+00,5.728E+00,5.731E+00,5.724E+00,5.724E+00,5.715E+00,5.697E+00,5.693E+00,5.703E+00,5.700E+00,& +5.713E+00,5.728E+00,5.731E+00,5.735E+00,5.743E+00,5.754E+00,5.753E+00,5.744E+00,5.746E+00,5.746E+00,& +5.746E+00,5.750E+00,5.749E+00,5.743E+00,5.740E+00,5.747E+00,5.739E+00,5.755E+00,5.749E+00,5.753E+00,& +5.745E+00,5.732E+00,5.735E+00,5.724E+00,5.725E+00,5.712E+00,5.702E+00,5.700E+00,5.700E+00,5.686E+00,& +5.685E+00,5.672E+00,5.659E+00,5.627E+00,5.613E+00,5.590E+00,5.591E+00,5.563E+00,5.552E+00,5.525E+00/ + data (k_Cm(i),i=1201,1300)/& +5.517E+00,5.506E+00,5.494E+00,5.459E+00,5.450E+00,5.438E+00,5.428E+00,5.407E+00,5.391E+00,5.382E+00,& +5.376E+00,5.358E+00,5.347E+00,5.333E+00,5.319E+00,5.301E+00,5.292E+00,5.284E+00,5.274E+00,5.258E+00,& +5.253E+00,5.249E+00,5.233E+00,5.222E+00,5.211E+00,5.204E+00,5.210E+00,5.200E+00,5.193E+00,5.186E+00,& +5.177E+00,5.175E+00,5.178E+00,5.173E+00,5.152E+00,5.135E+00,5.139E+00,5.128E+00,5.121E+00,5.114E+00,& +5.126E+00,5.107E+00,5.104E+00,5.100E+00,5.109E+00,5.114E+00,5.112E+00,5.128E+00,5.137E+00,5.131E+00,& +5.152E+00,5.175E+00,5.194E+00,5.200E+00,5.244E+00,5.257E+00,5.273E+00,5.289E+00,5.335E+00,5.366E+00,& +5.389E+00,5.427E+00,5.453E+00,5.490E+00,5.522E+00,5.562E+00,5.605E+00,5.652E+00,5.698E+00,5.744E+00,& +5.743E+00,5.642E+00,5.689E+00,5.722E+00,5.755E+00,5.798E+00,5.848E+00,5.875E+00,5.918E+00,5.971E+00,& +6.022E+00,6.061E+00,6.116E+00,6.173E+00,6.214E+00,6.266E+00,6.319E+00,6.382E+00,6.426E+00,6.486E+00,& +6.542E+00,6.579E+00,6.616E+00,6.666E+00,6.728E+00,6.771E+00,6.807E+00,6.858E+00,6.908E+00,6.959E+00/ + data (k_Cm(i),i=1301,1400)/& +7.006E+00,7.052E+00,7.093E+00,7.136E+00,7.164E+00,7.199E+00,7.232E+00,7.266E+00,7.315E+00,7.340E+00,& +7.361E+00,7.399E+00,7.440E+00,7.473E+00,7.505E+00,7.525E+00,7.557E+00,7.579E+00,7.604E+00,7.633E+00,& +7.653E+00,7.674E+00,7.691E+00,7.699E+00,7.708E+00,7.721E+00,7.730E+00,7.729E+00,7.712E+00,7.702E+00,& +7.695E+00,7.670E+00,7.644E+00,7.618E+00,7.585E+00,7.555E+00,7.517E+00,7.479E+00,7.451E+00,7.435E+00,& +7.408E+00,7.379E+00,7.363E+00,7.347E+00,7.332E+00,7.332E+00,7.332E+00,7.304E+00,7.295E+00,7.296E+00,& +7.291E+00,7.292E+00,7.292E+00,7.281E+00,7.283E+00,7.264E+00,7.250E+00,7.240E+00,7.228E+00,7.210E+00,& +7.186E+00,7.164E+00,7.143E+00,7.114E+00,7.101E+00,7.069E+00,7.038E+00,7.003E+00,6.974E+00,6.928E+00,& +6.889E+00,6.839E+00,6.793E+00,6.764E+00,6.729E+00,6.694E+00,6.662E+00,6.613E+00,6.572E+00,6.546E+00,& +6.522E+00,6.507E+00,6.482E+00,6.484E+00,6.479E+00,6.494E+00,6.496E+00,6.491E+00,6.461E+00,6.440E+00,& +6.430E+00,6.413E+00,6.421E+00,6.399E+00,6.379E+00,6.365E+00,6.372E+00,6.346E+00,6.321E+00,6.310E+00/ + data (k_Cm(i),i=1401,1500)/& +6.314E+00,6.282E+00,6.277E+00,6.270E+00,6.258E+00,6.242E+00,6.234E+00,6.221E+00,6.231E+00,6.221E+00,& +6.205E+00,6.193E+00,6.192E+00,6.179E+00,6.159E+00,6.143E+00,6.143E+00,6.120E+00,6.098E+00,6.087E+00,& +6.063E+00,6.056E+00,6.053E+00,6.040E+00,6.044E+00,6.007E+00,5.996E+00,5.994E+00,5.997E+00,5.975E+00,& +5.954E+00,5.946E+00,5.927E+00,5.914E+00,5.890E+00,5.873E+00,5.832E+00,5.794E+00,5.768E+00,5.728E+00,& +5.681E+00,5.680E+00,5.655E+00,5.648E+00,5.620E+00,5.594E+00,5.567E+00,5.557E+00,5.552E+00,5.553E+00,& +5.539E+00,5.524E+00,5.507E+00,5.505E+00,5.487E+00,5.474E+00,5.462E+00,5.450E+00,5.448E+00,5.441E+00,& +5.440E+00,5.442E+00,5.450E+00,5.466E+00,5.461E+00,5.452E+00,5.445E+00,5.412E+00,5.379E+00,5.280E+00,& +5.228E+00,5.199E+00,5.171E+00,5.139E+00,5.124E+00,5.112E+00,5.129E+00,5.145E+00,5.173E+00,5.176E+00,& +5.185E+00,5.183E+00,5.200E+00,5.202E+00,5.204E+00,5.224E+00,5.244E+00,5.297E+00,5.318E+00,5.376E+00,& +5.441E+00,5.491E+00,5.561E+00,5.629E+00,5.687E+00,5.757E+00,5.830E+00,5.911E+00,5.998E+00,6.090E+00/ + data (k_Cm(i),i=1501,1600)/& +6.193E+00,6.330E+00,6.449E+00,6.581E+00,6.710E+00,6.838E+00,6.970E+00,7.107E+00,7.238E+00,7.388E+00,& +7.506E+00,7.635E+00,7.767E+00,7.874E+00,7.977E+00,8.071E+00,8.150E+00,8.220E+00,8.292E+00,8.350E+00,& +8.449E+00,8.521E+00,8.583E+00,8.666E+00,8.723E+00,8.759E+00,8.821E+00,8.864E+00,8.909E+00,8.941E+00,& +8.949E+00,8.955E+00,8.983E+00,9.022E+00,9.043E+00,9.044E+00,9.028E+00,9.034E+00,9.052E+00,9.048E+00,& +9.041E+00,9.037E+00,9.036E+00,9.035E+00,9.021E+00,9.016E+00,9.008E+00,8.970E+00,8.974E+00,8.953E+00,& +8.957E+00,8.937E+00,8.923E+00,8.912E+00,8.895E+00,8.891E+00,8.880E+00,8.867E+00,8.855E+00,8.852E+00,& +8.861E+00,8.864E+00,8.876E+00,8.869E+00,8.873E+00,8.855E+00,8.828E+00,8.839E+00,8.855E+00,8.856E+00,& +8.833E+00,8.842E+00,8.844E+00,8.830E+00,8.808E+00,8.818E+00,8.807E+00,8.797E+00,8.794E+00,8.791E+00,& +8.795E+00,8.772E+00,8.754E+00,8.759E+00,8.760E+00,8.746E+00,8.762E+00,8.778E+00,8.790E+00,8.795E+00,& +8.811E+00,8.848E+00,8.874E+00,8.885E+00,8.913E+00,8.944E+00,8.981E+00,8.988E+00,9.001E+00,9.034E+00/ + data (k_Cm(i),i=1601,1700)/& +9.076E+00,9.111E+00,9.141E+00,9.171E+00,9.214E+00,9.255E+00,9.304E+00,9.356E+00,9.406E+00,9.448E+00,& +9.516E+00,9.578E+00,9.638E+00,9.692E+00,9.763E+00,9.845E+00,9.953E+00,1.004E+01,1.015E+01,1.027E+01,& +1.039E+01,1.052E+01,1.063E+01,1.077E+01,1.091E+01,1.103E+01,1.119E+01,1.135E+01,1.150E+01,1.166E+01,& +1.181E+01,1.201E+01,1.217E+01,1.235E+01,1.251E+01,1.269E+01,1.287E+01,1.307E+01,1.325E+01,1.346E+01,& +1.364E+01,1.384E+01,1.404E+01,1.423E+01,1.441E+01,1.461E+01,1.481E+01,1.499E+01,1.518E+01,1.534E+01,& +1.554E+01,1.571E+01,1.591E+01,1.607E+01,1.622E+01,1.637E+01,1.653E+01,1.667E+01,1.678E+01,1.690E+01,& +1.698E+01,1.709E+01,1.718E+01,1.725E+01,1.734E+01,1.739E+01,1.748E+01,1.755E+01,1.761E+01,1.767E+01,& +1.771E+01,1.777E+01,1.783E+01,1.787E+01,1.794E+01,1.795E+01,1.799E+01,1.805E+01,1.809E+01,1.813E+01,& +1.820E+01,1.827E+01,1.830E+01,1.835E+01,1.841E+01,1.846E+01,1.852E+01,1.856E+01,1.861E+01,1.866E+01,& +1.871E+01,1.876E+01,1.881E+01,1.885E+01,1.890E+01,1.896E+01,1.903E+01,1.907E+01,1.911E+01,1.916E+01/ + data (k_Cm(i),i=1701,1800)/& +1.921E+01,1.927E+01,1.929E+01,1.932E+01,1.935E+01,1.936E+01,1.940E+01,1.943E+01,1.947E+01,1.951E+01,& +1.953E+01,1.956E+01,1.960E+01,1.961E+01,1.962E+01,1.966E+01,1.966E+01,1.969E+01,1.970E+01,1.972E+01,& +1.974E+01,1.974E+01,1.976E+01,1.978E+01,1.979E+01,1.982E+01,1.982E+01,1.983E+01,1.986E+01,1.988E+01,& +1.989E+01,1.989E+01,1.993E+01,1.993E+01,1.997E+01,2.001E+01,2.001E+01,2.004E+01,2.007E+01,2.011E+01,& +2.014E+01,2.015E+01,2.017E+01,2.019E+01,2.022E+01,2.023E+01,2.023E+01,2.026E+01,2.027E+01,2.029E+01,& +2.028E+01,2.027E+01,2.029E+01,2.029E+01,2.031E+01,2.029E+01,2.026E+01,2.030E+01,2.031E+01,2.030E+01,& +2.030E+01,2.031E+01,2.029E+01,2.029E+01,2.026E+01,2.025E+01,2.023E+01,2.020E+01,2.016E+01,2.015E+01,& +2.012E+01,2.009E+01,2.007E+01,2.003E+01,1.998E+01,1.996E+01,1.991E+01,1.986E+01,1.980E+01,1.975E+01,& +1.969E+01,1.964E+01,1.959E+01,1.953E+01,1.947E+01,1.941E+01,1.936E+01,1.931E+01,1.922E+01,1.918E+01,& +1.912E+01,1.906E+01,1.899E+01,1.890E+01,1.885E+01,1.881E+01,1.875E+01,1.867E+01,1.861E+01,1.858E+01/ + data (k_Cm(i),i=1801,1900)/& +1.852E+01,1.846E+01,1.840E+01,1.834E+01,1.829E+01,1.824E+01,1.819E+01,1.813E+01,1.807E+01,1.803E+01,& +1.798E+01,1.792E+01,1.788E+01,1.782E+01,1.780E+01,1.775E+01,1.773E+01,1.768E+01,1.768E+01,1.766E+01,& +1.763E+01,1.762E+01,1.763E+01,1.764E+01,1.764E+01,1.766E+01,1.770E+01,1.774E+01,1.779E+01,1.786E+01,& +1.795E+01,1.803E+01,1.814E+01,1.825E+01,1.836E+01,1.851E+01,1.866E+01,1.881E+01,1.895E+01,1.913E+01,& +1.932E+01,1.951E+01,1.972E+01,1.994E+01,2.017E+01,2.040E+01,2.065E+01,2.089E+01,2.114E+01,2.140E+01,& +2.163E+01,2.186E+01,2.210E+01,2.237E+01,2.262E+01,2.290E+01,2.313E+01,2.339E+01,2.361E+01,2.387E+01,& +2.410E+01,2.435E+01,2.455E+01,2.479E+01,2.499E+01,2.521E+01,2.541E+01,2.562E+01,2.583E+01,2.605E+01,& +2.626E+01,2.643E+01,2.657E+01,2.674E+01,2.689E+01,2.701E+01,2.718E+01,2.732E+01,2.742E+01,2.754E+01,& +2.763E+01,2.777E+01,2.794E+01,2.804E+01,2.821E+01,2.836E+01,2.850E+01,2.863E+01,2.878E+01,2.896E+01,& +2.913E+01,2.922E+01,2.937E+01,2.947E+01,2.960E+01,2.970E+01,2.982E+01,2.997E+01,3.007E+01,3.018E+01/ + data (k_Cm(i),i=1901,2000)/& +3.028E+01,3.040E+01,3.053E+01,3.060E+01,3.066E+01,3.070E+01,3.076E+01,3.078E+01,3.075E+01,3.074E+01,& +3.072E+01,3.065E+01,3.058E+01,3.051E+01,3.045E+01,3.034E+01,3.029E+01,3.023E+01,3.015E+01,3.004E+01,& +3.000E+01,2.998E+01,2.991E+01,2.986E+01,2.984E+01,2.981E+01,2.976E+01,2.973E+01,2.976E+01,2.977E+01,& +2.979E+01,2.981E+01,2.985E+01,2.989E+01,2.999E+01,3.000E+01,3.005E+01,3.007E+01,3.011E+01,3.017E+01,& +3.022E+01,3.023E+01,3.029E+01,3.028E+01,3.029E+01,3.027E+01,3.027E+01,3.024E+01,3.019E+01,3.010E+01,& +3.010E+01,3.003E+01,2.993E+01,2.983E+01,2.984E+01,2.975E+01,2.966E+01,2.958E+01,2.948E+01,2.930E+01,& +2.926E+01,2.920E+01,2.913E+01,2.902E+01,2.890E+01,2.882E+01,2.873E+01,2.873E+01,2.870E+01,2.865E+01,& +2.858E+01,2.854E+01,2.851E+01,2.846E+01,2.838E+01,2.834E+01,2.823E+01,2.820E+01,2.817E+01,2.809E+01,& +2.803E+01,2.803E+01,2.801E+01,2.794E+01,2.791E+01,2.790E+01,2.784E+01,2.779E+01,2.781E+01,2.782E+01,& +2.781E+01,2.781E+01,2.783E+01,2.785E+01,2.785E+01,2.782E+01,2.782E+01,2.780E+01,2.780E+01,2.778E+01/ + data (k_Cm(i),i=2001,2101)/& +2.783E+01,2.784E+01,2.788E+01,2.791E+01,2.799E+01,2.804E+01,2.812E+01,2.811E+01,2.819E+01,2.819E+01,& +2.817E+01,2.817E+01,2.831E+01,2.837E+01,2.848E+01,2.853E+01,2.859E+01,2.870E+01,2.874E+01,2.887E+01,& +2.898E+01,2.910E+01,2.923E+01,2.934E+01,2.944E+01,2.959E+01,2.973E+01,2.987E+01,3.002E+01,3.016E+01,& +3.035E+01,3.043E+01,3.064E+01,3.084E+01,3.098E+01,3.122E+01,3.132E+01,3.152E+01,3.165E+01,3.184E+01,& +3.204E+01,3.221E+01,3.233E+01,3.255E+01,3.282E+01,3.315E+01,3.339E+01,3.360E+01,3.384E+01,3.410E+01,& +3.426E+01,3.452E+01,3.473E+01,3.497E+01,3.519E+01,3.539E+01,3.561E+01,3.579E+01,3.604E+01,3.618E+01,& +3.636E+01,3.660E+01,3.675E+01,3.682E+01,3.699E+01,3.711E+01,3.735E+01,3.758E+01,3.792E+01,3.796E+01,& +3.812E+01,3.822E+01,3.833E+01,3.856E+01,3.874E+01,3.877E+01,3.884E+01,3.883E+01,3.879E+01,3.886E+01,& +3.900E+01,3.900E+01,3.906E+01,3.905E+01,3.916E+01,3.928E+01,3.948E+01,3.943E+01,3.951E+01,3.964E+01,& +3.953E+01,3.960E+01,3.958E+01,3.954E+01,3.940E+01,3.936E+01,3.917E+01,3.926E+01,3.893E+01,3.921E+01,& +3.871E+01/ + +end \ No newline at end of file diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_prospect_DB.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_prospect_DB.F90 new file mode 100644 index 0000000000..876f672c79 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_prospect_DB.F90 @@ -0,0 +1,204 @@ +#include + +! ******************************************************************************** +! prospect_DB.f90 +! a.k.a. PROSPECT-Dynamic +! version 6.0 (January, 16th 2017) +! subroutines required: tav.f90, dataSpec_PDB.f90 +! _______________________________________________________________________ +! for any question or request, please contact: +! +! Jean-Baptiste FERET +! UMR-TETIS, IRSTEA Montpellier +! Maison de la T�l�d�tection +! 500 rue Jean-Fracois Breton +! 34093 Montpellier cedex 5 +! E-mail: jb.feret@teledetection.fr +! +! St�phane JACQUEMOUD +! Universit� Paris Diderot / Institut de Physique du Globe de Paris +! 35 rue H�l�ne Brion +! 75013 Paris, France +! E-mail: jacquemoud@ipgp.fr +! +! http://teledetection.ipgp.fr/prosail/ +!______________________________________________________________________ +! Plant leaf reflectance and transmittance are calculated from 400 nm to +! 2500 nm (1 nm step) with the following parameters: +! +! - N = leaf structure parameter +! - Cab = chlorophyll a+b content in �g/cm� +! - Car = carotenoids content in �g/cm� +! - Anth = Anthocyanin content in �g/cm� +! - Cbrown= brown pigments content in arbitrary units +! - Cw = equivalent water thickness in g/cm� or cm +! - Cm = dry matter content in g/cm� +! +!Here are some examples observed during the LOPEX'93 experiment on +!fresh (F) and dry (D) leaves : +! +!--------------------------------------------- +! N Cab Cw Cm +!--------------------------------------------- +!min 1.000 0.0 0.004000 0.001900 +! max 3.000 100.0 0.040000 0.016500 +! corn (F) 1.518 58.0 0.013100 0.003662 +! rice (F) 2.275 23.7 0.007500 0.005811 +! clover (F) 1.875 46.7 0.010000 0.003014 +! laurel (F) 2.660 74.1 0.019900 0.013520 +! --------------------------------------------- +! min 1.500 0.0 0.000063 0.0019 +! max 3.600 100.0 0.000900 0.0165 +! bamboo (D) 2.698 70.8 0.000117 0.009327 +! lettuce (D) 2.107 35.2 0.000244 0.002250 +! walnut (D) 2.656 62.8 0.000263 0.006573 +! chestnut (D) 1.826 47.7 0.000307 0.004305 +! --------------------------------------------- +! _______________________________________________________________________! +! if no information about Anth or Cbrown and work on green / mature leaves +! set it to 0 ! +! if no information about Car and work on green / mature leaves ! +! set the Chl / Car ratio between 4 and 5. this is not appropriate for ! +! senescent leaves ! +! _______________________________________________________________________! +! this code includes numerical optimizations proposed in the FLUSPECT code +! Authors: Wout Verhoef, Christiaan van der Tol (c.vandertol@utwente.nl) & +! Joris Timmermans +! Date: 2007 +! Update from PROSPECT to FLUSPECT: January 2011 (CvdT) +! for more info about FLUSPECT, see publication: +! Vilfan, N., van der Tol, C., Muller, O., Rascher, U., Verhoef, W., 2016. +! Fluspect-B: A model for leaf fluorescence, reflectance and transmittance +! spectra. Remote Sens. Environ. 186, 596�615. doi:10.1016/j.rse.2016.09.017 + +MODULE MOD_prospect_DB +USE MOD_Precision +IMPLICIT NONE +SAVE + +PUBLIC :: prospect_DB + +CONTAINS +subroutine prospect_DB(N,Cab,Car,Anth,Cbrown,Cw,Cm,RT) +! ******************************************************************************** +! F�ret, Gitelson, Noble & Jacqumoud (2017). PROSPECT-D: Towards modeling +! leaf optical properties through a complete lifecycle +! Remote Sensing of Environment, 193:204�215 +! DOI: http://doi.org/10.1016/j.rse.2017.03.004 +! Jacquemoud S., Baret F. (1990), PROSPECT: a model of leaf optical properties +! spectra, Remote Sensing of Environment, 34:75-91. +! ******************************************************************************** + +use MOD_dataSpec_PDB +use MOD_tav_abs +implicit none + +real(r8), intent(in) :: N,Cab,Car,Anth,Cbrown,Cw,Cm +real(r8), intent(out) :: RT(nw,2) + +real(r8) :: k(nw), tau(nw), xx(nw), yy(nw) +real(r8) :: ralf(nw),talf(nw),r12(nw),t12(nw),r21(nw),t21(nw) +real(r8) :: theta1, theta2, denom(nw),Ra(nw),Ta(nw),r(nw),t(nw) +real(r8) :: d(nw),rq(nw),tq(nw),a(nw),b(nw) +real(r8) :: bNm1(nw),bN2(nw),a2(nw),Rsub(nw),Tsub(nw) + +k = (Cab*k_Cab+Car*k_Car+Anth*k_Anth+Cbrown*k_Brown+Cw*k_Cw+Cm*k_Cm)/N + +! ******************************************************************************** +! reflectance and transmittance of one layer +! ******************************************************************************** +! Allen W.A., Gausman H.W., Richardson A.J., Thomas J.R. (1969), Interaction of +! isotropic ligth with a compact plant leaf, Journal of the Optical Society of +! American, 59:1376-1379. +! ******************************************************************************** + +! exponential integral: S13AAF routine from the NAG library + +where (k.le.0.0) + tau = 1 +end where +where (k.gt.0.0.and.k.le.4.0) + xx = 0.5*k-1.0 + yy = (((((((((((((((-3.60311230482612224d-13 & + *xx+3.46348526554087424d-12)*xx-2.99627399604128973d-11) & + *xx+2.57747807106988589d-10)*xx-2.09330568435488303d-9) & + *xx+1.59501329936987818d-8)*xx-1.13717900285428895d-7) & + *xx+7.55292885309152956d-7)*xx-4.64980751480619431d-6) & + *xx+2.63830365675408129d-5)*xx-1.37089870978830576d-4) & + *xx+6.47686503728103400d-4)*xx-2.76060141343627983d-3) & + *xx+1.05306034687449505d-2)*xx-3.57191348753631956d-2) & + *xx+1.07774527938978692d-1)*xx-2.96997075145080963d-1 + yy = (yy*xx+8.64664716763387311d-1)*xx+7.42047691268006429d-1 + yy = yy-log(k) + tau = (1.0-k)*exp(-k)+k**2*yy +end where +where (k.gt.4.0.and.k.le.85.0) + xx = 14.5/(k+3.25)-1.0 + yy = (((((((((((((((-1.62806570868460749d-12 & + *xx-8.95400579318284288d-13)*xx-4.08352702838151578d-12) & + *xx-1.45132988248537498d-11)*xx-8.35086918940757852d-11) & + *xx-2.13638678953766289d-10)*xx-1.10302431467069770d-9) & + *xx-3.67128915633455484d-9)*xx-1.66980544304104726d-8) & + *xx-6.11774386401295125d-8)*xx-2.70306163610271497d-7) & + *xx-1.05565006992891261d-6)*xx-4.72090467203711484d-6) & + *xx-1.95076375089955937d-5)*xx-9.16450482931221453d-5) & + *xx-4.05892130452128677d-4)*xx-2.14213055000334718d-3 + yy = ((yy*xx-1.06374875116569657d-2)*xx-8.50699154984571871d-2)*xx+9.23755307807784058d-1 + yy = exp(-k)*yy/k + tau = (1.0-k)*exp(-k)+k**2*yy +end where +where (k.gt.85.0) + tau = 0 +end where + +! transmissivity of the layer + +theta1 = 90. +call tav_abs(theta1,refractive,t12) +theta2 = 40. +call tav_abs(theta2,refractive,talf) +ralf = 1.-talf +r12 = 1.-t12 +t21 = t12/(refractive**2) +r21 = 1-t21 +! top surface side +denom = 1-r21*r21*tau**2 +Ta = talf*tau*t21/denom +Ra = ralf+r21*tau*Ta +! bottom surface side +t = t12*tau*t21/denom +r = r12+r21*tau*t + +! ******************************************************************************** +! reflectance and transmittance of N layers +! ******************************************************************************** +! Stokes G.G. (1862), On the intensity of the light reflected from or transmitted +! through a pile of plates, Proceedings of the Royal Society of London, 11:545-556. +! ******************************************************************************** +D = sqrt((1.+r+t)*(1.+r-t)*(1.-r+t)*(1.-r-t)) +rq = r**2 +tq = t**2 +a = (1.+rq-tq+D)/(2*r) +b = (1.-rq+tq+D)/(2*t) + +bNm1 = b**(N-1) +bN2 = bNm1**2 +a2 = a**2 +denom = a2*bN2-1. +Rsub = a*(bN2-1.)/denom +Tsub = bNm1*(a2-1.)/denom + +! Case of zero absorption +where (r+t.ge.1.0) + Tsub = t/(t+(1.-t)*(N-1)) + Rsub = 1-Tsub +end where + +! Reflectance and transmittance of the leaf: combine top layer with next N-1 layers +denom = 1-Rsub*r +RT(:,2) = Ta*Tsub/denom +RT(:,1) = Ra+Ta*Rsub*t/denom + +end subroutine + +END MODULE \ No newline at end of file diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_tav_abs.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_tav_abs.F90 new file mode 100644 index 0000000000..f738a7cb57 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_tav_abs.F90 @@ -0,0 +1,67 @@ +#include + +! ******************************************************************************** +! tav_abs.f90 +! ******************************************************************************** +! computation of the average transmittivity at the leaf surface within a given +! solid angle. teta is the incidence solid angle (in radian). The average angle +! that works in most cases is 40deg*pi/180. ref is the refaction index. +! ******************************************************************************** +! Stern F. (1964), Transmission of isotropic radiation across an interface between +! two dielectrics, Applied Optics, 3:111-113. +! Allen W.A. (1973), Transmission of isotropic light across a dielectric surface in +! two and three dimensions, Journal of the Optical Society of America, 63:664-666. +! ******************************************************************************** +! version 5.02 (25 July 2011) +! ******************************************************************************** +MODULE MOD_tav_abs +IMPLICIT NONE +PUBLIC :: tav_abs + +CONTAINS +subroutine tav_abs(theta,nr,tav) +USE MOD_Precision +use MOD_dataSpec_PDB +implicit none + +real(r8), intent(in) :: theta, nr(nw) +real(r8), intent(out) :: tav(nw) + +real(r8) pi,rd +real(r8) n2(nw),np(nw),nm(nw) +real(r8) a(nw),k(nw),sa(nw),b1(nw),b2(nw),b3(nw),b(nw),a3(nw) +real(r8) ts(nw),tp(nw),tp1(nw),tp2(nw),tp3(nw),tp4(nw),tp5(nw) + + +pi = atan(1.)*4. +rd = pi/180. +n2 = nr**2. +np = n2+1. +nm = n2-1. +a = (nr+1)*(nr+1.)/2. +k = -(n2-1)*(n2-1.)/4. +sa = sin(theta*rd) + +if (theta.eq.90.) then + b1=0. +else + b1 = sqrt((sa**2-np/2._r8)*(sa**2-np/2._r8)+k) +endif + +b2 = sa**2-np/2._r8 +b = b1-b2 +b3 = b**3 +a3 = a**3 +ts = (k**2./(6._r8*b3)+k/b-b/2._r8)-(k**2./(6._r8*a3)+k/a-a/2._r8) + +tp1 = -2._r8*n2*(b-a)/(np**2) +tp2 = -2._r8*n2*np*log(b/a)/(nm**2) +tp3 = n2*(1._r8/b-1._r8/a)/2._r8 +tp4 = 16._r8*n2**2._r8*(n2**2._r8+1._r8)*log((2._r8*np*b-nm**2)/(2._r8*np*a-nm**2))/(np**3._r8*nm**2) +tp5 = 16._r8*n2**3._r8*(1._r8/(2._r8*np*b-nm**2)-1._r8/(2._r8*np*a-nm**2))/(np**3._r8) +tp = tp1+tp2+tp3+tp4+tp5 +tav = (ts+tp)/(2._r8*sa**2) + +return +end +END MODULE MOD_tav_abs \ No newline at end of file diff --git a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 new file mode 100644 index 0000000000..033e21602c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90 @@ -0,0 +1,223 @@ +#include + +MODULE MOD_Opt_Baseflow + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Namelist + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + real(r8), allocatable :: scale_baseflow (:) + + real(r8), allocatable :: zwt_init (:) + real(r8), allocatable :: rchg_year (:) + real(r8), allocatable :: rsub_year (:) + + integer :: iter_bf_opt + +CONTAINS + + ! ----- + SUBROUTINE Opt_Baseflow_init () + + USE MOD_NetCDFVector + USE MOD_Vars_TimeVariables, only: zwt + USE MOD_LandPatch, only: numpatch, landpatch + USE MOD_Utils, only: make_directory + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + ! Local Variables + character(len=256) :: file_restart + + + file_restart = trim(DEF_dir_restart) // '/ParaOpt/' // trim(DEF_CASE_NAME) //'_baseflow.nc' + CALL ncio_read_vector (file_restart, 'scale_baseflow', landpatch, scale_baseflow, defval = 1.) + IF (numpatch > 0) THEN + IF (.not. allocated(scale_baseflow)) THEN + CALL CoLM_stop('Embedded CoLM baseflow scale is not allocated.') + ENDIF + IF (size(scale_baseflow) /= numpatch) THEN + CALL CoLM_stop('Embedded CoLM baseflow scale does not match the local patch decomposition.') + ENDIF + IF (.not. all(ieee_is_finite(scale_baseflow)) .or. any(scale_baseflow <= 0._r8)) THEN + CALL CoLM_stop('Embedded CoLM baseflow scale must contain finite positive values.') + ENDIF + ENDIF + + IF (mpas_is_root) CALL make_directory(trim(DEF_dir_restart)//'/ParaOpt') +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('baseflow-scale initialization') +#endif + + IF (DEF_Optimize_Baseflow) THEN + + IF (.true.) THEN + IF (numpatch > 0) THEN + allocate (zwt_init (numpatch)); zwt_init (:) = zwt + allocate (rchg_year (numpatch)); rchg_year (:) = spval + allocate (rsub_year (numpatch)); rsub_year (:) = spval + ENDIF + ENDIF + + iter_bf_opt = 0 + + ENDIF + + END SUBROUTINE Opt_Baseflow_init + + ! ----- + SUBROUTINE BaseFlow_Optimize (idate, deltim, is_spinup) + + USE MOD_TimeManager + USE MOD_NetCDFVector + USE MOD_Vars_TimeInvariants, only: patchtype + USE MOD_Vars_TimeVariables, only: wice_soisno, zwt + USE MOD_Vars_1DForcing, only: forc_prc, forc_prl + USE MOD_Vars_1DFluxes, only: fevpa, rsur, rsub + USE MOD_LandPatch, only: numpatch, landpatch + USE MOD_Utils, only: make_directory + IMPLICIT NONE + + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: is_spinup + + ! Local Variables + real(r8), allocatable :: recharge(:) + integer :: ipatch + character(len=256) :: file_restart + character(len=5) :: strcyc + + IF (DEF_Optimize_Baseflow .and. is_spinup) THEN + + IF (.true.) THEN + IF (numpatch > 0) THEN + + allocate (recharge(numpatch)); recharge(:) = spval + WHERE ((forc_prc /= spval) .and. (forc_prl /= spval) .and. (fevpa /= spval) .and. (rsur /= spval)) + recharge = forc_prc + forc_prl - fevpa - rsur + END WHERE + + CALL add_spv (recharge, rchg_year, deltim) + + deallocate (recharge) + + CALL add_spv (rsub, rsub_year, deltim) + + ENDIF + ENDIF + + IF (isendofyear(idate,deltim)) THEN + + iter_bf_opt = iter_bf_opt + 1 + + write(strcyc,'(A1,I4.4)') 'c', iter_bf_opt + IF (mpas_is_root) CALL make_directory(trim(DEF_dir_restart)//'/ParaOpt/'//strcyc) +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) +#endif + file_restart = trim(DEF_dir_restart)//'/ParaOpt/'//strcyc//'/'//trim(DEF_CASE_NAME)//'_baseflow.nc' + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_write_vector (file_restart, 'zwt', 'patch', landpatch, zwt, 1) + CALL ncio_write_vector (file_restart, 'zwt_init', 'patch', landpatch, zwt_init, 1) + CALL ncio_write_vector (file_restart, 'scale_baseflow', 'patch', landpatch, scale_baseflow, 1) + CALL ncio_write_vector (file_restart, 'total_recharge', 'patch', landpatch, rchg_year, 1) + CALL ncio_write_vector (file_restart, 'total_subsurface_runoff', 'patch', landpatch, rsub_year, 1) + + IF (.true.) THEN + DO ipatch = 1, numpatch + IF (patchtype(ipatch) <= 1) THEN + + IF ((rchg_year(ipatch) > 0) .and. (rsub_year(ipatch) > 0)) THEN + + IF ((zwt(ipatch) > zwt_init(ipatch)) .and. (rchg_year(ipatch) < rsub_year(ipatch))) THEN + + scale_baseflow(ipatch) = rchg_year(ipatch)/rsub_year(ipatch) * scale_baseflow(ipatch) + + ENDIF + + IF ((zwt(ipatch) < zwt_init(ipatch)) .and. (rchg_year(ipatch) > rsub_year(ipatch))) THEN + + scale_baseflow(ipatch) = rchg_year(ipatch)/rsub_year(ipatch) * scale_baseflow(ipatch) + + ENDIF + + ENDIF + + scale_baseflow(ipatch) = max(1.e-8, scale_baseflow(ipatch)) + + ENDIF + ENDDO + ENDIF + + file_restart = trim(DEF_dir_restart) // '/ParaOpt/' // trim(DEF_CASE_NAME) //'_baseflow.nc' + CALL ncio_create_file_vector (file_restart, landpatch) + CALL ncio_define_dimension_vector (file_restart, landpatch, 'patch') + CALL ncio_write_vector (file_restart, 'scale_baseflow', 'patch', landpatch, scale_baseflow, 1) + + IF (.true.) THEN + IF (numpatch > 0) THEN + rchg_year(:) = spval + rsub_year(:) = spval + ENDIF + ENDIF + + ENDIF + + ENDIF + + END SUBROUTINE BaseFlow_Optimize + + ! ----- + SUBROUTINE Opt_Baseflow_final () + + IMPLICIT NONE + + IF (allocated(scale_baseflow)) deallocate(scale_baseflow) + IF (allocated(zwt_init )) deallocate(zwt_init ) + IF (allocated(rchg_year )) deallocate(rchg_year ) + IF (allocated(rsub_year )) deallocate(rsub_year ) + + END SUBROUTINE Opt_Baseflow_final + + !----------------------------------------------------------------------- + SUBROUTINE add_spv (var, s, dt) + + USE MOD_Precision + + IMPLICIT NONE + + real(r8), intent(in) :: var(:) + real(r8), intent(inout) :: s (:) + real(r8), intent(in), optional :: dt + ! Local variables + integer :: i + + IF (present(dt)) THEN + DO i = lbound(var,1), ubound(var,1) + IF (var(i) /= spval) THEN + IF (s(i) /= spval) THEN + s(i) = s(i) + var(i)*dt + ELSE + s(i) = var(i)*dt + ENDIF + ENDIF + ENDDO + ELSE + DO i = lbound(var,1), ubound(var,1) + IF (var(i) /= spval) THEN + IF (s(i) /= spval) THEN + s(i) = s(i) + var(i) + ELSE + s(i) = var(i) + ENDIF + ENDIF + ENDDO + ENDIF + + END SUBROUTINE add_spv +END MODULE MOD_Opt_Baseflow diff --git a/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_ParameterOptimization.F90 b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_ParameterOptimization.F90 new file mode 100644 index 0000000000..a9a9f61eb8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_ParameterOptimization.F90 @@ -0,0 +1,44 @@ +#include + +MODULE MOD_ParameterOptimization + + USE MOD_Precision + USE MOD_Opt_Baseflow + IMPLICIT NONE + SAVE + +CONTAINS + + ! ----- + SUBROUTINE ParaOpt_init (ref_date_in, ref_lc_year_in) + + IMPLICIT NONE + integer :: ref_date_in(3), ref_lc_year_in + + CALL Opt_Baseflow_init () + + END SUBROUTINE ParaOpt_init + + ! ----- + SUBROUTINE ParameterOptimization (idate, deltim, is_spinup) + + IMPLICIT NONE + + integer, intent(in) :: idate(3) + real(r8), intent(in) :: deltim + logical, intent(in) :: is_spinup + + CALL BaseFlow_Optimize (idate, deltim, is_spinup) + + END SUBROUTINE ParameterOptimization + + ! ----- + SUBROUTINE ParaOpt_final () + + IMPLICIT NONE + + CALL Opt_Baseflow_final () + + END SUBROUTINE ParaOpt_final + +END MODULE MOD_ParameterOptimization diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 new file mode 100644 index 0000000000..b3aad898d2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/CoLMMAIN_Urban.F90 @@ -0,0 +1,1351 @@ +#include + +!----------------------------------------------------------------------- +! +! --- CoLM 3D Building Community Urban Model --- +! +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++|_ AC ______ +! |++++++|_| ___ |++++++| +! ______+++++| ||||| |++++++| +! |++++++|++++| ||||||| |++++++| +! sunlit |[]++[]|++++| ||||| |++++++| shaded +! wall |++++++| | tree |++++++| wall +! |[]++[]| | |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|____________________________________ +! +! !DESCRIPTION: +! +! Unlike the traditional urban canyon models, the CoLM urban model is +! based on the assumption of a three-dimensional urban building +! community, including trees and water bodies. We have developed a new +! approach for shortwave and longwave radiation transfer, as well as +! turbulent exchange within the three-dimensional urban buildings. In +! the process of calculating radiation transfer and turbulent exchange, +! we have integrated simulations of vegetation and water bodies. +! +! The CoLM urban model utilizes comprehensive high-resolution data on +! urban cover, geometric structure, vegetation, water bodies, etc. +! Furthermore, it has developed a relatively complete simulation of +! anthropogenic heat processes, including building energy consumption, +! traffic heat, and metabolic heat. +! +! Created by Hua Yuan, 09/2021 +! +! +! !REVISIONS (major): +! +! 03/2022, Hua Yuan: complete the model with full coupling, and make +! it possible to run multiple scenario assumptions through +! macro definitions. +! +! 07/2022, Wenzong Dong: add LUCY model initial version. +! +! 05/2023, Hua Yuan: Initial urban physical codes in MPI version. Add +! some interface or modifications for Urban model coupling. +! +! 05/2023, Wenzong Dong, Hua Yuan, Shupeng Zhang: porting urban making +! surface data codes to MPI parallel version. +! +! 05/2023, Hua Yuan: Rename files and modules align with current +! version. +! +!----------------------------------------------------------------------- + + SUBROUTINE CoLMMAIN_Urban ( & + + ! model running information + ipatch ,idate ,coszen ,deltim ,& + patchlonr ,patchlatr ,patchclass ,patchtype ,& + + ! urban and lake depth + froof ,flake ,hroof ,hlr ,& + fgper ,em_roof ,em_wall ,em_gimp ,& + em_gper ,cv_roof ,cv_wall ,cv_gimp ,& + tk_roof ,tk_wall ,tk_gimp ,z_roof ,& + z_wall ,dz_roof ,dz_wall ,lakedepth ,& + dz_lake ,elvstd ,BVIC ,& + + ! LUCY model input parameters + fix_holiday ,week_holiday ,hum_prof ,pop_den ,& + vehicle ,weh_prof ,wdh_prof ,& + + ! soil ground and wall information + vf_quartz ,vf_gravels ,vf_om ,vf_sand ,& + wf_gravels ,wf_sand ,porsl ,psi0 ,& + bsw ,theta_r ,fsatmax ,fsatdcf ,& +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm ,& +#endif + hksati ,csol ,k_solids ,dksatu ,& + dksatf ,dkdry ,BA_alpha ,BA_beta ,& + alb_roof ,alb_wall ,alb_gimp ,alb_gper ,& + + ! vegetation information + htop ,hbot ,sqrtdi ,chil ,& + effcon ,vmax25 ,c3c4 ,slti ,hlti,& + shti ,hhti ,trda ,trdm ,& + trop ,g1 ,g0 ,gradm ,& + binter ,extkn ,rho ,tau ,& + rootfr ,lambda ,& + + ! atmospheric forcing + forc_pco2m ,forc_po2m ,forc_us ,forc_vs ,& + forc_t ,forc_q ,forc_prc ,forc_prl ,& + forc_rain ,forc_snow ,forc_psrf ,forc_pbot ,& + forc_sols ,forc_soll ,forc_solsd ,forc_solld ,& + forc_frl ,forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,& + forc_rhoair ,Fhac ,Fwst ,Fach ,& + Fahe ,Fhah ,vehc ,meta ,& + + ! land surface variables required for restart + z_sno_roof ,z_sno_gimp ,z_sno_gper ,z_sno_lake ,& + dz_sno_roof ,dz_sno_gimp ,dz_sno_gper ,dz_sno_lake ,& + t_roofsno ,t_gimpsno ,t_gpersno ,t_lakesno ,& + wliq_roofsno ,wliq_gimpsno ,wliq_gpersno ,wliq_lakesno ,& + wice_roofsno ,wice_gimpsno ,wice_gpersno ,wice_lakesno ,& + z_sno ,dz_sno ,wliq_soisno ,wice_soisno ,& + t_soisno ,smp ,hk ,t_wallsun ,& + t_wallsha ,& + + lai ,sai ,fveg ,sigf ,& + green ,tleaf ,ldew ,ldew_rain ,& + ldew_snow ,fwet_snow ,t_grnd ,& + + sag_roof ,sag_gimp ,sag_gper ,sag_lake ,& + scv_roof ,scv_gimp ,scv_gper ,scv_lake ,& + snowdp_roof ,snowdp_gimp ,snowdp_gper ,snowdp_lake ,& + fsno_roof ,fsno_gimp ,fsno_gper ,fsno_lake ,& + sag ,scv ,snowdp ,fsno ,& + extkd ,alb ,ssun ,ssha ,& + sroof ,swsun ,swsha ,sgimp ,& + sgper ,slake ,lwsun ,lwsha ,& + lgimp ,lgper ,lveg ,fwsun ,& + dfwsun ,t_room ,troof_inner ,twsun_inner ,& + twsha_inner ,t_roommax ,t_roommin ,tafu ,& + + zwt ,wdsrf ,wa ,& + t_lake ,lake_icefrac ,savedtke1 ,& + + ! SNICAR snow model related + snw_rds ,ssno ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& + + ! additional diagnostic variables for output + laisun ,laisha ,rss ,& + rstfac ,h2osoi ,wat ,& + + ! FLUXES + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + fsen_roof ,fsen_wsun ,fsen_wsha ,fsen_gimp ,& + fsen_gper ,fsen_urbl ,troof ,twall ,& + lfevp_roof ,lfevp_gimp ,lfevp_gper ,lfevp_urbl ,& + trad ,tref ,&!tmax ,tmin ,& + qref ,rsur ,rnof ,qintr ,& + qinfl ,qdrip ,rst ,assim ,& + respc ,sabvsun ,sabvsha ,sabg ,& + sr ,solvd ,solvi ,solnd ,& + solni ,srvd ,srvi ,srnd ,& + srni ,solvdln ,solviln ,solndln ,& + solniln ,srvdln ,srviln ,srndln ,& + srniln ,qcharge ,xerr ,zerr ,& + + ! TUNABLE model constants + zlnd ,zsno ,csoilc ,dewmx ,& + capr ,cnfac ,ssi ,wimp ,& + pondmx ,smpmax ,smpmin ,trsmx0 ,& + tcrit ,& + + ! additional variables required by coupling with WRF model + emis ,z0m ,zol ,rib ,& + ustar ,qstar ,tstar ,fm ,& + fh ,fq ,hpbl ) + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: tfrz, denh2o, denice + USE MOD_Vars_TimeVariables, only: tlai, tsai + USE MOD_SnowLayersCombineDivide + USE MOD_LeafInterception + USE MOD_Urban_Albedo + USE MOD_Urban_NetSolar + USE MOD_Urban_Thermal + USE MOD_Urban_Hydrology + USE MOD_Lake + USE MOD_TimeManager + USE MOD_RainSnowTemp, only: rain_snow_temp + USE MOD_NewSnow, only: newsnow + USE MOD_OrbCoszen, only: orb_coszen + USE MOD_SnowFraction, only: snowfraction + USE MOD_ALBEDO, only: snowage + USE MOD_Qsadv, only: qsadv +#ifdef USE_LUCY + USE MOD_Urban_LUCY +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ,&! maximum number of snow layers + idate(3) ,&! next time-step /year/julian day/second in a day/ + patchclass ,&! land cover type of USGS classification or others + patchtype ! land patch type (0=soil, 1=urban and built-up, + ! 2=wetland, 3=land ice, 4=land water bodies, 99 = ocean) + + real(r8),intent(in) :: & + deltim ,&! seconds in a time step [second] + patchlonr ,&! longitude in radians + patchlatr ! latitude in radians + + real(r8),intent(inout) :: & + coszen ! cosine of solar zenith angle + + ! Parameters + ! ---------------------- + real(r8), intent(in) :: & + fix_holiday(365) ,&! Fixed public holidays, holiday(0) or workday(1) + week_holiday(7) ,&! week holidays + hum_prof(24) ,&! Diurnal metabolic heat profile + weh_prof(24) ,&! Diurnal traffic flow profile of weekend + wdh_prof(24) ,&! Diurnal traffic flow profile of weekday + pop_den ,&! population density + vehicle(3) ! vehicle numbers per thousand people + + real(r8), intent(in) :: & + froof ,&! roof fractional cover [-] + fgper ,&! impervious fraction to ground area [-] + flake ,&! lake fraction to ground area [-] + hroof ,&! average building height [m] + hlr ,&! average building height to their side length [-] + em_roof ,&! emissivity of roof [-] + em_wall ,&! emissivity of walls [-] + em_gimp ,&! emissivity of impervious [-] + em_gper ! emissivity of pervious [-] + + real(r8), intent(in) :: & + cv_roof (1:nl_roof) ,&! heat capacity of roof [J/(m2 K)] + cv_wall (1:nl_wall) ,&! heat capacity of wall [J/(m2 K)] + cv_gimp (1:nl_soil) ,&! heat capacity of impervious [J/(m2 K)] + tk_roof (1:nl_roof) ,&! thermal conductivity of roof [W/m-K] + tk_wall (1:nl_wall) ,&! thermal conductivity of wall [W/m-K] + tk_gimp (1:nl_soil) ! thermal conductivity of impervious [W/m-K] + + real(r8), intent(in) :: & + ! soil physical parameters and lake info + vf_quartz (nl_soil) ,&! volumetric fraction of quartz within mineral soil + vf_gravels (nl_soil) ,&! volumetric fraction of gravels + vf_om (nl_soil) ,&! volumetric fraction of organic matter + vf_sand (nl_soil) ,&! volumetric fraction of sand + wf_gravels (nl_soil) ,&! gravimetric fraction of gravels + wf_sand (nl_soil) ,&! gravimetric fraction of sand + porsl (nl_soil) ,&! fraction of soil that is voids [-] + psi0 (nl_soil) ,&! minimum soil suction [mm] + bsw (nl_soil) ,&! clapp and hornberger "b" parameter [-] + theta_r (nl_soil) ,&! residual water content (cm3/cm3) + fsatmax ,&! maximum saturated area fraction [-] + fsatdcf ,&! decay factor in calculation of saturated area fraction [1/m] + +#ifdef vanGenuchten_Mualem_SOIL_MODEL + alpha_vgm (1:nl_soil) ,&! parameter correspond approximately to inverse of air-entry value + n_vgm (1:nl_soil) ,&! a shape parameter + L_vgm (1:nl_soil) ,&! pore-connectivity parameter + sc_vgm (1:nl_soil) ,&! saturation at air entry value in classical vanGenuchten model [-] + fc_vgm (1:nl_soil) ,&! a scaling factor by using air entry value in the Mualem model [-] +#endif + hksati (nl_soil) ,&! hydraulic conductivity at saturation [mm h2o/s] + csol (nl_soil) ,&! heat capacity of soil solids [J/(m3 K)] + k_solids (nl_soil) ,&! thermal conductivity of minerals soil [W/m-K] + dksatu (nl_soil) ,&! thermal conductivity of saturated unfrozen soil [W/m-K] + dksatf (nl_soil) ,&! thermal conductivity of saturated frozen soil [W/m-K] + dkdry (nl_soil) ,&! thermal conductivity for dry soil [J/(K s m)] + + BA_alpha (nl_soil) ,&! alpha in Balland and Arp(2005) thermal conductivity scheme + BA_beta (nl_soil) ,&! beta in Balland and Arp(2005) thermal conductivity scheme + alb_roof(2,2) ,&! albedo of roof [-] + alb_wall(2,2) ,&! albedo of walls [-] + alb_gimp(2,2) ,&! albedo of impervious [-] + alb_gper(2,2) ,&! albedo of pervious [-] + + ! vegetation static, dynamic, derived parameters + sqrtdi ,&! inverse sqrt of leaf dimension [m**-0.5] + chil ,&! leaf angle distribution factor + effcon ,&! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) + vmax25 ,&! maximum carboxylation rate at 25 C at canopy top + slti ,&! slope of low temperature inhibition function [s3] + hlti ,&! 1/2 point of low temperature inhibition function [s4] + shti ,&! slope of high temperature inhibition function [s1] + hhti ,&! 1/2 point of high temperature inhibition function [s2] + trda ,&! temperature coefficient in gs-a model [s5] + trdm ,&! temperature coefficient in gs-a model [s6] + trop ,&! temperature coefficient in gs-a model + g1 ,&! conductance-photosynthesis slope parameter for medlyn model + g0 ,&! conductance-photosynthesis intercept for medlyn model + gradm ,&! conductance-photosynthesis slope parameter + binter ,&! conductance-photosynthesis intercep + extkn ,&! coefficient of leaf nitrogen allocation + rho(2,2) ,&! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ,&! leaf transmittance (iw=iband, il=life and dead) + + rootfr (nl_soil) ,&! fraction of roots in each soil layer + lambda ,&! marginal water cost of carbon gain + + ! tunable parameters + zlnd ,&! roughness length for soil [m] + zsno ,&! roughness length for snow [m] + csoilc ,&! drag coefficient for soil under canopy [-] + dewmx ,&! maximum dew + ! wtfact ,&! fraction of model area with high water table + ! (updated to gridded 'fsatmax') + capr ,&! tuning factor to turn first layer T into surface T + cnfac ,&! Crank Nicholson factor between 0 and 1 + ssi ,&! irreducible water saturation of snow + wimp ,&! water impermeable IF porosity less than wimp + pondmx ,&! ponding depth (mm) + smpmax ,&! wilting point potential in mm + smpmin ,&! restriction for min of soil poten. (mm) + trsmx0 ,&! max transpiration for moist soil+100% veg. [mm/s] + tcrit ! critical temp. to determine rain or snow + + integer, intent(in) :: c3c4 ! 1 for C3, 0 for C4 + + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + ! Forcing + ! ---------------------- + real(r8), intent(in) :: & + forc_pco2m ,&! partial pressure of CO2 at observational height [pa] + forc_po2m ,&! partial pressure of O2 at observational height [pa] + forc_us ,&! wind speed in eastward direction [m/s] + forc_vs ,&! wind speed in northward direction [m/s] + forc_t ,&! temperature at agcm reference height [kelvin] + forc_q ,&! specific humidity at agcm reference height [kg/kg] + forc_prc ,&! convective precipitation [mm/s] + forc_prl ,&! large scale precipitation [mm/s] + forc_psrf ,&! atmosphere pressure at the surface [pa] + forc_pbot ,&! atmosphere pressure at the bottom of the atmos. model level [pa] + forc_sols ,&! atm vis direct beam solar rad onto srf [W/m2] + forc_soll ,&! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd ,&! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ,&! atm nir diffuse solar rad onto srf [W/m2] + forc_frl ,&! atmospheric infrared (longwave) radiation [W/m2] + forc_hgt_u ,&! observational height of wind [m] + forc_hgt_t ,&! observational height of temperature [m] + forc_hgt_q ,&! observational height of humidity [m] + forc_rhoair ! density air [kg/m3] + +! Variables required for restart run +! ---------------------------------------------------------------------- + real(r8), intent(inout) :: & + t_wallsun ( 1:nl_wall) ,&! sunlit wall layer temperature [K] + t_wallsha ( 1:nl_wall) ,&! shaded wall layer temperature [K] + t_soisno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + t_roofsno (maxsnl+1:nl_roof) ,&! soil + snow layer temperature [K] + t_gimpsno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + t_gpersno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + t_lakesno (maxsnl+1:nl_soil) ,&! soil + snow layer temperature [K] + wliq_soisno (maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wliq_roofsno (maxsnl+1:nl_roof) ,&! liquid water (kg/m2) + wliq_gimpsno (maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wliq_gpersno (maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wliq_lakesno (maxsnl+1:nl_soil) ,&! liquid water (kg/m2) + wice_soisno (maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + wice_roofsno (maxsnl+1:nl_roof) ,&! ice lens (kg/m2) + wice_gimpsno (maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + wice_gpersno (maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + wice_lakesno (maxsnl+1:nl_soil) ,&! ice lens (kg/m2) + smp ( 1:nl_soil) ,&! soil matrix potential [mm] + hk ( 1:nl_soil) ,&! hydraulic conductivity [mm h2o/s] + + z_sno (maxsnl+1:0) ,&! node depth [m] + dz_sno (maxsnl+1:0) ,&! interface depth [m] + z_sno_roof (maxsnl+1:0) ,&! node depth of roof [m] + z_sno_gimp (maxsnl+1:0) ,&! node depth of impervious [m] + z_sno_gper (maxsnl+1:0) ,&! node depth pervious [m] + z_sno_lake (maxsnl+1:0) ,&! node depth lake [m] + dz_sno_roof (maxsnl+1:0) ,&! interface depth of roof [m] + dz_sno_gimp (maxsnl+1:0) ,&! interface depth of impervious [m] + dz_sno_gper (maxsnl+1:0) ,&! interface depth pervious [m] + dz_sno_lake (maxsnl+1:0) ,&! interface depth lake [m] + + lakedepth ,&! lake depth (m) + z_roof (nl_roof) ,&! thickness of roof [m] + z_wall (nl_wall) ,&! thickness of wall [m] + dz_roof (nl_roof) ,&! thickness of each layer [m] + dz_wall (nl_wall) ,&! thickness of each layer [m] + dz_lake (nl_lake) ,&! lake layer thickness (m) + t_lake (nl_lake) ,&! lake temperature (kelvin) + lake_icefrac (nl_lake) ,&! lake mass fraction of lake layer that is frozen + savedtke1 ,&! top level eddy conductivity (W/m K) + + elvstd ,&! standard deviation of elevation [m] + BVIC ,&! b parameter in Fraction of saturated soil calculated by VIC + + t_grnd ,&! ground surface temperature [k] + tleaf ,&! sunlit leaf temperature [K] + !tmax ,&! Diurnal Max 2 m height air temperature [kelvin] + !tmin ,&! Diurnal Min 2 m height air temperature [kelvin] + ldew ,&! depth of water on foliage [kg/m2/s] + ldew_rain ,&! depth of rain on foliage[kg/m2/s] + ldew_snow ,&! depth of snow on foliage[kg/m2/s] + fwet_snow ,&! vegetation canopy snow fractional cover [-] + sag ,&! non dimensional snow age [-] + sag_roof ,&! non dimensional snow age [-] + sag_gimp ,&! non dimensional snow age [-] + sag_gper ,&! non dimensional snow age [-] + sag_lake ,&! non dimensional snow age [-] + scv ,&! snow mass (kg/m2) + scv_roof ,&! snow mass (kg/m2) + scv_gimp ,&! snow mass (kg/m2) + scv_gper ,&! snow mass (kg/m2) + scv_lake ,&! snow mass (kg/m2) + snowdp ,&! snow depth (m) + snowdp_roof ,&! snow depth (m) + snowdp_gimp ,&! snow depth (m) + snowdp_gper ,&! snow depth (m) + snowdp_lake ,&! snow depth (m) + zwt ,&! the depth to water table [m] + wdsrf ,&! depth of surface water [mm] + wa ,&! water storage in aquifer [mm] + + snw_rds ( maxsnl+1:0 ) ,&! effective grain radius (col,lyr) [microns, m-6] + mss_bcpho ( maxsnl+1:0 ) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi ( maxsnl+1:0 ) ,&! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho ( maxsnl+1:0 ) ,&! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi ( maxsnl+1:0 ) ,&! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 ( maxsnl+1:0 ) ,&! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 ( maxsnl+1:0 ) ,&! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 ( maxsnl+1:0 ) ,&! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 ( maxsnl+1:0 ) ,&! mass of dust species 4 in snow (col,lyr) [kg] + ssno (2,2,maxsnl+1:1 ) ,&! snow layer absorption [-] + + fveg ,&! fraction of vegetation cover + fsno ,&! fractional snow cover + fsno_roof ,&! fractional snow cover + fsno_gimp ,&! fractional snow cover + fsno_gper ,&! fractional snow cover + fsno_lake ,&! fractional snow cover + sigf ,&! fraction of veg cover, excluding snow-covered veg [-] + green ,&! greenness + lai ,&! leaf area index + sai ,&! stem area index + htop ,&! canopy crown top + hbot ,&! canopy crown bottom + + lwsun ,&! net longwave of sunlit wall [W/m2] + lwsha ,&! net longwave of shaded wall [W/m2] + lgimp ,&! net longwave of impervious [W/m2] + lgper ,&! net longwave of pervious [W/m2] + lveg ,&! net longwave of vegetation [W/m2] + fwsun ,&! sunlit fraction of walls [-] + dfwsun ,&! change of sunlit fraction of walls [-] + t_room ,&! temperature of inner building [K] + troof_inner ,&! temperature of inner roof [K] + twsun_inner ,&! temperature of inner sunlit wall [K] + twsha_inner ,&! temperature of inner shaded wall [K] + t_roommax ,&! maximum temperature of inner room [K] + t_roommin ,&! minimum temperature of inner room [K] + tafu ,&! temperature of outer building [K] + Fhac ,&! sensible flux from heat or cool AC [W/m2] + Fwst ,&! waste heat flux from heat or cool AC [W/m2] + Fach ,&! flux from inner and outer air exchange [W/m2] + Fahe ,&! flux from metabolism and vehicle [W/m2] + Fhah ,&! sensible heat flux from heating [W/m2] + vehc ,&! flux from vehicle [W/m2] + meta ,&! flux from metabolism [W/m2] + + extkd ,&! diffuse and scattered diffuse PAR extinction coefficient + alb (2,2) ,&! averaged albedo [-] + ssun (2,2) ,&! sunlit canopy absorption for solar radiation + ssha (2,2) ,&! shaded canopy absorption for solar radiation + sroof(2,2) ,&! shaded canopy absorption for solar radiation + swsun(2,2) ,&! shaded canopy absorption for solar radiation + swsha(2,2) ,&! shaded canopy absorption for solar radiation + sgimp(2,2) ,&! shaded canopy absorption for solar radiation + sgper(2,2) ,&! shaded canopy absorption for solar radiation + slake(2,2) ! shaded canopy absorption for solar radiation + +! additional diagnostic variables for output + real(r8), intent(out) :: & + laisun ,&! sunlit leaf area index + laisha ,&! shaded leaf area index + rstfac ,&! factor of soil water stress + rss ,&! soil surface resistance + wat ,&! total water storage + h2osoi(nl_soil) ! volumetric soil water in layers [m3/m3] + +! Fluxes +! ---------------------------------------------------------------------- + real(r8), intent(out) :: & + taux ,&! wind stress: E-W [kg/m/s**2] + tauy ,&! wind stress: N-S [kg/m/s**2] + fsena ,&! sensible heat from canopy height to atmosphere [W/m2] + fevpa ,&! evapotranspiration from canopy height to atmosphere [mm/s] + lfevpa ,&! latent heat flux from canopy height to atmosphere [W/2] + fsenl ,&! sensible heat from leaves [W/m2] + fevpl ,&! evaporation+transpiration from leaves [mm/s] + etr ,&! transpiration rate [mm/s] + fseng ,&! sensible heat flux from ground [W/m2] + fevpg ,&! evaporation heat flux from ground [mm/s] + olrg ,&! outgoing long-wave radiation from ground+canopy + fgrnd ,&! ground heat flux [W/m2] + xerr ,&! water balance error at current time-step [mm/s] + zerr ,&! energy balance error at current time-step [W/m2] + + tref ,&! 2 m height air temperature [K] + qref ,&! 2 m height air specific humidity + trad ,&! radiative temperature [K] + rsur ,&! surface runoff (mm h2o/s) + rnof ,&! total runoff (mm h2o/s) + qintr ,&! interception (mm h2o/s) + qinfl ,&! infiltration (mm h2o/s) + qdrip ,&! throughfall (mm h2o/s) + qcharge ,&! groundwater recharge [mm/s] + + rst ,&! canopy stomatal resistance + assim ,&! canopy assimilation + respc ,&! canopy respiration + + fsen_roof ,&! sensible heat flux from roof [W/m2] + fsen_wsun ,&! sensible heat flux from sunlit wall [W/m2] + fsen_wsha ,&! sensible heat flux from shaded wall [W/m2] + fsen_gimp ,&! sensible heat flux from impervious road [W/m2] + fsen_gper ,&! sensible heat flux from pervious road [W/m2] + fsen_urbl ,&! sensible heat flux from urban vegetation [W/m2] + + lfevp_roof ,&! latent heat flux from roof [W/m2] + lfevp_gimp ,&! latent heat flux from impervious road [W/m2] + lfevp_gper ,&! latent heat flux from pervious road [W/m2] + lfevp_urbl ,&! latent heat flux from urban vegetation [W/m2] + + troof ,&! temperature of roof [K] + twall ,&! temperature of wall [K] + + sabvsun ,&! solar absorbed by sunlit vegetation [W/m2] + sabvsha ,&! solar absorbed by shaded vegetation [W/m2] + sabg ,&! solar absorbed by ground [W/m2] + sr ,&! total reflected solar radiation (W/m2) + solvd ,&! incident direct beam vis solar radiation (W/m2) + solvi ,&! incident diffuse beam vis solar radiation (W/m2) + solnd ,&! incident direct beam nir solar radiation (W/m2) + solni ,&! incident diffuse beam nir solar radiation (W/m2) + srvd ,&! reflected direct beam vis solar radiation (W/m2) + srvi ,&! reflected diffuse beam vis solar radiation (W/m2) + srnd ,&! reflected direct beam nir solar radiation (W/m2) + srni ,&! reflected diffuse beam nir solar radiation (W/m2) + solvdln ,&! incident direct beam vis solar radiation at local noon(W/m2) + solviln ,&! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln ,&! incident direct beam nir solar radiation at local noon(W/m2) + solniln ,&! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln ,&! reflected direct beam vis solar radiation at local noon(W/m2) + srviln ,&! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln ,&! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ,&! reflected diffuse beam nir solar radiation at local noon(W/m2) + + forc_rain ,&! rain [mm/s] + forc_snow ,&! snow [mm/s] + + emis ,&! averaged bulk surface emissivity + z0m ,&! effective roughness [m] + zol ,&! dimensionless height (z/L) used in Monin-Obukhov theory + rib ,&! bulk Richardson number in surface layer + ustar ,&! u* in similarity theory [m/s] + qstar ,&! q* in similarity theory [kg/kg] + tstar ,&! t* in similarity theory [K] + fm ,&! integral of profile function for momentum + fh ,&! integral of profile function for heat + fq ! integral of profile function for moisture + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + calday ,&! Julian cal day (1.xx to 365.xx) + endwb ,&! water mass at the end of time step + errore ,&! energy balance error (Wm-2) + errorw ,&! water balance error (mm) + fioldr (maxsnl+1:nl_roof), &! fraction of ice relative to the total water + fioldi (maxsnl+1:nl_soil), &! fraction of ice relative to the total water + fioldp (maxsnl+1:nl_soil), &! fraction of ice relative to the total water + fioldl (maxsnl+1:nl_soil), &! fraction of ice relative to the total water + w_old ,&! liquid water mass of the column at the previous time step (mm) + theta ,&! sun zenith angle + sabv ,&! solar absorbed by vegetation [W/m2] + sabroof ,&! solar absorbed by vegetation [W/m2] + sabwsun ,&! solar absorbed by vegetation [W/m2] + sabwsha ,&! solar absorbed by vegetation [W/m2] + sabgimp ,&! solar absorbed by vegetation [W/m2] + sabgper ,&! solar absorbed by vegetation [W/m2] + sablake ,&! solar absorbed by vegetation [W/m2] + par ,&! PAR by leaves [W/m2] + tgimp ,&! temperature of impervious surface [K] + tgper ,&! temperature of pervious surface [K] + tlake ,&! temperature of lake surface [K] + qdrip_gper ,&! throughfall of pervious (mm h2o/s) + qseva_roof ,&! ground surface evaporation rate (mm h2o/s) + qseva_gimp ,&! ground surface evaporation rate (mm h2o/s) + qseva_gper ,&! ground surface evaporation rate (mm h2o/s) + qseva_lake ,&! ground surface evaporation rate (mm h2o/s) + qsdew_roof ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_gimp ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_gper ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_lake ,&! ground surface dew formation (mm h2o /s) [+] + qsubl_roof ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_gimp ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_gper ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_lake ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros_roof ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gimp ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gper ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_lake ,&! surface dew added to snow pack (mm h2o /s) [+] + scvold_roof ,&! snow mass on roof for previous time step [kg/m2] + scvold_gimp ,&! snow mass on impervious surfaces for previous time step [kg/m2] + scvold_gper ,&! snow mass on pervious surfaces for previous time step [kg/m2] + scvold_lake ,&! snow mass on lake for previous time step [kg/m2] + sm_roof ,&! rate of snowmelt [kg/(m2 s)] + sm_gimp ,&! rate of snowmelt [kg/(m2 s)] + sm_gper ,&! rate of snowmelt [kg/(m2 s)] + sm_lake ,&! rate of snowmelt [kg/(m2 s)] + totwb ,&! water mass at the begining of time step + totwb_roof ,&! water mass at the begining of time step + totwb_gimp ,&! water mass at the begining of time step + totwb_gper ,&! water mass at the begining of time step + wt ,&! fraction of vegetation buried (covered) by snow [-] + rootr (1:nl_soil) ,&! root resistance of a layer, all layers add to 1.0 + rootflux (1:nl_soil) ,&! root resistance of a layer, all layers add to 1.0 + etr_deficit ,&! urban tree etr deficit [mm/s] + urb_irrig ,&! named urban tree irrigation [mm/s] + + zi_wall ( 0:nl_wall) ,&! interface level below a "z" level [m] + z_roofsno (maxsnl+1:nl_roof) ,&! layer depth [m] + z_gimpsno (maxsnl+1:nl_soil) ,&! layer depth [m] + z_gpersno (maxsnl+1:nl_soil) ,&! layer depth [m] + z_lakesno (maxsnl+1:nl_soil) ,&! layer depth [m] + dz_roofsno (maxsnl+1:nl_roof) ,&! layer thickness [m] + dz_gimpsno (maxsnl+1:nl_soil) ,&! layer thickness [m] + dz_gpersno (maxsnl+1:nl_soil) ,&! layer thickness [m] + dz_lakesno (maxsnl+1:nl_soil) ,&! layer thickness [m] + zi_roofsno (maxsnl :nl_roof) ,&! interface level below a "z" level [m] + zi_gimpsno (maxsnl :nl_soil) ,&! interface level below a "z" level [m] + zi_gpersno (maxsnl :nl_soil) ,&! interface level below a "z" level [m] + zi_lakesno (maxsnl :nl_soil) ! interface level below a "z" level [m] + + real(r8) :: & + prc_rain ,&! convective rainfall [kg/(m2 s)] + prc_snow ,&! convective snowfall [kg/(m2 s)] + prl_rain ,&! large scale rainfall [kg/(m2 s)] + prl_snow ,&! large scale snowfall [kg/(m2 s)] + t_precip ,&! snowfall/rainfall temperature [kelvin] + bifall ,&! bulk density of newly fallen dry snow [kg/m3] + pg_rain ,&! rainfall onto ground including canopy runoff [kg/(m2 s)] + pg_snow ,&! snowfall onto ground including canopy runoff [kg/(m2 s)] + pgper_rain ,&! rainfall onto ground including canopy runoff [kg/(m2 s)] + pgper_snow ,&! snowfall onto ground including canopy runoff [kg/(m2 s)] + pgimp_rain ,&! rainfall onto ground including canopy runoff [kg/(m2 s)] + pgimp_snow ,&! snowfall onto ground including canopy runoff [kg/(m2 s)] + pg_rain_lake ,&! rainfall onto lake [kg/(m2 s)] + pg_snow_lake ,&! snowfall onto lake [kg/(m2 s)] + qintr_rain ,&! rainfall interception (mm h2o/s) + qintr_snow ,&! snowfall interception (mm h2o/s) + etrgper ,&! etr for pervious ground + fveg_gper ,&! fraction of fveg/fgper + fveg_gimp ! fraction of fveg/fgimp + + real(r8) :: & + ei ,&! vapor pressure on leaf surface [pa] + deidT ,&! derivative of "ei" on "tl" [pa/K] + qsatl ,&! leaf specific humidity [kg/kg] + qsatldT ! derivative of "qsatl" on "tlef" + + integer :: & + snlr ,&! number of snow layers + snli ,&! number of snow layers + snlp ,&! number of snow layers + snll ,&! number of snow layers + imeltr (maxsnl+1:nl_roof), &! flag for: melting=1, freezing=2, Nothing happened=0 + imelti (maxsnl+1:nl_soil), &! flag for: melting=1, freezing=2, Nothing happened=0 + imeltp (maxsnl+1:nl_soil), &! flag for: melting=1, freezing=2, Nothing happened=0 + imeltl (maxsnl+1:nl_soil), &! flag for: melting=1, freezing=2, Nothing happened=0 + lbr ,&! lower bound of arrays + lbi ,&! lower bound of arrays + lbp ,&! lower bound of arrays + lbl ,&! lower bound of arrays + lbsn ,&! lower bound of arrays + j ! DO looping index + + ! For SNICAR snow model + !---------------------------------------------------------------------- + real(r8) forc_aer ( 14 ) !aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + real(r8) snofrz (maxsnl+1:0) !snow freezing rate (col,lyr) [kg m-2 s-1] + real(r8) sabg_lyr (maxsnl+1:1) !snow layer absorption [W/m-2] + + !irrigation + real(r8) :: & + qflx_irrig_drip ,&! drip irrigation rate [mm/s] + qflx_irrig_sprinkler ,&! sprinkler irrigation rate [mm/s] + qflx_irrig_flood ,&! flood irrigation rate [mm/s] + qflx_irrig_paddy ! paddy irrigation rate [mm/s] + + ! A simple urban irrigation scheme accounts for soil water stress of trees + ! a factor represents irrigation efficiency, '1' represents a 50% direct irrigation efficiency. + real(r8), parameter :: wst_irrig = 1.0 + +!----------------------------------------------------------------------- + + theta = acos(max(coszen,0.01)) + forc_aer(:) = 0. !aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + +!====================================================================== +! [1] Solar absorbed by vegetation and ground +! and precipitation information (rain/snow fall and precip temperature +!====================================================================== + + CALL netsolar_urban (ipatch,idate,patchlonr,deltim,& + forc_sols,forc_soll,forc_solsd,forc_solld,lai,sai,rho,tau,& + alb(:,:),ssun(:,:),ssha(:,:),sroof(:,:),swsun(:,:),& + swsha(:,:),sgimp(:,:),sgper(:,:),slake(:,:),& + sr,sabv,par,sabroof,sabwsun,sabwsha,sabgimp,sabgper,sablake,& + solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) + + CALL rain_snow_temp (patchtype,forc_t,forc_q,forc_psrf,forc_prc,forc_prl,forc_us,forc_vs,& + tcrit,prc_rain,prc_snow,prl_rain,prl_snow,t_precip,bifall) + +#ifdef MPAS_EMBEDDED_COLM + ! MPAS already provides hydrometeor phase; keep it while using CoLM for precipitation temperature. + prc_rain = max(0._r8, min(forc_prc, forc_rain)) + prc_snow = max(0._r8, forc_prc - prc_rain) + prl_rain = max(0._r8, forc_rain - prc_rain) + prl_snow = max(0._r8, forc_snow - prc_snow) +#else + forc_rain = prc_rain + prl_rain + forc_snow = prc_snow + prl_snow +#endif + + sabvsun = sabv * fveg * (1-flake) + sabvsha = 0. + +!====================================================================== + + z_roofsno (maxsnl+1:0) = z_sno_roof (maxsnl+1:0) + z_roofsno (1:nl_roof ) = z_roof (1:nl_roof) + dz_roofsno(maxsnl+1:0) = dz_sno_roof(maxsnl+1:0) + dz_roofsno(1:nl_roof ) = dz_roof(1:nl_roof) + + z_gimpsno (maxsnl+1:0) = z_sno_gimp (maxsnl+1:0) + z_gimpsno (1:nl_soil ) = z_soi (1:nl_soil) + dz_gimpsno(maxsnl+1:0) = dz_sno_gimp(maxsnl+1:0) + dz_gimpsno(1:nl_soil ) = dz_soi(1:nl_soil) + + z_gpersno (maxsnl+1:0) = z_sno_gper (maxsnl+1:0) + z_gpersno (1:nl_soil ) = z_soi (1:nl_soil) + dz_gpersno(maxsnl+1:0) = dz_sno_gper(maxsnl+1:0) + dz_gpersno(1:nl_soil ) = dz_soi(1:nl_soil) + + z_lakesno (maxsnl+1:0) = z_sno_lake (maxsnl+1:0) + z_lakesno (1:nl_soil ) = z_soi (1:nl_soil) + dz_lakesno(maxsnl+1:0) = dz_sno_lake(maxsnl+1:0) + dz_lakesno(1:nl_soil ) = dz_soi(1:nl_soil) + + !============================================================ + zi_wall(0) = 0. + DO j = 1, nl_wall + zi_wall(j) = zi_wall(j-1) + dz_wall(j) + ENDDO + + !============================================================ + scvold_roof = scv_roof !snow mass at previous time step + + snlr = 0 + DO j = maxsnl+1, 0 + IF (wliq_roofsno(j)+wice_roofsno(j) > 0.) snlr = snlr - 1 + ENDDO + + zi_roofsno(0) = 0. + IF (snlr < 0) THEN + DO j = -1, snlr, -1 + zi_roofsno(j) = zi_roofsno(j+1) - dz_roofsno(j+1) + ENDDO + ENDIF + DO j = 1, nl_roof + zi_roofsno(j) = zi_roofsno(j-1) + dz_roofsno(j) + ENDDO + + totwb_roof = scv_roof + wice_roofsno(1) + wliq_roofsno(1) + fioldr(:) = 0.0 + IF (snlr < 0) THEN + fioldr(snlr+1:0) = wice_roofsno(snlr+1:0) / & + (wliq_roofsno(snlr+1:0) + wice_roofsno(snlr+1:0)) + ENDIF + + !============================================================ + scvold_gimp = scv_gimp !snow mass at previous time step + + snli = 0 + DO j = maxsnl+1, 0 + IF (wliq_gimpsno(j)+wice_gimpsno(j) > 0.) snli = snli - 1 + ENDDO + + zi_gimpsno(0) = 0. + IF (snli < 0) THEN + DO j = -1, snli, -1 + zi_gimpsno(j) = zi_gimpsno(j+1) - dz_gimpsno(j+1) + ENDDO + ENDIF + + zi_gimpsno(1:nl_soil) = zi_soi(1:nl_soil) + + totwb_gimp = scv_gimp + wice_gimpsno(1) + wliq_gimpsno(1) + fioldi(:) = 0.0 + IF (snli < 0) THEN + fioldi(snli+1:0) = wice_gimpsno(snli+1:0) / & + (wliq_gimpsno(snli+1:0) + wice_gimpsno(snli+1:0)) + ENDIF + + !============================================================ + scvold_gper = scv_gper !snow mass at previous time step + + snlp = 0 + DO j = maxsnl+1, 0 + IF(wliq_gpersno(j)+wice_gpersno(j) > 0.) snlp = snlp - 1 + ENDDO + + zi_gpersno(0) = 0. + IF (snlp < 0) THEN + DO j = -1, snlp, -1 + zi_gpersno(j) = zi_gpersno(j+1) - dz_gpersno(j+1) + ENDDO + ENDIF + + zi_gpersno(1:nl_soil) = zi_soi(1:nl_soil) + + totwb_gper = ldew + scv_gper + sum(wice_gpersno(1:) + wliq_gpersno(1:)) + wa + fioldp(:) = 0.0 + IF (snlp < 0) THEN + fioldp(snlp+1:0) = wice_gpersno(snlp+1:0) / & + (wliq_gpersno(snlp+1:0) + wice_gpersno(snlp+1:0)) + ENDIF + + !============================================================ + scvold_lake = scv_lake !snow mass at previous time step + + snll = 0 + DO j = maxsnl+1, 0 + IF (wliq_lakesno(j) + wice_lakesno(j) > 0.) snll = snll - 1 + ENDDO + + zi_lakesno(0) = 0. + IF (snll < 0) THEN + DO j = -1, snll, -1 + zi_lakesno(j) = zi_lakesno(j+1) - dz_lakesno(j+1) + ENDDO + ENDIF + + zi_lakesno(1:nl_soil) = zi_soi(1:nl_soil) + + w_old = sum(wliq_lakesno(snll+1:)) + fioldl(:) = 0.0 + IF (snll <0 ) THEN + fioldl(snll+1:0) = wice_lakesno(snll+1:0) / & + (wliq_lakesno(snll+1:0) + wice_lakesno(snll+1:0)) + ENDIF + + !============================================================ + totwb = sum(wice_soisno(1:) + wliq_soisno(1:)) + totwb = totwb + scv + ldew*fveg + wa*(1-froof)*fgper + + etr_deficit = 0. + urb_irrig = 0. + +!---------------------------------------------------------------------- +! [2] Canopy interception and precipitation onto ground surface +!---------------------------------------------------------------------- + qflx_irrig_drip = 0._r8 + qflx_irrig_sprinkler = 0._r8 + qflx_irrig_flood = 0._r8 + qflx_irrig_paddy = 0._r8 + + ! with vegetation canopy + CALL LEAF_interception_CoLM2014 (deltim,dewmx,forc_us,forc_vs,chil,sigf,lai,sai,tref,tleaf,& + prc_rain,prc_snow,prl_rain,prl_snow,qflx_irrig_sprinkler,bifall,& + ldew,ldew_rain,ldew_snow,z0m,forc_hgt_u,pgper_rain,pgper_snow,& + qintr,qintr_rain,qintr_snow) + + ! for output, patch scale + qintr = qintr * fveg * (1-flake) + qdrip_gper = pgper_rain + pgper_snow + qdrip = forc_rain + forc_snow + qdrip = qdrip*(1-fveg*(1-flake)) + qdrip_gper*fveg*(1-flake) + + ! without vegetation canopy + pg_rain = prc_rain + prl_rain + pg_snow = prc_snow + prl_snow + pg_rain_lake = prc_rain + prl_rain + pg_snow_lake = prc_snow + prl_snow + + ! for urban hydrology input, only for pervious ground + IF (fgper > 0) THEN + fveg_gper = fveg/((1-froof)*fgper) + ELSE + fveg_gper = 0. + ENDIF + + IF (fgper < 1) THEN + fveg_gimp = (fveg-(1-froof)*fgper)/((1-froof)*(1-fgper)) + ELSE + fveg_gimp = 0. + ENDIF + + IF (fveg_gper .le. 1) THEN + pgper_rain = pgper_rain*fveg_gper + pg_rain*(1-fveg_gper) + pgper_snow = pgper_snow*fveg_gper + pg_snow*(1-fveg_gper) + pgimp_rain = pg_rain + pgimp_snow = pg_snow + ELSE + pgimp_rain = pgper_rain*fveg_gimp + pg_rain*(1-fveg_gimp) + pgimp_snow = pgper_snow*fveg_gimp + pg_snow*(1-fveg_gimp) + ENDIF + +!---------------------------------------------------------------------- +! [3] Initialize new snow nodes for snowfall / sleet +!---------------------------------------------------------------------- + + lbr = snlr + 1 !lower bound of array + lbi = snli + 1 !lower bound of array + lbp = snlp + 1 !lower bound of array + troof = t_roofsno(lbr) + tgimp = t_gimpsno(lbi) + tgper = t_gpersno(lbp) + + CALL newsnow (patchtype,maxsnl,deltim,troof,pg_rain,pg_snow,bifall,& + t_precip,zi_roofsno(:0),z_roofsno(:0),dz_roofsno(:0),t_roofsno(:0),& + wliq_roofsno(:0),wice_roofsno(:0),fioldr(:0),& + snlr,sag_roof,scv_roof,snowdp_roof,fsno_roof) + + CALL newsnow (patchtype,maxsnl,deltim,tgimp,pgimp_rain,pgimp_snow,bifall,& + t_precip,zi_gimpsno(:0),z_gimpsno(:0),dz_gimpsno(:0),t_gimpsno(:0),& + wliq_gimpsno(:0),wice_gimpsno(:0),fioldi(:0),& + snli,sag_gimp,scv_gimp,snowdp_gimp,fsno_gimp) + + CALL newsnow (patchtype,maxsnl,deltim,tgper,pgper_rain,pgper_snow,bifall,& + t_precip,zi_gpersno(:0),z_gpersno(:0),dz_gpersno(:0),t_gpersno(:0),& + wliq_gpersno(:0),wice_gpersno(:0),fioldp(:0),& + snlp,sag_gper,scv_gper,snowdp_gper,fsno_gper) + + CALL newsnow_lake ( DEF_USE_Dynamic_Lake, & + ! "in" arguments + ! --------------- + maxsnl ,nl_lake ,deltim ,dz_lake ,& + pg_rain_lake ,pg_snow_lake ,t_precip ,bifall ,& + + ! "inout" arguments + ! ------------------ + t_lake ,zi_lakesno(:0),z_lakesno(:0) ,& + dz_lakesno(:0),t_lakesno(:0) ,wliq_lakesno(:0),wice_lakesno(:0),& + fioldl(:0) ,snll ,sag_lake ,scv_lake ,& + snowdp_lake ,lake_icefrac ) + +!---------------------------------------------------------------------- +! [4] Energy and Water balance +!---------------------------------------------------------------------- + + lbr = snlr + 1 !lower bound of array + lbi = snli + 1 !lower bound of array + lbp = snlp + 1 !lower bound of array + lbl = snll + 1 !lower bound of array + lbsn= min(lbp,0) + + ! Thermal process + CALL UrbanTHERMAL ( & + ! model running information + ipatch ,patchtype ,lbr ,lbi ,& + lbp ,lbl ,deltim ,patchlatr ,& + ! forcing + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_psrf ,& + forc_rhoair ,forc_frl ,forc_po2m ,forc_pco2m ,& + forc_sols ,forc_soll ,forc_solsd ,forc_solld ,& + theta ,sabroof ,sabwsun ,sabwsha ,& + sabgimp ,sabgper ,sablake ,sabv ,& + par ,Fhac ,Fwst ,Fach ,& + Fahe ,Fhah ,vehc ,meta ,& + ! LUCY INPUT PARAMETERS + fix_holiday ,week_holiday ,hum_prof ,pop_den ,& + vehicle ,weh_prof ,wdh_prof ,idate ,& + patchlonr ,& + ! GROUND PARAMETERS + froof ,flake ,hroof ,hlr ,& + fgper ,pondmx ,em_roof ,em_wall ,& + em_gimp ,em_gper ,trsmx0 ,zlnd ,& + zsno ,capr ,cnfac ,vf_quartz ,& + vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& + wf_sand ,csol ,porsl ,psi0 ,& +#ifdef Campbell_SOIL_MODEL + bsw ,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r ,alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm ,& +#endif + k_solids ,dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,& + cv_roof ,cv_wall ,cv_gimp ,& + tk_roof ,tk_wall ,tk_gimp ,dz_roofsno(lbr:) ,& + dz_gimpsno(lbi:) ,dz_gpersno(lbp:) ,dz_lakesno(:) ,dz_wall(:) ,& + z_roofsno(lbr:) ,z_gimpsno(lbi:) ,z_gpersno(lbp:) ,z_lakesno(:) ,& + z_wall(:) ,zi_roofsno(lbr-1:) ,zi_gimpsno(lbi-1:) ,zi_gpersno(lbp-1:) ,& + zi_lakesno(:) ,zi_wall(0:) ,dz_lake(1:) ,lakedepth ,& + dewmx ,sqrtdi ,rootfr(:) ,effcon ,& + vmax25 ,c3c4 ,slti ,hlti ,shti,& + hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,& + extkn ,lambda ,& + ! surface status + fsno_roof ,fsno_gimp ,fsno_gper ,scv_roof ,& + scv_gimp ,scv_gper ,scv_lake ,snowdp_roof ,& + snowdp_gimp ,snowdp_gper ,snowdp_lake ,fwsun ,& + dfwsun ,lai ,sai ,htop ,& + hbot ,fveg ,sigf ,extkd ,& + lwsun ,lwsha ,lgimp ,lgper ,& + t_grnd ,t_roofsno(lbr:) ,t_wallsun(:) ,t_wallsha(:) ,& + t_gimpsno(lbi:) ,t_gpersno(lbp:) ,t_lakesno(:) ,wliq_roofsno(lbr:) ,& + wliq_gimpsno(lbi:) ,wliq_gpersno(lbp:) ,wliq_lakesno(:) ,wice_roofsno(lbr:) ,& + wice_gimpsno(lbi:) ,wice_gpersno(lbp:) ,wice_lakesno(:) ,t_lake(:) ,& + lake_icefrac(:) ,savedtke1 ,lveg ,tleaf ,& + ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + t_room ,troof_inner ,twsun_inner ,twsha_inner ,& + t_roommax ,t_roommin ,tafu ,& + +! SNICAR model variables + snofrz(lbsn:0) ,sabg_lyr(lbp:1) ,& +! END SNICAR model variables + + ! output + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + fsen_roof ,fsen_wsun ,fsen_wsha ,fsen_gimp ,& + fsen_gper ,fsen_urbl ,troof ,twall ,& + lfevp_roof ,lfevp_gimp ,lfevp_gper ,lfevp_urbl ,& + qseva_roof ,qseva_gimp ,qseva_gper ,qseva_lake ,& + qsdew_roof ,qsdew_gimp ,qsdew_gper ,qsdew_lake ,& + qsubl_roof ,qsubl_gimp ,qsubl_gper ,qsubl_lake ,& + qfros_roof ,qfros_gimp ,qfros_gper ,qfros_lake ,& + imeltr(lbr:) ,imelti(lbi:) ,imeltp(lbp:) ,imeltl(:) ,& + sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& + sabg ,rstfac ,rootr(:) ,etr_deficit ,& + tref ,qref ,trad ,rst ,& + assim ,respc ,errore ,emis ,& + z0m ,zol ,rib ,ustar ,& + qstar ,tstar ,fm ,fh ,& + fq ,hpbl ) + +!---------------------------------------------------------------------- +! [5] Urban hydrology +!---------------------------------------------------------------------- + IF (fveg > 0) THEN + ! convert to unit area + etrgper = (etr-etr_deficit)/(1-froof)/fgper + ELSE + etrgper = 0. + ENDIF + + pgper_rain = pgper_rain + wst_irrig*etr_deficit/(1-froof)/fgper + urb_irrig = etr_deficit + wst_irrig*etr_deficit + + CALL UrbanHydrology ( & + ! model running information + ipatch ,patchtype ,lbr ,lbi ,& + lbp ,lbl ,snll ,deltim ,& + ! forcing + pg_rain ,pgper_rain ,pgimp_rain ,pg_snow ,& + pg_rain_lake ,pg_snow_lake ,& + froof ,fgper ,flake ,bsw ,& + porsl ,psi0 ,hksati ,pondmx ,& + ssi ,wimp ,smpmin ,theta_r ,& + fsatmax ,fsatdcf ,elvstd ,BVIC ,& + rootr,rootflux ,etrgper ,fseng ,fgrnd ,& + t_gpersno(lbp:) ,t_lakesno(:) ,t_lake ,dz_lake ,& + z_gpersno(lbp:) ,z_lakesno(:) ,zi_gpersno(lbp-1:) ,zi_lakesno(:) ,& + dz_roofsno(lbr:) ,dz_gimpsno(lbi:) ,dz_gpersno(lbp:) ,dz_lakesno(:) ,& + wliq_roofsno(lbr:) ,wliq_gimpsno(lbi:) ,wliq_gpersno(lbp:) ,wliq_lakesno(:) ,& + wice_roofsno(lbr:) ,wice_gimpsno(lbi:) ,wice_gpersno(lbp:) ,wice_lakesno(:) ,& + qseva_roof ,qseva_gimp ,qseva_gper ,qseva_lake ,& + qsdew_roof ,qsdew_gimp ,qsdew_gper ,qsdew_lake ,& + qsubl_roof ,qsubl_gimp ,qsubl_gper ,qsubl_lake ,& + qfros_roof ,qfros_gimp ,qfros_gper ,qfros_lake ,& + sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& + lake_icefrac ,scv_lake ,snowdp_lake ,imeltl ,& + fioldl ,w_old ,& + forc_us ,forc_vs ,& + +! SNICAR model variables + forc_aer ,& + mss_bcpho(lbsn:0) ,mss_bcphi(lbsn:0) ,mss_ocpho(lbsn:0) ,mss_ocphi(lbsn:0) ,& + mss_dst1 (lbsn:0) ,mss_dst2 (lbsn:0) ,mss_dst3 (lbsn:0) ,mss_dst4 (lbsn:0) ,& +! END SNICAR model variables +! irrigaiton + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy ,& +! end irrigation + ! output + rsur ,rnof ,qinfl ,zwt ,& + wdsrf ,wa ,qcharge ,smp ,hk ) + + ! roof + !============================================================ + IF (snlr < 0) THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lbr = snlr + 1 ! lower bound of array + CALL snowcompaction (lbr,deltim,& + imeltr(lbr:0),fioldr(lbr:0),t_roofsno(lbr:0),& + wliq_roofsno(lbr:0),wice_roofsno(lbr:0),forc_us,forc_vs,dz_roofsno(lbr:0)) + + ! Combine thin snow elements + lbr = maxsnl + 1 + CALL snowlayerscombine (lbr,snlr,& + z_roofsno(lbr:1),dz_roofsno(lbr:1),zi_roofsno(lbr-1:1),& + wliq_roofsno(lbr:1),wice_roofsno(lbr:1),t_roofsno(lbr:1),& + scv_roof,snowdp_roof) + + ! Divide thick snow elements + IF (snlr < 0) & + CALL snowlayersdivide (lbr,snlr,& + z_roofsno(lbr:0),dz_roofsno(lbr:0),zi_roofsno(lbr-1:0),& + wliq_roofsno(lbr:0),wice_roofsno(lbr:0),t_roofsno(lbr:0)) + ENDIF + + ! Set zero to the empty node + IF (snlr > maxsnl) THEN + wice_roofsno(maxsnl+1:snlr) = 0. + wliq_roofsno(maxsnl+1:snlr) = 0. + t_roofsno (maxsnl+1:snlr) = 0. + z_roofsno (maxsnl+1:snlr) = 0. + dz_roofsno (maxsnl+1:snlr) = 0. + ENDIF + + lbr = snlr + 1 + troof = t_roofsno(lbr) + + ! impervious ground + !============================================================ + IF (snli < 0) THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lbi = snli + 1 ! lower bound of array + CALL snowcompaction (lbi,deltim,& + imelti(lbi:0),fioldi(lbi:0),t_gimpsno(lbi:0),& + wliq_gimpsno(lbi:0),wice_gimpsno(lbi:0),forc_us,forc_vs,dz_gimpsno(lbi:0)) + + ! Combine thin snow elements + lbi = maxsnl + 1 + CALL snowlayerscombine (lbi,snli,& + z_gimpsno(lbi:1),dz_gimpsno(lbi:1),zi_gimpsno(lbi-1:1),& + wliq_gimpsno(lbi:1),wice_gimpsno(lbi:1),t_gimpsno(lbi:1),& + scv_gimp,snowdp_gimp) + + ! Divide thick snow elements + IF (snli < 0) & + CALL snowlayersdivide (lbi,snli,& + z_gimpsno(lbi:0),dz_gimpsno(lbi:0),zi_gimpsno(lbi-1:0),& + wliq_gimpsno(lbi:0),wice_gimpsno(lbi:0),t_gimpsno(lbi:0)) + ENDIF + + ! Set zero to the empty node + IF (snli > maxsnl) THEN + wice_gimpsno(maxsnl+1:snli) = 0. + wliq_gimpsno(maxsnl+1:snli) = 0. + t_gimpsno (maxsnl+1:snli) = 0. + z_gimpsno (maxsnl+1:snli) = 0. + dz_gimpsno (maxsnl+1:snli) = 0. + ENDIF + + lbi = snli + 1 + tgimp = t_gimpsno(lbi) + + ! pervious ground + !============================================================ + IF (snlp < 0) THEN + ! Compaction rate for snow + ! Natural compaction and metamorphosis. The compaction rate + ! is recalculated for every new timestep + lbp = snlp + 1 ! lower bound of array + CALL snowcompaction (lbp,deltim,& + imeltp(lbp:0),fioldp(lbp:0),t_gpersno(lbp:0),& + wliq_gpersno(lbp:0),wice_gpersno(lbp:0),forc_us,forc_vs,dz_gpersno(lbp:0)) + + ! Combine thin snow elements + lbp = maxsnl + 1 + CALL snowlayerscombine (lbp,snlp,& + z_gpersno(lbp:1),dz_gpersno(lbp:1),zi_gpersno(lbp-1:1),& + wliq_gpersno(lbp:1),wice_gpersno(lbp:1),t_gpersno(lbp:1),& + scv_gper,snowdp_gper) + + ! Divide thick snow elements + IF (snlp < 0) & + CALL snowlayersdivide (lbp,snlp,& + z_gpersno(lbp:0),dz_gpersno(lbp:0),zi_gpersno(lbp-1:0),& + wliq_gpersno(lbp:0),wice_gpersno(lbp:0),t_gpersno(lbp:0)) + ENDIF + + ! Set zero to the empty node + IF (snlp > maxsnl) THEN + wice_gpersno(maxsnl+1:snlp) = 0. + wliq_gpersno(maxsnl+1:snlp) = 0. + t_gpersno (maxsnl+1:snlp) = 0. + z_gpersno (maxsnl+1:snlp) = 0. + dz_gpersno (maxsnl+1:snlp) = 0. + ENDIF + + lbp = snlp + 1 + tgper = t_gpersno(lbp) + + !TODO: temporal, set to t_soisno + t_soisno(:) = t_gpersno(:) + + !TODO: how to set tlake + lbl = snll + 1 + IF (lbl < 1) THEN + tlake = t_lakesno(lbl) + ELSE + tlake = t_lake(1) + ENDIF + + ! ---------------------------------------- + ! energy balance check + ! ---------------------------------------- + zerr=errore +#if (defined CoLMDEBUG) + IF(abs(errore)>.5)THEN + write(6,*) 'Warning: energy balance violation ',errore,patchclass + ENDIF +#endif + + ! ---------------------------------------- + ! water balance check + ! ---------------------------------------- + + wliq_soisno(: ) = 0. + wliq_soisno(:1) = wliq_roofsno(:1)*froof + wliq_soisno(: ) = wliq_soisno(: ) + wliq_gpersno(: )*(1-froof)*fgper + wliq_soisno(:1) = wliq_soisno(:1) + wliq_gimpsno(:1)*(1-froof)*(1-fgper) + !wliq_soisno(:) = wliq_soisno(:)*(1-flake) + wliq_lakesno(:)*flake + + wice_soisno(: ) = 0. + wice_soisno(:1) = wice_roofsno(:1)*froof + wice_soisno(: ) = wice_soisno(: ) + wice_gpersno(: )*(1-froof)*fgper + wice_soisno(:1) = wice_soisno(:1) + wice_gimpsno(:1)*(1-froof)*(1-fgper) + !wice_soisno(:) = wice_soisno(:)*(1-flake) + wice_lakesno(:)*flake + + scv = scv_roof*froof + scv_gper*(1-froof)*fgper + scv_gimp*(1-froof)*(1-fgper) + !scv = scv*(1-flake) + scv_lake*flake + + endwb = sum(wice_soisno(1:) + wliq_soisno(1:)) + endwb = endwb + scv + ldew*fveg + wa*(1-froof)*fgper + errorw = (endwb - totwb) - (forc_prc + forc_prl + urb_irrig - fevpa - rnof)*deltim + xerr = errorw/deltim + +#if (defined CoLMDEBUG) + IF(abs(errorw)>1.e-3) THEN + write(6,*) 'Warning: water balance violation', errorw, ipatch, patchclass + !STOP + ENDIF +#endif + +!====================================================================== +! Preparation for the next time step +! 1) time-varying parameters for vegetation +! 2) fraction of snow cover +! 3) solar zenith angle and +! 4) albedos +!====================================================================== + + ! cosine of solar zenith angle + calday = calendarday(idate) + coszen = orb_coszen(calday,patchlonr,patchlatr) + + ! fraction of snow cover. + CALL snowfraction ( 0., 0.,z0m,zlnd,scv_lake,snowdp_lake,wt,sigf,fsno_lake) + CALL snowfraction ( 0., 0.,z0m,zlnd,scv_roof,snowdp_roof,wt,sigf,fsno_roof) + CALL snowfraction ( 0., 0.,z0m,zlnd,scv_gimp,snowdp_gimp,wt,sigf,fsno_gimp) + CALL snowfraction (lai,sai,z0m,zlnd,scv_gper,snowdp_gper,wt,sigf,fsno_gper) + lai = tlai(ipatch) + sai = tsai(ipatch) * sigf + + ! update the snow age + !TODO: can be moved to UrbanALBEDO.F90 + IF (snlr == 0) sag_roof = 0. + CALL snowage (deltim,troof,scv_roof,scvold_roof,sag_roof) + IF (snli == 0) sag_gimp = 0. + CALL snowage (deltim,tgimp,scv_gimp,scvold_gimp,sag_gimp) + IF (snlp == 0) sag_gper = 0. + CALL snowage (deltim,tgper,scv_gper,scvold_gper,sag_gper) + IF (snll == 0) sag_lake = 0. + CALL snowage (deltim,tlake,scv_lake,scvold_lake,sag_lake) + + ! update snow depth, snow cover and snow age + snowdp = snowdp_roof*froof + snowdp_gper*(1-froof)*fgper + snowdp_gimp*(1-froof)*(1-fgper) + fsno = fsno_roof*froof + fsno_gper*(1-froof)*fgper + fsno_gimp*(1-froof)*(1-fgper) + sag = sag_roof*froof + sag_gper*(1-froof)*fgper + sag_gimp*(1-froof)*(1-fgper) + + ! albedos + ! we supposed call it every time-step, because + ! other vegetation related parameters are needed to create + + CALL alburban (ipatch,froof,fgper,flake,hlr,hroof,& + alb_roof,alb_wall,alb_gimp,alb_gper,& + rho,tau,fveg,(htop+hbot)/2.,lai,sai,fwet_snow,coszen,fwsun,tlake,& + fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& + scv_roof,scv_gimp,scv_gper,scv_lake,& + sag_roof,sag_gimp,sag_gper,sag_lake,& + dfwsun,extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) + + ! zero-filling set for glacier/ice-sheet/land water bodies/ocean components + laisun = lai + laisha = 0.0 + green = 1. + + h2osoi = wliq_soisno(1:)/(dz_soi(1:)*denh2o) + wice_soisno(1:)/(dz_soi(1:)*denice) + wat = sum(wice_soisno(1:)+wliq_soisno(1:)) + wat = wat + scv + ldew*fveg + wa*(1-froof)*fgper + + z_sno_roof (maxsnl+1:0) = z_roofsno (maxsnl+1:0) + z_sno_gimp (maxsnl+1:0) = z_gimpsno (maxsnl+1:0) + z_sno_gper (maxsnl+1:0) = z_gpersno (maxsnl+1:0) + z_sno_lake (maxsnl+1:0) = z_lakesno (maxsnl+1:0) + + dz_sno_roof(maxsnl+1:0) = dz_roofsno(maxsnl+1:0) + dz_sno_gimp(maxsnl+1:0) = dz_gimpsno(maxsnl+1:0) + dz_sno_gper(maxsnl+1:0) = dz_gpersno(maxsnl+1:0) + dz_sno_lake(maxsnl+1:0) = dz_lakesno(maxsnl+1:0) + + z_sno(:) = z_sno_roof(:)*froof + z_sno(:) = z_sno(:) + z_sno_gper(:)*(1-froof)*fgper + z_sno(:) = z_sno(:) + z_sno_gimp(:)*(1-froof)*(1-fgper) + z_sno(:) = z_sno(:)*(1-flake) + z_sno_lake(:)*flake + + dz_sno(:) = dz_sno_roof(:)*froof + dz_sno(:) = dz_sno(:) + dz_sno_gper(:)*(1-froof)*fgper + dz_sno(:) = dz_sno(:) + dz_sno_gimp(:)*(1-froof)*(1-fgper) + dz_sno(:) = dz_sno(:)*(1-flake) + dz_sno_lake(:)*flake + +! diagnostic diurnal temperature + !IF (tref > tmax) tmax = tref + !IF (tref < tmin) tmin = tref + +! 06/05/2022, yuan: RH for output to compare + CALL qsadv(tref,forc_psrf,ei,deiDT,qsatl,qsatlDT) + qref = qref/qsatl + +END SUBROUTINE CoLMMAIN_Urban +! ---------------------------------------------------------------------- +! EOP diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Albedo.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Albedo.F90 new file mode 100644 index 0000000000..07d568478e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Albedo.F90 @@ -0,0 +1,371 @@ +#include + +MODULE MOD_Urban_Albedo +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Calculate the total urban albedo. Prepare albedo values over water, +! roof, ground with snow cover. Then CALL 3D urban radiation transfer +! model. Finally calculate the total albedo weighted by the urban and +! water fractional cover. +! +! Created by Hua Yuan, 09/2021 +! +! +! !REVISIONS: +! +! 07/2023, Hua Yuan: Fix low zenith angle problem for urban radiation +! calculation and urban display height problem when +! considering vegetations. modify limitation for conzen value +! (0.001->0.01) for urban. +! +! 05/2024, Hua Yuan: Account for vegetation snow optical properties. +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: alburban + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE alburban (ipatch,froof,fgper,flake,hlr,hroof,& + alb_roof,alb_wall,alb_gimp,alb_gper,& + rho,tau,fveg,hveg,lai,sai,fwet_snow,coszen,fwsun,tlake,& + fsno_roof,fsno_gimp,fsno_gper,fsno_lake,& + scv_roof,scv_gimp,scv_gper,scv_lake,& + sag_roof,sag_gimp,sag_gper,sag_lake,& + dfwsun,extkd,alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake) + +!======================================================================= +! Calculates fragmented albedos (direct and diffuse) for urban area in +! wavelength regions split at 0.7um. +! +! (1) snow albedos: as in BATS formulations, which are inferred from +! the calculations of Wiscombe and Warren (1980) and the snow model +! and data of Anderson(1976), and the function of snow age, grain +! size, solar zenith angle, pollution, the amount of the fresh snow +! (2) lake and wetland albedos: as in BATS, which depend on cosine solar +! zenith angle, based on data in Henderson-Sellers (1986). The +! frozen lake and wetland albedos are set to constants (0.6 for +! visible beam, 0.4 for near-infrared) +! (3) over the snow covered surface, the surface albedo is estimated by +! a linear combination of albedos for snow, roof, impervious and +! pervious ground +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: tfrz + USE MOD_Namelist, only: DEF_VEG_SNOW + USE MOD_Urban_Shortwave + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- +! ground cover index + integer, intent(in) :: & + ipatch ! patch index + + real(r8), intent(in) :: & + froof, &! roof fraction + fgper, &! impervious ground weight fraction + flake, &! lake fraction + hlr, &! average building height to their side length + hroof ! average building height + + real(r8), intent(in) :: & + alb_roof(2,2), &! roof albedo (iband,direct/diffuse) + alb_wall(2,2), &! wall albedo (iband,direct/diffuse) + alb_gimp(2,2), &! impervious albedo (iband,direct/diffuse) + alb_gper(2,2) ! pervious albedo (iband,direct/diffuse) + + real(r8), intent(in) :: & + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2), &! leaf transmittance (iw=iband, il=life and dead) + fveg, &! fractional vegetation cover [-] + hveg, &! vegetation central crown height [m] + lai, &! leaf area index (LAI+SAI) [m2/m2] + sai, &! stem area index (LAI+SAI) [m2/m2] + fwet_snow, &! vegetation snow fractional cover [-] + + ! variables + coszen, &! cosine of solar zenith angle [-] + fwsun, &! sunlit wall fraction [-] + tlake, &! lake surface temperature [K] + fsno_roof, &! fraction of soil covered by snow [-] + fsno_gimp, &! fraction of soil covered by snow [-] + fsno_gper, &! fraction of soil covered by snow [-] + fsno_lake, &! fraction of soil covered by snow [-] + scv_roof, &! snow cover, water equivalent [mm] + scv_gimp, &! snow cover, water equivalent [mm] + scv_gper, &! snow cover, water equivalent [mm] + scv_lake, &! snow cover, water equivalent [mm] + sag_roof, &! non dimensional snow age [-] + sag_gimp, &! non dimensional snow age [-] + sag_gper, &! non dimensional snow age [-] + sag_lake ! non dimensional snow age [-] + + real(r8), intent(out) :: & + dfwsun, &! change of fwsun + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + alb (2,2), &! averaged albedo [-] + ssun (2,2), &! sunlit canopy absorption for solar radiation + ssha (2,2), &! shaded canopy absorption for solar radiation, + sroof(2,2), &! roof absorption for solar radiation, + swsun(2,2), &! sunlit wall absorption for solar radiation, + swsha(2,2), &! shaded wall absorption for solar radiation, + sgimp(2,2), &! impervious ground absorption for solar radiation, + sgper(2,2), &! pervious ground absorption for solar radiation, + slake(2,2) ! lake absorption for solar radiation, + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + age, &! factor to reduce visible snow alb due to snow age [-] + albg0, &! temporary varaiable [-] + alb_s_inc, &! decrease in soil albedo due to wetness [-] + beta0, &! upscattering parameter for direct beam [-] + cff, &! snow alb correction factor for zenith angle > 60 [-] + conn, &! constant (=0.5) for visible snow alb calculation [-] + cons, &! constant (=0.2) for nir snow albedo calculation [-] + czen, &! cosine of solar zenith angle > 0 [-] + theta, &! solar zenith angle + fwsun_, &! sunlit wall fraction + czf, &! solar zenith correction for new snow albedo [-] + dfalbl, &! snow albedo for diffuse nir radiation [-] + dfalbs, &! snow albedo for diffuse visible solar radiation [-] + dralbl, &! snow albedo for visible radiation [-] + dralbs, &! snow albedo for near infrared radiation [-] + sl, &! factor that helps control alb zenith dependence [-] + snal0, &! alb for visible,incident on new snow (zen ang<60) [-] + snal1 ! alb for NIR, incident on new snow (zen angle<60) [-] + + real(r8) :: & + erho(2), &! effective reflection of leaf+stem + etau(2), &! effective transmittance of leaf+stem + albsno (2,2), &! snow albedo [-] + albroof(2,2), &! albedo, ground + albgimp(2,2), &! albedo, ground + albgper(2,2), &! albedo, ground + alblake(2,2) ! albedo, ground + + ! vegetation snow optical properties, 1:vis, 2:nir + real(r8) :: rho_sno(2), tau_sno(2) + data rho_sno(1), rho_sno(2) /0.5, 0.2/ + data tau_sno(1), tau_sno(2) /0.3, 0.2/ + +! ---------------------------------------------------------------------- +! 1. Initial set +! ---------------------------------------------------------------------- + +! short and long wave albedo for new snow + snal0 = 0.85 ! shortwave + snal1 = 0.65 ! long wave + +! ---------------------------------------------------------------------- +! set default soil and vegetation albedos and solar absorption + alb (:,:) = 1. ! averaged + ssun (:,:) = 0. + ssha (:,:) = 0. + sroof (:,:) = 0. + swsun (:,:) = 0. + swsha (:,:) = 0. + sgimp (:,:) = 0. + sgper (:,:) = 0. + alblake (:,:) = 1. + slake (:,:) = 0. + + dfwsun = 0. + extkd = 0.718 + + IF(coszen <= -0.3) THEN + !print *, "coszen < 0, ipatch and coszen: ", ipatch, coszen + RETURN !only do albedo when coszen > -0.3 + ENDIF + + czen = max(coszen, 0.01) + albsno(:,:) = 0. !set initial snow albedo + cons = 0.2 !parameter for snow albedo + conn = 0.5 !parameter for snow albedo + sl = 2.0 !sl helps control albedo zenith dependence + + ! effective leaf optical properties: rho and tau. + IF (lai+sai>1.e-6 .and. fveg>0.) THEN + erho(:) = rho(:,1)*lai/(lai+sai) + rho(:,2)*sai/(lai+sai) + etau(:) = tau(:,1)*lai/(lai+sai) + tau(:,2)*sai/(lai+sai) + ENDIF + + ! correct for snow on leaf + IF ( DEF_VEG_SNOW ) THEN + ! modify rho, tau, USE: fwet_snow + erho(:) = (1-fwet_snow)*erho(:) + fwet_snow*rho_sno(:) + etau(:) = (1-fwet_snow)*etau(:) + fwet_snow*tau_sno(:) + ENDIF + +! ---------------------------------------------------------------------- +! 2. get albedo over water, roof, ground +! ---------------------------------------------------------------------- + +! 2.1 albedo for inland water (NOTE: wetland is removed) + albg0 = 0.05/(czen+0.15) + alblake(:,1) = albg0 + alblake(:,2) = 0.1 !Subin (2012) + + IF (tlake < tfrz) THEN !frozen lake and wetland + alblake(1,:) = 0.6 + alblake(2,:) = 0.4 + ENDIF + + IF (scv_lake > 0.) THEN + + ! correction for snow age + age = 1.-1./(1.+sag_lake) !correction for snow age + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ENDIF + + alblake(:,:) = (1.-fsno_lake)*alblake(:,:) + fsno_lake*albsno(:,:) + slake(:,:) = 1. - alblake(:,:) + +! 2.2 roof albedo with snow + IF (scv_roof > 0.) THEN + + ! correction for snow age + age = 1.-1./(1.+sag_roof) !correction for snow age + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ENDIF + + albroof(:,:) = (1.-fsno_roof)*alb_roof(:,:) + fsno_roof*albsno(:,:) + +! 2.3 impervious ground albedo with snow + IF (scv_gimp > 0.) THEN + + ! correction for snow age + age = 1.-1./(1.+sag_gimp) !correction for snow age + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ENDIF + + albgimp(:,:) = (1.-fsno_gimp)*alb_gimp(:,:) + fsno_gimp*albsno(:,:) + +! 2.4 pervious ground albedo with snow + IF (scv_gper > 0.) THEN + + ! correction for snow age + age = 1.-1./(1.+sag_gper) !correction for snow age + dfalbs = snal0*(1.-cons*age) + + ! czf corrects albedo of new snow for solar zenith + cff = ((1.+1./sl)/(1.+czen*2.*sl )- 1./sl) + cff = max(cff,0.) + czf = 0.4*cff*(1.-dfalbs) + dralbs = dfalbs+czf + dfalbl = snal1*(1.-conn*age) + czf = 0.4*cff*(1.-dfalbl) + dralbl = dfalbl+czf + + albsno(1,1) = dralbs + albsno(2,1) = dralbl + albsno(1,2) = dfalbs + albsno(2,2) = dfalbl + + ENDIF + + albgper(:,:) = (1.-fsno_gper)*alb_gper(:,:) + fsno_gper*albsno(:,:) + +! ---------------------------------------------------------------------- +! 3. Urban albedo +! ---------------------------------------------------------------------- + + theta = acos(czen) + + ! Distinguish between no-vegetation and vegetation-included cases + IF (lai+sai>1.e-6 .and. fveg>0.) THEN + + CALL UrbanVegShortwave ( & + theta, hlr, froof, fgper, hroof, & + albroof(1,1), alb_wall(1,1), albgimp(1,1), albgper(1,1), & + lai, sai, fveg, hveg, erho(1), etau(1), & + fwsun_, sroof(1,:), swsun(1,:), swsha(1,:), sgimp(1,:), & + sgper(1,:), ssun(1,:), alb(1,:)) + + CALL UrbanVegShortwave ( & + theta, hlr, froof, fgper, hroof, & + albroof(2,1), alb_wall(2,1), albgimp(2,1), albgper(2,1), & + lai, sai, fveg, hveg, erho(2), etau(2), & + fwsun_, sroof(2,:), swsun(2,:), swsha(2,:), sgimp(2,:), & + sgper(2,:), ssun(2,:), alb(2,:)) + ELSE + + CALL UrbanOnlyShortwave ( & + theta, hlr, froof, fgper, hroof, & + albroof(1,1), alb_wall(1,1), albgimp(1,1), albgper(1,1), & + fwsun_, sroof(1,:), swsun(1,:), swsha(1,:), sgimp(1,:), & + sgper(1,:), alb(1,:)) + + CALL UrbanOnlyShortwave ( & + theta, hlr, froof, fgper, hroof, & + albroof(2,1), alb_wall(2,1), albgimp(2,1), albgper(2,1), & + fwsun_, sroof(2,:), swsun(2,:), swsha(2,:), sgimp(2,:), & + sgper(2,:), alb(2,:)) + + ssun(:,:) = 0. + ENDIF + + dfwsun = fwsun_ - fwsun + + alb(:,:) = (1.-flake)*alb(:,:) + flake*alblake(:,:) + + END SUBROUTINE alburban + +END MODULE MOD_Urban_Albedo +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_BEM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_BEM.F90 new file mode 100644 index 0000000000..7b817c1bfa --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_BEM.F90 @@ -0,0 +1,256 @@ +#include + +MODULE MOD_Urban_BEM + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_Urban_Shortwave, only: MatrixInverse + + IMPLICIT NONE + SAVE + PRIVATE + + ! A simple building energy model to calculate room temperature + PUBLIC :: SimpleBEM + +CONTAINS + +!----------------------------------------------------------------------- + SUBROUTINE SimpleBEM (deltim, rhoair, fcover, H, troom_max, troom_min, & + troof_nl_bef, twsun_nl_bef, twsha_nl_bef, & + troof_nl, twsun_nl, twsha_nl, & + tkdz_roof, tkdz_wsun, tkdz_wsha, taf, & + troom, troof_inner, twsun_inner, twsha_inner, & + Fhac, Fwst, Fach, Fhah) + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! A simple building energy model to calculate room temperature +! +! The basic approach is as follows: +! +! 1. Predict indoor temperature using the indoor energy balance +! equations (see below) without turning on the air conditioning. +! +! 2. If the indoor temperature falls within the predefined comfort +! range, further energy consumption calculations are not necessary, +! only indoor and outdoor heat exchange is considered. +! +! 3. If the indoor temperature falls outside the predefined comfort +! range, calculate the minimum/maximum heating/cooling capacity +! based on the air conditioning usage strategy. +! +! 4. Calculate the indoor and outdoor heat exchange and waste heat +! discharge (taking into account energy utilization efficiency) +! based on the calculated heating/cooling capacity in step 3. +! +! Finally, energy consumption can be calculated based on the total +! heat flux. +! +! o Solve the following energy balance equations +! o Variables: troom, troof_inner, twsun_inner, twsha_innter +! +! Hc_roof = Fn_roof .................................(1) +! Hc_wsun = Fn_wsun .................................(2) +! Hc_wsha = Fn_wsha .................................(3) +! +! Troom' - Troom +! H*rhoair*cpair*-------------- = +! dt +! ACH +! ------*H*rhoair*cpair*(Taf-Troom') + Hc_roof + Hc_wsun + Hc_wsha +! 3600 +! .................................(4) +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +! 11/2022, Hua Yuan: Add option for constant AC. +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + deltim, &! seconds in a time step [second] + rhoair, &! density air [kg/m3] + fcover(0:2), &! fractional cover of roof, wall + H, &! average building height [m] + troom_max, &! maximum temperature of inner building + troom_min, &! minimum temperature of inner building + troof_nl_bef, &! roof temperature at layer nl_roof + twsun_nl_bef, &! sunlit wall temperature at layer nl_wall + twsha_nl_bef, &! shaded wall temperature at layer nl_wall + troof_nl, &! roof temperature at layer nl_roof + twsun_nl, &! sunlit wall temperature at layer nl_wall + twsha_nl, &! shaded wall temperature at layer nl_wall + tkdz_roof, &! temporal var for heat transfer of roof + tkdz_wsun, &! temporal var for heat transfer of sunlit wall + tkdz_wsha, &! temporal var for heat transfer of shaded wall + taf ! temperature of urban air + + real(r8), intent(inout) :: & + troom, &! temperature of inner building + troof_inner, &! temperature of inner roof + twsun_inner, &! temperature of inner sunlit wall + twsha_inner ! temperature of inner shaded wall + + real(r8), intent(out) :: & + Fhah, &! flux from heating + Fhac, &! flux from heat or cool AC + Fwst, &! waste heat from cool or heat + Fach ! flux from air exchange + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + ACH, &! air exchange coefficient + hcv_roof, &! convective exchange coefficient for roof<->room + hcv_wall, &! convective exchange coefficient for wall<->room + waste_coef, &! waste coefficient + waste_cool, &! waste heat for AC cooling + waste_heat ! waste heat for AC heating + + real(r8) :: & + f_wsun, &! weight factor for sunlit wall + f_wsha ! weight factor for shaded wall + + real(r8) :: & + A(4,4), &! Heat transfer matrix + Ainv(4,4), &! Inverse of Heat transfer matrix + B(4), &! B for Ax=B + X(4) ! x for Ax=B + + real(r8) :: & + troom_pro, &! projected room temperature + troom_bef, &! temperature of inner building + troof_inner_bef, &! temperature of inner roof + twsun_inner_bef, &! temperature of inner sunlit wall + twsha_inner_bef ! temperature of inner shaded wall + + logical :: cooling, heating + + ! Option for continuous AC + logical, parameter :: Constant_AC = .true. + +!----------------------------------------------------------------------- + + ACH = 0.3 !air exchange coefficient + hcv_roof = 4.040 !convective exchange coefficient for roof<->room (W m-2 K-1) + hcv_wall = 3.076 !convective exchange coefficient for wall<->room (W m-2 K-1) + waste_cool = 0.6 !waste heat for AC cooling + waste_heat = 0.2 !waste heat for AC heating + cooling = .false. !cooling case + heating = .false. !heating case + + f_wsun = fcover(1)/fcover(0) !weight factor for sunlit wall + f_wsha = fcover(2)/fcover(0) !weight factor for shaded wall + + ! initialization + Fhac = 0.; Fwst = 0.; Fach = 0.; Fhah = 0.; + + ! Ax = B + ! set values for heat transfer matrix + ! 1: roof, 2: sunlit wall, 3: shaded wall, 4: room + A(:,:) = 0. + A(1,:) = (/0.5*hcv_roof+0.5*tkdz_roof, 0., 0., -0.5*hcv_roof/) + A(2,:) = (/0., 0.5*hcv_wall+0.5*tkdz_wsun, 0., -0.5*hcv_wall/) + A(3,:) = (/0., 0., 0.5*hcv_wall+0.5*tkdz_wsha, -0.5*hcv_wall/) + + A(4,:) = (/-0.5*hcv_roof, -0.5*hcv_wall*f_wsun, -0.5*hcv_wall*f_wsha, & + 0.5*hcv_roof + 0.5*hcv_wall*f_wsun + 0.5*hcv_wall*f_wsha +& + H*rhoair*cpair/deltim + (ACH/3600.)*H*rhoair*cpair /) + + B(1) = -0.5*hcv_roof*(troof_inner-troom) + 0.5*tkdz_roof*(troof_nl_bef-troof_inner) & + + 0.5*tkdz_roof*troof_nl + B(2) = -0.5*hcv_wall*(twsun_inner-troom) + 0.5*tkdz_wsun*(twsun_nl_bef-twsun_inner) & + + 0.5*tkdz_wsun*twsun_nl + B(3) = -0.5*hcv_wall*(twsha_inner-troom) + 0.5*tkdz_wsha*(twsha_nl_bef-twsha_inner) & + + 0.5*tkdz_wsha*twsha_nl + + B(4) = H*rhoair*cpair*troom/deltim + (ACH/3600.)*H*rhoair*cpair*taf & + + 0.5*hcv_roof*(troof_inner-troom) & + + 0.5*hcv_wall*(twsun_inner-troom)*f_wsun & + + 0.5*hcv_wall*(twsha_inner-troom)*f_wsha + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Matrix computing to resolve multiple reflections + X = matmul(Ainv, B) + + troof_inner_bef = troof_inner + twsun_inner_bef = twsun_inner + twsha_inner_bef = twsha_inner + troom_bef = troom + + troof_inner = X(1) + twsun_inner = X(2) + twsha_inner = X(3) + troom = X(4) + troom_pro = X(4) + + Fach = (ACH/3600.)*H*rhoair*cpair*(troom - taf) + + IF (troom > troom_max) THEN !cooling case + Fhac = H*rhoair*cpair*(troom-troom_max)/deltim + troom = troom_max + Fwst = Fhac*waste_cool + ENDIF + + IF (troom < troom_min) THEN !heating case + Fhac = H*rhoair*cpair*(troom-troom_min)/deltim + troom = troom_min + Fwst = abs(Fhac)*waste_heat + ! negative value, set it to 0. + Fhac = 0. + ENDIF + + ! for constant cooling or heating + IF ((troom_pro>troom_max .or. troom_pro troom_max) THEN !cooling case + troom = troom_max + waste_coef = waste_cool + cooling = .true. + ENDIF + + IF (troom_pro < troom_min) THEN !heating case + troom = troom_min + waste_coef = waste_heat + heating = .true. + ENDIF + + Fach = (ACH/3600.)*H*rhoair*cpair*(troom - taf) + + troof_inner = (B(1)-A(1,4)*troom)/A(1,1) + twsun_inner = (B(2)-A(2,4)*troom)/A(2,2) + twsha_inner = (B(3)-A(3,4)*troom)/A(3,3) + + Fhac = 0.5*hcv_roof*(troof_inner_bef-troom_bef) & + + 0.5*hcv_roof*(troof_inner-troom) + Fhac = 0.5*hcv_wall*(twsun_inner_bef-troom_bef)*f_wsun & + + 0.5*hcv_wall*(twsun_inner-troom)*f_wsun + Fhac + Fhac = 0.5*hcv_wall*(twsha_inner_bef-troom_bef)*f_wsha & + + 0.5*hcv_wall*(twsha_inner-troom)*f_wsha + Fhac + + IF ( heating ) Fhah = abs(Fhac) + Fhac = abs(Fhac) + abs(Fach) + Fwst = Fhac*waste_coef + IF ( heating ) Fhac = 0. + + ENDIF + + Fhah = Fhah*fcover(0) + Fach = Fach*fcover(0) + Fwst = Fwst*fcover(0) + Fhac = Fhac*fcover(0) + + END SUBROUTINE SimpleBEM + +END MODULE MOD_Urban_BEM +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Const_LCZ.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Const_LCZ.F90 new file mode 100644 index 0000000000..0504664be4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Const_LCZ.F90 @@ -0,0 +1,125 @@ +#include +MODULE MOD_Urban_Const_LCZ + +! ----------------------------------------------------------------------- +! !DESCRIPTION: +! look-up-table for LCZ morphology and thermal parameters +! - NOTE - +! Each city may have different values for the parameters in this table. +! The default values may not suit any specific city. +! Users could adjust these values based on the city they are working with. +! +! Created by Wenzong Dong, Jun, 2022 +! +! !REFERENCES: +! 1) Stewart, I. D., Oke, T. R., & Krayenhoff, E. S. (2014). Evaluation of +! the 'local climate zone' scheme using temperature observations and model +! simulations. International Journal of Climatology, 34(4), 1062-1080. +! https://doi.org/10.1002/joc.3746 +! +! 2) The URBPARM_LCZ.TBL of WRF, https://github.com/wrf-model/WRF/ +! +! ----------------------------------------------------------------------- +! !USE + USE MOD_Precision + + IMPLICIT NONE + SAVE + + ! roof fraction [-] + real(r8), parameter, dimension(10) :: wtroof_lcz & + = (/0.5 , 0.5 , 0.55, 0.3 , 0.3, 0.3, 0.8 , 0.4 , 0.15, 0.25/) + + ! pervious fraction [-] + real(r8), parameter, dimension(10) :: fgper_lcz & + = (/0.05, 0.1 , 0.15, 0.35, 0.3, 0.4, 0.15, 0.15, 0.7 , 0.45/) + + ! height of roof [m] + real(r8), parameter, dimension(10) :: htroof_lcz & + = (/45., 15. , 5. , 40., 15., 5. , 3. , 7. , 5. , 8.5 /) + + ! H/W [-] + real(r8), parameter, dimension(10) :: hwrbld_lcz & + = (/2.5, 1.25, 1.25, 1. , 0.5, 0.5, 1.5, 0.2, 0.15, 0.35/) + + ! thickness of roof [m] + real(r8), parameter, dimension(10) :: thkroof_lcz & + = (/0.3 , 0.3 , 0.2 , 0.3 , 0.25, 0.15, 0.05, 0.12, 0.15, 0.05/) + + ! thickness of wall [m] + real(r8), parameter, dimension(10) :: thkwall_lcz & + = (/0.3 , 0.25, 0.2 , 0.2 , 0.2 , 0.2 , 0.1 , 0.2 , 0.2 , 0.05/) + + ! thickness of impervious road [m] + real(r8), parameter, dimension(10) :: thkgimp_lcz & + = (/0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25/) + + ! albedo of roof [-] + real(r8), parameter, dimension(10) :: albroof_lcz & + = (/0.13, 0.18, 0.15, 0.13, 0.13, 0.13, 0.15, 0.18, 0.13, 0.1 /) + + ! albedo of wall [-] + real(r8), parameter, dimension(10) :: albwall_lcz & + = (/0.25, 0.2 , 0.2 , 0.25, 0.25, 0.25, 0.2 , 0.25, 0.25, 0.2 /) + + ! albedo of impervious road [-] + real(r8), parameter, dimension(10) :: albgimp_lcz & + = (/0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.18, 0.14, 0.14, 0.14/) + + ! albedo of pervious road [-] + real(r8), parameter, dimension(10) :: albgper_lcz & + = (/0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15/) + + ! emissivity of roof [-] + real(r8), parameter, dimension(10) :: emroof_lcz & + = (/0.91, 0.91, 0.91, 0.91, 0.91, 0.91, 0.28, 0.91, 0.91, 0.91/) + + ! emissivity of wall [-] + real(r8), parameter, dimension(10) :: emwall_lcz & + = (/0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90/) + + ! emissivity of road [-] + real(r8), parameter, dimension(10) :: emgimp_lcz & + = (/0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.92, 0.95, 0.95, 0.95/) + + ! emissivity of impervious road [-] + real(r8), parameter, dimension(10) :: emgper_lcz & + = (/0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95/) + + + ! volumetric heat capacity of roof [J/m3*K] + real(r8), parameter, dimension(10) :: cvroof_lcz & + = (/1.8E6 , 1.8E6 , 1.44E6, 1.8E6 , 1.8E6 , 1.44E6, 2.0E6 , 1.8E6 , 1.44E6, 2.0E6 /) + + ! volumetric heat capacity of wall [J/m3*K] + real(r8), parameter, dimension(10) :: cvwall_lcz & + = (/1.8E6 , 2.67E6, 2.05E6, 2.0E6 , 2.0E6 , 2.05E6, 0.72E6, 1.8E6 , 2.56E6, 1.69E6/) + + ! volumetric heat capacity of impervious road [J/m3*K] + real(r8), parameter, dimension(10) :: cvgimp_lcz & + = (/1.75E6, 1.68E6, 1.63E6, 1.54E6, 1.50E6, 1.47E6, 1.67E6, 1.38E6, 1.37E6, 1.49E6/) + + + ! thermal conductivity of roof [W/m*K] + real(r8), parameter, dimension(10) :: tkroof_lcz & + = (/1.25, 1.25, 1.00, 1.25, 1.25, 1.00, 2.0 , 1.25, 1.00, 2.00/) + + ! thermal conductivity of wall [W/m*K] + real(r8), parameter, dimension(10) :: tkwall_lcz & + = (/1.09, 1.5 , 1.25, 1.45, 1.45, 1.25, 0.5 , 1.25, 1.00, 1.33/) + + ! thermal conductivity of impervious road [W/m*K] + real(r8), parameter, dimension(10) :: tkgimp_lcz & + = (/0.77, 0.73, 0.69, 0.64, 0.62, 0.60, 0.72, 0.51, 0.55, 0.61/) + + !TODO:AHE coding + ! maximum temperature of inner room [K] + real(r8), parameter, dimension(10) :: tbldmax_lcz & + = (/297.65, 297.65, 297.65, 297.65, 297.65, 297.65, 297.65, 297.65, 297.65, 297.65/) + + ! minimum temperature of inner room [K] + real(r8), parameter, dimension(10) :: tbldmin_lcz & + = (/290.65, 290.65, 290.65, 290.65, 290.65, 290.65, 290.65, 290.65, 290.65, 290.65/) + +END MODULE MOD_Urban_Const_LCZ +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 new file mode 100644 index 0000000000..d9e6503427 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Flux.F90 @@ -0,0 +1,2644 @@ +#include + +MODULE MOD_Urban_Flux + +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The process of urban turbulence exchange is similar to the plant +! community (3D canopy) turbulence exchange. The sensible and latent +! heat exchange of roofs, walls (shaded and sunny sides), ground, and +! vegetation is calculated based on the M-O similarity theory +! similarity. However, the differences lie in the roughness, frontal +! area index, zero-plane displacement height, wind speed/turbulence +! exchange coefficient decay rate, and calculation of boundary layer +! resistance for building surfaces and vegetation. Each layer +! (equivalent height) conservation equation for flux is established and +! solved simultaneously. +! +! The process of solving includes two situations: +! +! 1. not considering vegetation - Subroutine UrbanOnlyFlux() +! +! 2. considering vegetation - Subroutine UrbanVegFlux() +! +! Created by Hua Yuan, 09/2021 +! +! +! !REVISIONS: +! +! 10/2022, Hua Yuan: Add three options of decay coefficient for u and k. +! Add wet fraction for roof and impervious ground, set max +! ponding for roof and impervious from 10mm -> 1mm. +! +! 12/2022, Wenzong Dong: Traffic and metabolism heat flux are considered +! in turbulent flux exchange. +! +! 05/2024, Wenzong Dong: re-write the two- and three-layer flux exchange +! code in resistance style and make it consistant with the +! technical report. [better for incorporating rss and further +! developments] +! +! 05/2024, Hua Yuan: add option to account for vegetation snow process. +! +!----------------------------------------------------------------------- + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Namelist, only: DEF_RSS_SCHEME, DEF_VEG_SNOW + USE MOD_Vars_Global + USE MOD_Qsadv, only: qsadv + IMPLICIT NONE + SAVE + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: UrbanOnlyFlux + PUBLIC :: UrbanVegFlux + PUBLIC :: dewfraction + + ! Exponential extinction factor (alpha) options: + ! 1. Masson, 2000; Oleson et al., 2008 + ! 2. Swaid, 1993; Kusaka, 2001; Lee and Park, 2008 + ! 3. Macdonald, 2000 + integer, parameter :: alpha_opt = 3 + + ! Layer number setting, default is false, i.e., 2 layers + logical, parameter :: run_three_layer = .false. + + ! Percent of sensible/latent to AHE (only for Fhac, Fwst, vehc now), + ! 92% heat release as SH, 8% heat release as LH, Pigeon et al., 2007 + real(r8), parameter :: fsh = 0.92 + real(r8), parameter :: flh = 0.08 + + ! A simple urban irrigation scheme accounts for soil water stress of trees + logical, parameter :: DEF_URBAN_Irrigation = .true. + real(r8), parameter :: rstfac_irrig = 1. + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE UrbanOnlyFlux ( & + ! Model running information + ipatch ,deltim ,lbr ,lbi ,& + ! Forcing + hu ,ht ,hq ,us ,& + vs ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,Fhac ,& + Fwst ,Fach ,vehc ,meta ,& + ! Urban parameters + hroof ,hlr ,nurb ,fcover ,& + ! Status of surface + z0h_g ,obug ,ustarg ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno ,wliq_gimpsno ,wice_roofsno ,wice_gimpsno ,& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,rss ,& + ! Output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwsuns ,& + cwshas ,cgrnds ,croofl ,cgimpl ,& + cgperl ,croof ,cgimp ,cgper ,& + tref ,qref ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,tafu ) + +!======================================================================= + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav,hvap + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_Vars_1DForcing, only: forc_height_mode + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch, &! patch index [-] + lbr, &! lower bound of array + lbi ! lower bound of array + + real(r8), intent(in) :: & + deltim ! seconds in a time step [second] + + ! atmospherical variables and observational height + real(r8), intent(in) :: & + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + thm, &! intermediate variable (tm+0.0098*ht) [K] + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + qm, &! specific humidity at agcm reference height [kg/kg] + psrf, &! atmosphere pressure at the surface [pa] [not used] + rhoair ! density air [kg/m3] + + real(r8), intent(in) :: & + vehc, &! flux from vehicle [W/m2] + meta, &! flux from metabolic [W/m2] + Fhac, &! flux from heat or cool AC [W/m2] + Fwst, &! waste heat from cool or heat [W/m2] + Fach ! flux from air exchange [W/m2] + + integer, intent(in) :: & + nurb ! number of aboveground urban components [-] + + real(r8), intent(in) :: & + hroof, &! average building height [m] + hlr, &! average building height to their side length [-] + fcover(0:4) ! coverage of aboveground urban components [-] + + real(r8), intent(in) :: & + rss, &! bare soil resistance for evaporation [s/m] + z0h_g, &! roughness length for bare ground, sensible heat [m] + obug, &! monin-obukhov length for bare ground (m) + ustarg, &! friction velocity for bare ground [m/s] + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno_roof, &! fraction of ground covered by snow [-] + fsno_gimp, &! fraction of ground covered by snow [-] + fsno_gper, &! fraction of ground covered by snow [-] + wliq_roofsno, &! liqui water [kg/m2] + wliq_gimpsno, &! liqui water [kg/m2] + wice_roofsno, &! ice lens [kg/m2] + wice_gimpsno, &! ice lens [kg/m2] + htvp_roof, &! latent heat of vapor of water (or sublimation) [j/kg] + htvp_gimp, &! latent heat of vapor of water (or sublimation) [j/kg] + htvp_gper, &! latent heat of vapor of water (or sublimation) [j/kg] + + troof, &! temperature of roof [K] + twsun, &! temperature of sunlit wall [K] + twsha, &! temperature of shaded wall [K] + tgimp, &! temperature of impervious road [K] + tgper, &! pervious ground temperature [K] + + qroof, &! roof specific humidity [kg/kg] + qgimp, &! imperivous road specific humidity [kg/kg] + qgper, &! pervious ground specific humidity [kg/kg] + dqroofdT, &! d(qroof)/dT + dqgimpdT, &! d(qgimp)/dT + dqgperdT ! d(qgper)/dT + + ! Output + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsenroof, &! sensible heat flux from roof [W/m2] + fsenwsun, &! sensible heat flux from sunlit wall [W/m2] + fsenwsha, &! sensible heat flux from shaded wall [W/m2] + fsengimp, &! sensible heat flux from impervious road [W/m2] + fsengper, &! sensible heat flux from pervious ground [W/m2] + fevproof, &! evaporation heat flux from roof [W/m2] + fevpgimp, &! evaporation heat flux from impervious road [W/m2] + fevpgper, &! evaporation heat flux from pervious ground [mm/s] + + croofs, &! deriv of roof sensible heat flux wrt soil temp [w/m**2/k] + cwsuns, &! deriv of sunlit wall sensible heat flux wrt soil temp [w/m**2/k] + cwshas, &! deriv of shaded wall sensible heat flux wrt soil temp [w/m**2/k] + cgrnds, &! deriv of soil sensible heat flux wrt soil temp [w/m**2/k] + croofl, &! deriv of roof latent heat flux wrt soil temp [w/m**2/k] + cgimpl, &! deriv of gimp latent heat flux wrt soil temp [w/m**2/k] + cgperl, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + croof, &! deriv of roof total heat flux wrt soil temp [w/m**2/k] + cgimp, &! deriv of gimp total heat flux wrt soil temp [w/m**2/k] + cgper, &! deriv of soil total heat flux wrt soil temp [w/m**2/k] + + tref, &! 2 m height air temperature [kelvin] + qref, &! 2 m height air humidity [kg/kg] + + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq, &! integral of profile function for moisture + tafu ! effective urban air temperature (2nd layer, walls) + +!-------------------------- Local Variables ---------------------------- + integer :: & + niters, &! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + ur, &! wind speed at reference height [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0hg, &! roughness length over ground, sensible heat [m] + z0qg ! roughness length over ground, latent heat [m] + + real(r8) evplwet, evplwet_dtl, elwmax, elwdif + +!----------------------- definition for 3d run ------------------------- + + integer, parameter :: nlay = 3 ! potential layer number + + integer :: & + clev, &! current layer index + numlay ! available layer number + + real(r8) :: & + hu_, &! adjusted observational height of wind [m] + ht_, &! adjusted observational height of temperature [m] + hq_, &! adjusted observational height of humidity [m] + ktop, &! K value at a specific height + utop, &! u value at a specific height + fht, &! integral of profile function for heat at the top layer + fqt, &! integral of profile function for moisture at the top layer + fmtop, &! fm value at a specific height + phih, &! phi(h), similarity function for sensible heat + displa, &! displacement height for urban + displau, &! displacement height for urban building + z0mu, &! roughness length for urban building only + z0h, &! roughness length for sensible heat + z0q, &! roughness length for latent heat + tg, &! ground temperature + qg ! ground specific humidity + + real(r8) :: & + fg, &! ground fractional cover + fgimp, &! weight of impervious ground + fgper, &! weight of pervious ground + hwr, &! average building height to their distance [-] + sqrtdragc, &! sqrt(drag coefficient) + lm, &! mix length within canopy + fai, &! frontal area index + fwet, &! fractional wet area + delta, &! 0 or 1 + alpha ! exponential extinction factor for u/k decline within urban + + real(r8), dimension(0:nurb) :: & + tu, &! temperature array + fc, &! fractional cover array + canlev, &! urban canopy layer lookup table + rb, &! leaf boundary layer resistance [s/m] + cfh, &! heat conductance for leaf [m/s] + cfw, &! latent heat conductance for leaf [m/s] + wtl0, &! normalized heat conductance for air and leaf [-] + wtlq0, &! normalized latent heat cond. for air and leaf [-] + + ei, &! vapor pressure on leaf surface [pa] + deidT, &! derivative of "ei" on "tl" [pa/K] + qsatl, &! leaf specific humidity [kg/kg] + qsatldT ! derivative of "qsatl" on "tlef" + + real(r8), dimension(nlay) :: & + fah, &! weight for thermal resistance to upper layer + faw, &! weight for moisture resistance to upper layer + fgh, &! weight for thermal resistance to lower layer + fgw, &! weight for moisture resistance to lower layer + ueff_lay, &! effective wind speed within canopy layer [m/s] + ueff_lay_, &! effective wind speed within canopy layer [m/s] + taf, &! air temperature within canopy space [K] + qaf, &! humidity of canopy air [kg/kg] + rd, &! aerodynamic resistance between layers [s/m] + rd_, &! aerodynamic resistance between layers [s/m] + cah, &! heat conductance for air [m/s] + cgh, &! heat conductance for ground [m/s] + caw, &! latent heat conductance for air [m/s] + cgw, &! latent heat conductance for ground [m/s] + wtshi, &! sensible heat resistance for air, grd and leaf [-] + wtsqi, &! latent heat resistance for air, grd and leaf [-] + wta0, &! normalized heat conductance for air [-] + wtg0, &! normalized heat conductance for ground [-] + wtaq0, &! normalized latent heat conductance for air [-] + wtgq0, &! normalized heat conductance for ground [-] + wtll, &! sum of normalized heat conductance for air and leaf + wtlql ! sum of normalized heat conductance for air and leaf + + real(r8), dimension(nlay) :: & + Hahe ! anthropogenic heat emission (AHE) + + real(r8) :: & + ra2m, &! aerodynamic resistance between 2m and bottom layer [s/m] + rd2m ! aerodynamic resistance between bottom layer and ground [s/m] + + ! temporal + integer i + real(r8) tmpw3, cgw_per, cgw_imp + real(r8) bee, tmpw1, tmpw2, fact, facq + real(r8) aT, bT, cT + real(r8) aQ, bQ, cQ, Lahe + real(r8) fwet_roof, fwet_roof_, fwet_gimp, fwet_gimp_, rss_ + real(r8) fwetfac + +!----------------------------------------------------------------------- + +! initialization + tu(0) = troof; tu(1) = twsun; tu(2) = twsha + + fc(:) = fcover(0:nurb) + fg = 1 - fcover(0) + fgimp = fcover(3)/fg + fgper = fcover(4)/fg + !hlr = hwr*(1-sqrt(fcover(0)))/sqrt(fcover(0)) + hwr = hlr*sqrt(fcover(0))/(1-sqrt(fcover(0))) + canlev = (/3, 2, 2/) + numlay = 2 + +!----------------------------------------------------------------------- +! initial roughness length for z0mg, z0hg, z0qg +! Roughness of the city ground only (excluding buildings and vegetation) +!----------------------------------------------------------------------- + + !NOTE: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_gper > 0) THEN + z0mg = zsno + ELSE + z0mg = zlnd + ENDIF + z0hg = z0mg + z0qg = z0mg + +!----------------------------------------------------------------------- +! initial saturated vapor pressure and humidity and their derivation +! 0: roof, 1: sunlit wall, 2: shaded wall +!----------------------------------------------------------------------- + + qsatl(0) = qroof + qsatldT(0) = dqroofdT + DO i = 1, nurb + CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) + ENDDO + +!----------------------------------------------------------------------- +! tg, qg and wet fraction calculation +!----------------------------------------------------------------------- + + ! weighted tg + tg = tgimp*fgimp + tgper*fgper + + ! wet fraction for roof and impervious ground + !------------------------------------------- + ! roof + IF (lbr < 1) THEN + fwet_roof_ = fsno_roof !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_roof_ = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) + fwet_roof_ = min(1., fwet_roof_) + ENDIF + + ! impervious ground + IF (lbi < 1) THEN + fwet_gimp_ = fsno_gimp !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_gimp_ = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) + fwet_gimp_ = min(1., fwet_gimp_) + ENDIF + + ! dew case + IF (qm > qroof) THEN + fwet_roof = 1. + ELSE + fwet_roof = fwet_roof_ + ENDIF + + ! dew case + IF (qm > qgimp) THEN + fwet_gimp = 1. + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as pervious ground + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + +!----------------------------------------------------------------------- +! initial for fluxes profile +!----------------------------------------------------------------------- + + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) + +!----------------------------------------------------------------------- +! scaling factor bee +!----------------------------------------------------------------------- +!NOTE: bee value, the default is 1 + bee = 1. + +!----------------------------------------------------------------------- +! calculate z0m and displa +!----------------------------------------------------------------------- + + ! Macdonald et al., 1998, Eq. (23), A=4.43 + displau = hroof * (1 + 4.43**(-fcover(0))*(fcover(0) - 1)) + fai = 4/PI*hlr*fcover(0) + z0mu = (hroof - displau) * & + exp( -(0.5*1.2/vonkar/vonkar*(1-displau/hroof)*fai)**(-0.5) ) + + ! to compare z0 of urban and only the surface + ! maximum assumption + IF (z0mu < z0mg) z0mu = z0mg + + ! roughness length and displacement height for sensible + ! and latent heat transfer + z0m = z0mu + + displa = displau + displau = max(hroof/2., displau) + +!----------------------------------------------------------------------- +! calculate layer decay coefficient +!----------------------------------------------------------------------- + + !NOTE: the below is for vegetation, may not be suitable for urban + ! Raupach, 1992 + !sqrtdragc = min( (0.003+0.3*fai)**0.5, 0.3 ) + + ! Kondo, 1971 + !alpha = hroof/(hroof-displa)/(vonkar/sqrtdragc) + + ! Masson, 2000; Oleson et al., 2008 + IF (alpha_opt == 1) alpha = 0.5*hwr + + ! Swaid, 1993; Kusaka, 2001; Lee and Park, 2008 + IF (alpha_opt == 2) alpha = 0.772*hwr + + ! Macdonald, 2000 + IF (alpha_opt == 3) alpha = 9.6*fai + +!----------------------------------------------------------------------- +! first guess for taf and qaf for each layer +! a large difference from previous schemes +!----------------------------------------------------------------------- + + IF (numlay .eq. 2) THEN + taf(3) = (tg + 2.*thm)/3. + qaf(3) = (qg + 2.*qm )/3. + taf(2) = (2.*tg + thm)/3. + qaf(2) = (2.*qg + qm )/3. + ENDIF + +! initialization and input values for Monin-Obukhov + ! have been set before + z0h = z0m; z0q = z0m + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(2) + dqh = qm - qaf(2) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + + hu_ = hu; ht_ = ht; hq_ = hq; + + IF (forc_height_mode == 'absolute') THEN + + IF (hu <= hroof+1) THEN + hu_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of u less than hroof+1, set it to hroof+1.' + ENDIF + + IF (ht <= hroof+1) THEN + ht_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of t less than hroof+1, set it to hroof+1.' + ENDIF + + IF (hq <= hroof+1) THEN + hq_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of q less than hroof+1, set it to hroof+1.' + ENDIF + + ELSE ! relative height + hu_ = hroof + hu + ht_ = hroof + ht + hq_ = hroof + hq + ENDIF + + zldis = hu_ - displa + + IF (zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL CoLM_stop('UrbanOnlyFlux received a reference height below displacement height.') + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) + + niters=6 + +! ====================================================================== +! BEGIN stability iteration +! ====================================================================== + + ITERATION : DO iter = 1, niters !begin stability iteration + +!----------------------------------------------------------------------- +! Aerodynamical resistances +!----------------------------------------------------------------------- +! Evaluate stability-dependent variables using moz from prior iteration + + !NOTE: displat=hroof, z0mt=0, are set for roof + ! fmtop is calculated at the same height of fht, fqt + CALL moninobukm(hu_,ht_,hq_,displa,z0m,z0h,z0q,obu,um, & + hroof,0.,ustar,fh2m,fq2m,hroof,fmtop,fm,fh,fq,fht,fqt,phih) + +! Aerodynamic resistance + ! 09/16/2017: + ! NOTE that for ram, it is the resistance from Href to z0mv+displa + ! however, for rah and raw is only from Href to canopy effective + ! exchange height. + ! For Urban: from Href to roof height + ! so rah/raw is not comparable with that of 1D case + ram = 1./(ustar*ustar/um) + + ! 05/02/2016: calculate resistance from the top layer (effective exchange + ! height) to reference height + ! For Urban: from roof height to reference height + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + + ! update roughness length for sensible/latent heat + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + z0h = max(z0hg, z0h) + z0q = max(z0qg, z0q) + +!----------------------------------------------------------------------- +! new method to calculate rd and ueffect +! the kernel part of 3d model +!----------------------------------------------------------------------- + + ! initialization + rd(:) = 0. + rd_(:) = 0. + ueff_lay(:) = 0. + ueff_lay_(:) = 0. + + ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) + ! need to update each time as obu changed after each iteration + utop = ustar/vonkar * fmtop + ktop = vonkar * (hroof-displa) * ustar / phih + + ueff_lay(3) = utop + + ! NOTE: another calculation method for double-check + ! real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, displah, & + ! htop, hbot, obu, ustar, ztop, zbot) + ! rd(3) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, hroof, displa+z0m) + + ! real(r8) FUNCTION frd(ktop, htop, hbot, ztop, zbot, displah, z0h, & + ! obu, ustar, z0mg, alpha, bee, fc) + rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) + ! ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + + ! real(r8) FUNCTION ueffectz(utop, htop, hbot, ztop, zbot, z0mg, alpha, bee, fc) + ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + + ! rd(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displau+z0mu, z0qg) + rd(2) = frd(ktop, hroof, 0., displau+z0mu, z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! calculate ra2m, rd2m. NOTE: not used now. + ra2m = frd(ktop, hroof, 0., displau+z0mu, 2., displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! Masson, 2000: Account for different canyon orientations + ! 2/PI is a factor derived from 0-360deg integration + IF (alpha_opt == 1) THEN + ueff_lay(2) = 2/PI*ueff_lay(2) + rd(:) = PI/2*rd(:) + ENDIF + +!----------------------------------------------------------------------- +! Bulk boundary layer resistance of leaves +!----------------------------------------------------------------------- + + rb(:) = 0. + + DO i = 0, nurb + clev = canlev(i) + rb(i) = rhoair * cpair / ( 11.8 + 4.2*ueff_lay(clev) ) + ENDDO + +!----------------------------------------------------------------------- +! Solve taf(:) and qaf(:) +!----------------------------------------------------------------------- + + IF (numlay .eq. 2) THEN + + ! - Equations: + ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) & + ! + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) & + ! + AHE/(rho*cp))/ (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2)) + ! Also written as: + ! taf(3) = (cah(3)*thm + cah(2)*taf(2) & + ! + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) + ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) & + ! + AHE/(rho*cp))/(cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) + 1/rb(0)*qroof*fc(0)) & + ! / (1/raw + 1/rd(3) + 1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rss)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg & + ! + AHE/rho)/(1/rd(3) + 1/(rd(2)+rss)*fgper*fg + fwetimp/rd(2)*fgimp*fg) + ! Also written as: + ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) & + ! + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) + ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg + AHE/rho)/ & + ! (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg) + + ! 06/20/2021, yuan: account for Anthropogenic heat + ! 92% heat release as SH, Pigeon et al., 2007 + + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + vehc*fsh + meta + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + aT = (tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah)*bT + + taf(2) = (tg*fg/rd(2) + Hahe(2)/(rhoair*cpair) & + + tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) + aT) & + / (cT * (1- bT/(cT*rd(3)))) + + taf(3) = (taf(2)/rd(3) + tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah) & + / (1/rah + 1/rd(3) + fc(0)/rb(0)) + + IF (qgper < qaf(2)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = (qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw)*bQ + + qaf(2) = (qgper*fgper*fg/(rd(2)+rss_) + qgimp*fwet_gimp*fgimp*fg/rd(2) & + + aQ + Lahe/rhoair/hvap) / (cQ * (1-bQ/(cQ*rd(3)))) + + qaf(3) = (qaf(2)/rd(3) + qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw) & + / (1/raw + 1/rd(3) + fwet_roof*fc(0)/rb(0)) + + ENDIF + + !------------------------------------------------ + ! update fwet for roof and impervious ground + ! to check whether dew happens + IF (qaf(3) > qroof) THEN + fwet_roof = 1. !dew case + ELSE + fwet_roof = fwet_roof_ + ENDIF + + ! to check whether dew happens + IF (qaf(2) > qgimp) THEN + fwet_gimp = 1. !dew case + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + fgw(2) = fg*fwetfac + +!----------------------------------------------------------------------- +! Update monin-obukhov length and wind speed including the stability effect +!----------------------------------------------------------------------- + + ! USE the top layer taf and qaf + dth = thm - taf(2) + dqh = qm - qaf(2) + + tstar = vonkar/(fh)*dth + qstar = vonkar/(fq)*dqh + + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF (zeta .ge. 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF (zeta .ge. 0.) THEN + um = max(ur,.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + ENDDO ITERATION !end stability iteration + +! ====================================================================== +! END stability iteration +! ====================================================================== + + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + + ! sensible heat fluxes + fsenroof = rhoair*cpair/rb(0)*(troof-taf(3)) + fsenwsun = rhoair*cpair/rb(1)*(twsun-taf(2)) + fsenwsha = rhoair*cpair/rb(2)*(twsha-taf(2)) + + ! latent heat fluxes + fevproof = rhoair/rb(0)*(qsatl(0)-qaf(3)) + fevproof = fevproof*fwet_roof + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + + cwsuns = rhoair*cpair/rb(1) & + * ( 1. - fc(1) / (cT*rb(1)*(1-bT/(cT*rd(3)))) ) + cwshas = rhoair*cpair/rb(2) & + * ( 1. - fc(2) / (cT*rb(2)*(1-bT/(cT*rd(3)))) ) + croofs = rhoair*cpair/rb(0) & + * ( 1. - fc(0)*bT*bT / (cT*rb(0)*(1-bT/(cT*rd(3)))) & + - fc(0) / (rb(0)*(1/rah+1/rd(3)+fc(0)/rb(0))) ) + + croofl = rhoair*fwet_roof/rb(0)*qsatldT(0) & + * ( 1. - fwet_roof*fc(0)*bQ*bQ / (cQ*rb(0)*(1-bQ/(cQ*rd(3)))) & + - fwet_roof*fc(0) / (rb(0)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) ) + + croof = croofs + croofl*htvp_roof + + +#if (defined CoLMDEBUG) +#endif + + tafu = taf(2) + +!----------------------------------------------------------------------- +! wind stresses +!----------------------------------------------------------------------- + + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram + +!----------------------------------------------------------------------- +! fluxes from urban ground to canopy space +!----------------------------------------------------------------------- + + fsengper = cpair*rhoair/rd(2)*(tgper-taf(2)) + fsengimp = cpair*rhoair/rd(2)*(tgimp-taf(2)) + + fevpgper = rhoair/(rd(2)+rss_)*(qgper-qaf(2)) + fevpgimp = rhoair/rd(2) *(qgimp-qaf(2)) + fevpgimp = fevpgimp*fwet_gimp + +!----------------------------------------------------------------------- +! Derivative of soil energy flux with respect to soil temperature (cgrnd) +!----------------------------------------------------------------------- + + cgrnds = cpair*rhoair/rd(2)*( 1. - fg/(cT*rd(2)*(1-bT/(cT*rd(3)))) ) + + cgperl = rhoair/(rd(2)+rss_) & + * dqgperdT*( 1 - fg*fgper/(cQ*(rd(2)+rss_)*(1-bQ/(cQ*rd(3)))) ) + cgimpl = rhoair*fwet_gimp/rd(2)& + * dqgimpdT*( 1 - fwet_gimp*fg*fgimp/(cQ*rd(2)*(1-bQ/(cQ*rd(3)))) ) + + cgimp = cgrnds + cgimpl*htvp_gimp + cgper = cgrnds + cgperl*htvp_gper + +!----------------------------------------------------------------------- +! 2 m height air temperature above apparent sink height +!----------------------------------------------------------------------- + + !tref = thm + vonkar/(fh-fht)*dth * (fh2m/vonkar - fh/vonkar) + !qref = qm + vonkar/(fq-fqt)*dqh * (fq2m/vonkar - fq/vonkar) + + ! assumption: (tg-t2m):(tg-taf) = 2:(displa+z0m) + tref = ( (displau+z0mu-2.)*tg + 2.*taf(2) ) / (displau+z0mu) + qref = ( (displau+z0mu-2.)*qg + 2.*qaf(2) ) / (displau+z0mu) + + END SUBROUTINE UrbanOnlyFlux + + + SUBROUTINE UrbanVegFlux ( & + ! Model running information + ipatch ,deltim ,lbr ,lbi ,& + ! Forcing + hu ,ht ,hq ,us ,& + vs ,thm ,th ,thv ,& + qm ,psrf ,rhoair ,frl ,& + po2m ,pco2m ,par ,sabv ,& + rstfac ,Fhac ,Fwst ,Fach ,& + vehc ,meta ,& + ! Urban and vegetation parameters + hroof ,hlr ,nurb ,fcover ,& + ewall ,egimp ,egper ,ev ,& + htop ,hbot ,lai ,sai ,& + sqrtdi ,effcon ,vmax25 ,c3c4 ,slti,& + hlti ,shti ,hhti ,trda ,& + trdm ,trop ,g1 ,g0 ,& + gradm ,binter ,extkn ,extkd ,& + dewmx ,etrc ,trsmx0 ,lambda_wue ,& + ! Status of surface + z0h_g ,obug ,ustarg ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno ,wliq_gimpsno ,wice_roofsno ,wice_gimpsno ,& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,sigf ,tl ,& + ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + dheatl ,rss ,etr_deficit ,& + ! Longwave information + Ainv ,B ,B1 ,dBdT ,& + SkyVF ,VegVF ,& + ! Output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwsuns ,& + cwshas ,cgrnds ,croofl ,cgimpl ,& + cgperl ,croof ,cgimp ,cgper ,& + fsenl ,fevpl ,etr ,rst ,& + assim ,respc ,lwsun ,lwsha ,& + lgimp ,lgper ,lveg ,lout ,& + tref ,qref ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,tafu ) + +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: vonkar,grav,hvap,cpair,stefnc,cpliq, cpice, & + hfus, tfrz, denice, denh2o + USE MOD_FrictionVelocity + USE MOD_CanopyLayerProfile + USE MOD_AssimStomataConductance + USE MOD_Vars_1DForcing, only: forc_height_mode + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch, &! patch index [-] + lbr, &! lower bound of array + lbi ! lower bound of array + + real(r8), intent(in) :: & + deltim ! seconds in a time step [second] + + ! Forcing + real(r8), intent(in) :: & + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + qm, &! specific humidity at reference height [kg/kg] + psrf, &! pressure at reference height [pa] + rhoair, &! density air [kg/m**3] + + frl, &! atmospheric infrared (longwave) radiation [W/m2] + par, &! par absorbed per unit sunlit lai [w/m**2] + sabv, &! solar radiation absorbed by vegetation [W/m2] + rstfac, &! factor of soil water stress to plant physiological processes + + po2m, &! atmospheric partial pressure o2 (pa) + pco2m, &! atmospheric partial pressure co2 (pa) + + vehc, &! flux from vehicle [W/m2] + meta, &! flux from metabolic [W/m2] + Fhac, &! flux from heat or cool AC [W/m2] + Fwst, &! waste heat from cool or heat [W/m2] + Fach ! flux from air exchange [W/m2] + + ! Urban and vegetation parameters + integer, intent(in) :: & + nurb ! number of aboveground urban components [-] + + real(r8), intent(in) :: & + hroof, &! average building height [m] + hlr, &! average building height to their side length [-] + fcover(0:5) ! coverage of aboveground urban components [-] + + real(r8), intent(in) :: & + ewall, &! emissivity of walls + egimp, &! emissivity of impervious road + egper, &! emissivity of pervious road + ev ! emissivity of vegetation + + real(r8), intent(in) :: & + htop, &! PFT crown top height [m] + hbot, &! PFT crown bottom height [m] + lai, &! adjusted leaf area index for seasonal variation [-] + sai, &! stem area index [-] + sqrtdi, &! inverse sqrt of leaf dimension [m**-0.5] + + effcon, &! quantum efficiency of RuBP regeneration (mol CO2 / mol quanta) + vmax25, &! maximum carboxylation rate at 25 C at canopy top + ! the range : 30.e-6 <-> 100.e-6 (mol co2 m-2 s-1) + shti, &! slope of high temperature inhibition function (s1) + hhti, &! 1/2 point of high temperature inhibition function (s2) + slti, &! slope of low temperature inhibition function (s3) + hlti, &! 1/2 point of low temperature inhibition function (s4) + trda, &! temperature coefficient in gs-a model (s5) + trdm, &! temperature coefficient in gs-a model (s6) + trop, &! temperature coefficient in gs-a model (273+25) + g1, &! conductance-photosynthesis slope parameter for medlyn model + g0, &! conductance-photosynthesis intercept for medlyn model + gradm, &! conductance-photosynthesis slope parameter + binter, &! conductance-photosynthesis intercept + lambda_wue, &! marginal water cost of carbon gain + + extkn, &! coefficient of leaf nitrogen allocation + extkd, &! diffuse and scattered diffuse PAR extinction coefficient + dewmx, &! maximum dew + trsmx0, &! max transpiration for moist soil+100% veg. [mm/s] + etrc ! maximum possible transpiration rate (mm/s) + + integer, intent(in) :: & + c3c4 ! 1: C3, 0: C4 + + ! Status of surface + real(r8), intent(in) :: & + rss, &! bare soil resistance for evaporation [s/m] + z0h_g, &! roughness length for bare ground, sensible heat [m] + obug, &! monin-obukhov length for bare ground (m) + ustarg, &! friction velocity for bare ground [m/s] + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno_roof, &! fraction of ground covered by snow + fsno_gimp, &! fraction of ground covered by snow + fsno_gper, &! fraction of ground covered by snow + wliq_roofsno, &! liqui water [kg/m2] + wliq_gimpsno, &! liqui water [kg/m2] + wice_roofsno, &! ice lens [kg/m2] + wice_gimpsno, &! ice lens [kg/m2] + htvp_roof, &! latent heat of vapor of water (or sublimation) [j/kg] + htvp_gimp, &! latent heat of vapor of water (or sublimation) [j/kg] + htvp_gper, &! latent heat of vapor of water (or sublimation) [j/kg] + + troof, &! temperature of roof [K] + twsun, &! temperature of sunlit wall [K] + twsha, &! temperature of shaded wall [K] + tgimp, &! temperature of impervious road [K] + tgper, &! pervious ground temperature [K] + + qroof, &! roof specific humidity [kg/kg] + qgimp, &! imperivous road specific humidity [kg/kg] + qgper, &! pervious ground specific humidity [kg/kg] + dqroofdT, &! d(qroof)/dT + dqgimpdT, &! d(qgimp)/dT + dqgperdT, &! d(qgper)/dT + sigf ! + + real(r8), intent(inout) :: & + tl, &! leaf temperature [K] + ldew, &! depth of water on foliage [mm] + ldew_rain, &! depth of rain on foliage [mm] + ldew_snow ! depth of snow on foliage [mm] + + real(r8), intent(out) :: & + fwet_snow, &! vegetation snow fractional cover [-] + dheatl ! vegetation heat change [W/m2] + + real(r8), intent(in) :: Ainv(5,5) !Inverse of Radiation transfer matrix + real(r8), intent(in) :: SkyVF (5) !View factor to sky + real(r8), intent(in) :: VegVF (5) !View factor to veg + real(r8), intent(inout) :: B (5) !Vectors of incident radiation on each surface + real(r8), intent(inout) :: B1 (5) !Vectors of incident radiation on each surface + real(r8), intent(inout) :: dBdT (5) !Vectors of incident radiation on each surface + + real(r8), intent(out) :: & + taux, &! wind stress: E-W [kg/m/s**2] + tauy, &! wind stress: N-S [kg/m/s**2] + fsenroof, &! sensible heat flux from roof [W/m2] + fsenwsun, &! sensible heat flux from sunlit wall [W/m2] + fsenwsha, &! sensible heat flux from shaded wall [W/m2] + fsengimp, &! sensible heat flux from impervious road [W/m2] + fsengper, &! sensible heat flux from pervious ground [W/m2] + fevproof, &! evaporation heat flux from roof [mm/s] + fevpgimp, &! evaporation heat flux from impervious road [mm/s] + fevpgper, &! evaporation heat flux from pervious ground [mm/s] + + croofs, &! deriv of roof sensible heat flux wrt soil temp [w/m**2/k] + cwsuns, &! deriv of sunlit wall sensible heat flux wrt soil temp [w/m**2/k] + cwshas, &! deriv of shaded wall sensible heat flux wrt soil temp [w/m**2/k] + cgrnds, &! deriv of ground latent heat flux wrt soil temp [w/m**2/k] + croofl, &! deriv of roof latent heat flux wrt soil temp [w/m**2/k] + cgimpl, &! deriv of impervious latent heat flux wrt soil temp [w/m**2/k] + cgperl, &! deriv of soil latent heat flux wrt soil temp [w/m**2/k] + croof, &! deriv of roof total flux wrt soil temp [w/m**2/k] + cgimp, &! deriv of impervious total heat flux wrt soil temp [w/m**2/k] + cgper, &! deriv of soil total heat flux wrt soil temp [w/m**2/k] + + tref, &! 2 m height air temperature [kelvin] + qref ! 2 m height air humidity + + real(r8), intent(out) :: & + fsenl, &! sensible heat from leaves [W/m2] + fevpl, &! evaporation+transpiration from leaves [mm/s] + etr, &! transpiration rate [mm/s] + rst, &! stomatal resistance + assim, &! rate of assimilation + respc ! rate of respiration + + real(r8), intent(inout) :: & + etr_deficit ! urban irrigation [mm/s] + + real(r8), intent(inout) :: & + lwsun, &! net longwave radiation of sunlit wall [W/m2] + lwsha, &! net longwave radiation of shaded wall [W/m2] + lgimp, &! net longwave radiation of impervious road [W/m2] + lgper, &! net longwave radiation of pervious road [W/m2] + lveg, &! net longwave radiation of vegetation [W/m2] + lout ! out-going longwave radiation [W/m2] + + real(r8), intent(inout) :: & + z0m, &! effective roughness [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + rib, &! bulk Richardson number in surface layer + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq, &! integral of profile function for moisture + tafu ! effective urban air temperature (2nd layer, walls) + +!-----------------------Local Variables--------------------------------- +! assign iteration parameters + integer, parameter :: itmax = 40 !maximum number of iteration + integer, parameter :: itmin = 6 !minimum number of iteration + real(r8),parameter :: delmax = 3.0 !maximum change in leaf temperature [K] + real(r8),parameter :: dtmin = 0.01 !max limit for temperature convergence [K] + real(r8),parameter :: dlemin = 0.1 !max limit for energy flux convergence [w/m2] + + real(r8) dtl(0:itmax+1) !difference of tl between two iterative step + + real(r8) :: & + zldis, &! reference height "minus" zero displacement height [m] + zii, &! convective boundary layer height [m] + z0mv, &! roughness length of vegetation only, momentum [m] + z0mu, &! roughness length of building only, momentum [m] + z0h, &! roughness length, sensible heat [m] + z0q, &! roughness length, latent heat [m] + zeta, &! dimensionless height used in Monin-Obukhov theory + beta, &! coefficient of convective velocity [-] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + dth, &! diff of virtual temp. between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + obu, &! monin-obukhov length (m) + um, &! wind speed including the stability effect [m/s] + ur, &! wind speed at reference height [m/s] + uaf, &! velocity of air within foliage [m/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + eah, &! canopy air vapor pressure (pa) + pco2g, &! co2 pressure (pa) at ground surface (pa) + pco2a, &! canopy air co2 pressure (pa) + + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + clai, &! canopy heat capacity [Jm-2K-1] + del, &! absolute change in leaf temp in current iteration [K] + del2, &! change in leaf temperature in previous iteration [K] + dele, &! change in heat fluxes from leaf [K] + dele2, &! change in heat fluxes from leaf [K] + det, &! maximum leaf temp. change in two consecutive iter [K] + dee, &! maximum leaf temp. change in two consecutive iter [K] + + obuold, &! monin-obukhov length from previous iteration + tlbef, &! leaf temperature from previous iteration [K] + err, &! balance error + + rs, &! sunlit leaf stomatal resistance [s/m] + rsoil, &! soil respiration + gah2o, &! conductance between canopy and atmosphere + gdh2o, &! conductance between canopy and ground + tprcor ! tf*psur*100./1.013e5 + + integer it, nmozsgn + + real(r8) evplwet, evplwet_dtl, etr_dtl, elwmax, elwdif + real(r8) irab, dirab_dtl, fsenl_dtl, fevpl_dtl + real(r8) z0mg, z0hg, z0qg, cint(3) + real(r8) fevpl_bef, fevpl_noadj, dtl_noadj, erre + real(r8) qevpl, qdewl, qsubl, qfrol, qmelt, qfrz + +!----------------------- definition for 3d run ------------------------ + integer, parameter :: nlay = 3 + integer, parameter :: uvec(5) = (/0,0,0,0,1/) !unit vector + + integer :: & + clev, &! current layer index + botlay, &! bottom layer index + numlay ! available layer number + + real(r8) :: & + hu_, &! adjusted observational height of wind [m] + ht_, &! adjusted observational height of temperature [m] + hq_, &! adjusted observational height of humidity [m] + ktop, &! K value at a specific height + utop, &! u value at a specific height + fht, &! integral of profile function for heat at the top layer + fqt, &! integral of profile function for moisture at the top layer + fmtop, &! fm value at a specific height + phih, &! phi(h), similarity function for sensible heat + displa, &! displacement height for urban + displau, &! displacement height for urban building + displav, &! displacement height for urban vegetation + displav_lay, &! displacement height for urban vegetation layer + z0mv_lay, &! roughness length for vegetation + ueff_veg, &! effective wind speed within canopy layer [m/s] + tg, &! ground temperature + qg ! ground specific humidity + + real(r8) :: & + fg, &! ground fractional cover + fgimp, &! weight of impervious ground + fgper, &! weight of pervious ground + hwr, &! average building height to their distance [-] + sqrtdragc, &! sqrt(drag coefficient) + lm, &! mix length within canopy + fai, &! frontal area index for urban + faiv, &! frontal area index for trees + lsai, &! lai+sai + fwet, &! fractional wet area of foliage [-] + fdry, &! fraction of foliage that is green and dry [-] + delta, &! 0 or 1 + alpha, &! exponential extinction factor for u/k decline within urban + alphav ! exponential extinction factor for u/k decline within trees + + real(r8) :: & + dlwsun, &! change of lw for the last time + dlwsha, &! change of lw for the last time + dlgimp, &! change of lw for the last time + dlgper, &! change of lw for the last time + dlveg ! change of lw for the last time + + real(r8), dimension(0:nurb) :: & + tu, &! temperature array + fc, &! fractional cover array + canlev, &! urban canopy layer lookup table + rb, &! leaf boundary layer resistance [s/m] + cfh, &! heat conductance for leaf [m/s] + cfw, &! latent heat conductance for leaf [m/s] + wtl0, &! normalized heat conductance for air and leaf [-] + wtlq0, &! normalized latent heat cond. for air and leaf [-] + + ei, &! vapor pressure on leaf surface [pa] + deidT, &! derivative of "ei" on "tl" [pa/K] + qsatl, &! leaf specific humidity [kg/kg] + qsatldT ! derivative of "qsatl" on "tlef" + + real(r8), dimension(nlay) :: & + fah, &! weight for thermal resistance to upper layer + faw, &! weight for moisture resistance to upper layer + fgh, &! weight for thermal resistance to lower layer + fgw, &! weight for moisture resistance to lower layer + ueff_lay, &! effective wind speed within canopy layer [m/s] + ueff_lay_, &! effective wind speed within canopy layer [m/s] + taf, &! air temperature within canopy space [K] + qaf, &! humidity of canopy air [kg/kg] + rd, &! aerodynamic resistance between layers [s/m] + rd_, &! aerodynamic resistance between layers [s/m] + cah, &! heat conductance for air [m/s] + cgh, &! heat conductance for ground [m/s] + caw, &! latent heat conductance for air [m/s] + cgw, &! latent heat conductance for ground [m/s] + wtshi, &! sensible heat resistance for air, grd and leaf [-] + wtsqi, &! latent heat resistance for air, grd and leaf [-] + wta0, &! normalized heat conductance for air [-] + wtg0, &! normalized heat conductance for ground [-] + wtaq0, &! normalized latent heat conductance for air [-] + wtgq0, &! normalized heat conductance for ground [-] + wtll, &! sum of normalized heat conductance for air and leaf + wtlql ! sum of normalized heat conductance for air and leaf + + real(r8), dimension(nlay) :: & + Hahe ! anthropogenic heat emission (AHE) + + real(r8) :: & + rv, &! aerodynamic resistance between layers [s/m] + ra2m, &! aerodynamic resistance between 2m and bottom layer [s/m] + rd2m ! aerodynamic resistance between bottom layer and ground [s/m] + + ! temporal + integer i + real(r8) aT, bT, cT, aQ, bQ, cQ, Lahe + real(r8) bee, cf, tmpw1, tmpw2, tmpw3, tmpw4, fact, facq, taftmp + real(r8) B_5, B1_5, dBdT_5, X(5), dX(5) + real(r8) fwet_roof, fwet_roof_, fwet_gimp, fwet_gimp_, rss_, rs_, etr_ + real(r8) fwetfac, lambda + real(r8) cgw_imp, cgw_per + + ! for interface + real(r8) o3coefv, o3coefg, assim_RuBP, assim_Rubisco, ci, vpd, gammas + +!----------------------------------------------------------------------- + +! initialization of errors and iteration parameters + it = 1 !counter for leaf temperature iteration + del = 0.0 !change in leaf temperature from previous iteration + dele = 0.0 !latent head flux from leaf for previous iteration + + dtl = 0. + fevpl_bef = 0. + +! initial values for z0hg, z0qg + + !TODO: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_gper > 0) THEN + z0mg = zsno + ELSE + z0mg = zlnd + ENDIF + z0hg = z0mg + z0qg = z0mg + +!----------------------------------------------------------------------- +! scaling-up coefficients from leaf to canopy +!----------------------------------------------------------------------- + + cint(1) = (1.-exp(-0.110*lai))/0.110 + cint(2) = (1.-exp(-extkd*lai))/extkd + cint(3) = lai + +!----------------------------------------------------------------------- +! initial saturated vapor pressure and humidity and their derivation +!----------------------------------------------------------------------- + + clai = 0.0 + lsai = lai + sai + + ! 0.2mm*LSAI, account for leaf (plus dew) heat capacity + IF ( DEF_VEG_SNOW ) THEN + clai = 0.2*(lai+sai)*cpliq + ldew_rain*cpliq + ldew_snow*cpice + ENDIF + + ! index 0:roof, 1:sunlit wall, 2:shaded wall, 3: vegetation + tu(0) = troof; tu(1) = twsun; tu(2) = twsha; tu(3) = tl + + fg = 1 - fcover(0) + fc(:) = fcover(0:nurb) + fc(3) = fcover(5) + fgimp = fcover(3)/fg + fgper = fcover(4)/fg + !hlr = hwr*(1-sqrt(fcover(0)))/sqrt(fcover(0)) + hwr = hlr*sqrt(fcover(0))/(1-sqrt(fcover(0))) + canlev = (/3, 2, 2, 1/) + + B_5 = B(5) + B1_5 = B1(5) + dBdT_5 = dBdT(5) + + CALL dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) + + qsatl(0) = qroof + qsatldT(0) = dqroofDT + DO i = 1, nurb + CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) + ENDDO + + ! Save the longwave for the last time + dlwsun = lwsun + dlwsha = lwsha + dlgimp = lgimp + dlgper = lgper + dlveg = lveg + +!----------------------------------------------------------------------- +! Calculate the weighted qg, tg, and wet fraction +!----------------------------------------------------------------------- + + ! weighted tg and qg + tg = tgimp*fgimp + tgper*fgper + + ! wet fraction for roof and impervious ground + !------------------------------------------- + ! roof + IF (lbr < 1) THEN + fwet_roof_ = fsno_roof !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_roof_ = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) + fwet_roof_ = min(1., fwet_roof_) + ENDIF + + ! impervious ground + IF (lbi < 1) THEN + fwet_gimp_ = fsno_gimp !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_gimp_ = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) + fwet_gimp_ = min(1., fwet_gimp_) + ENDIF + + ! dew case + IF (qm > qroof) THEN + fwet_roof = 1. + ELSE + fwet_roof = fwet_roof_ + ENDIF + + ! dew case + IF (qm > qgimp) THEN + fwet_gimp = 1. + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + +!----------------------------------------------------------------------- +! initial for fluxes profile +!----------------------------------------------------------------------- + + nmozsgn = 0 !number of times moz changes sign + obuold = 0. !monin-obukhov length from previous iteration + zii = 1000. !m (pbl height) + beta = 1. !- (in computing W_*) + +!----------------------------------------------------------------------- +! scaling factor bee +!----------------------------------------------------------------------- +!NOTE: bee value, the default is 1 + bee = 1. + +!----------------------------------------------------------------------- +! calculate z0m and displa for layers +!----------------------------------------------------------------------- + + ! Calculate z0 and displa for vegetation only and the whole area + CALL cal_z0_displa(lsai, htop, 1., z0mv, displav) + CALL cal_z0_displa(lsai, htop, fc(3), z0mv_lay, displav_lay) + + ! For building only below + ! Macdonald et al., 1998, Eq. (23), A=4.43 + lambda = fcover(0) + displau = hroof * (1 + 4.43**(-lambda)*(lambda - 1)) + fai = 4/PI*hlr*fcover(0) + z0mu = (hroof - displau) * & + exp( -(0.5*1.2/vonkar/vonkar*(1-displau/hroof)*fai)**(-0.5) ) + + ! account for vegetation + faiv = fc(3)*(1. - exp(-0.5*lsai)) + lambda = fcover(0) + faiv*htop/hroof + displa = hroof * (1 + 4.43**(-lambda)*(lambda - 1)) + displa = min(0.95*hroof, displa) + z0m = (hroof - displa) * & + exp( -(0.5*1.2/vonkar/vonkar*(1-displa/hroof)*(fai+faiv*htop/hroof))**(-0.5) ) + + ! to compare z0 of urban and only the surface + ! maximum assumption + IF (z0m < z0mg) z0m = z0mg + IF (displa >= hroof-z0mg) displa = hroof-z0mg + + ! minimum building displa limit + displau = max(hroof/2., displau) + + ! Layer setting + IF ( (.not.run_three_layer) .or. z0mv+displav > 0.5*(z0mu+displau) ) THEN + numlay = 2; botlay = 2; canlev(3) = 2 + ELSE + numlay = 3; botlay = 1 + ENDIF + +!----------------------------------------------------------------------- +! calculate layer decay coefficient +!----------------------------------------------------------------------- + + ! Raupach, 1992 + sqrtdragc = min( (0.003+0.3*faiv)**0.5, 0.3 ) + + ! Kondo, 1971 + alphav = htop/(htop-displav_lay)/(vonkar/sqrtdragc) + alphav = alphav*htop/hroof + + ! Masson, 2000; Oleson et al., 2008 plus tree (+) + IF (alpha_opt == 1) alpha = 0.5*hwr + alphav + + ! Swaid, 1993; Kusaka, 2001; Lee and Park, 2008. plus tree (+) + IF (alpha_opt == 2) alpha = 0.772*hwr + alphav + + ! Macdonald, 2000 plus tree (+) + IF (alpha_opt == 3) alpha = 9.6*fai + alphav + +!----------------------------------------------------------------------- +! first guess for taf and qaf for each layer +! a large differece from previous schemes +!----------------------------------------------------------------------- + taf(:) = 0. + qaf(:) = 0. + + IF (numlay .eq. 2) THEN + taf(3) = (tg + 2.*thm)/3. + qaf(3) = (qg + 2.*qm )/3. + taf(2) = (2.*tg + thm)/3. + qaf(2) = (2.*qg + qm )/3. + ENDIF + + IF (numlay .eq. 3) THEN + taf(3) = (tg + 3.*thm)/4. + qaf(3) = (qg + 3.*qm )/4. + taf(2) = (tg + thm )/2. + qaf(2) = (qg + qm )/2. + taf(1) = (3.*tg + thm)/4. + qaf(1) = (3.*qg + qm )/4. + ENDIF + +!----------------------------------------------------------------------- +! some environment variables +! how to calculate rsoil and what is its usage? +!----------------------------------------------------------------------- + pco2a = pco2m + tprcor = 44.6*273.16*psrf/1.013e5 + rsoil = 0. !respiration (mol m-2 s-1) + !rsoil = 1.22e-6*exp(308.56*(1./56.02-1./(tg-227.13))) + !rsoil = rstfac * 0.23 * 15. * 2.**((tg-273.16-10.)/10.) * 1.e-6 + !rsoil = 5.22 * 1.e-6 + rsoil = 0.22 * 1.e-6 + +! initialization and input values for Monin-Obukhov + ! have been set before + z0h = z0m; z0q = z0m + ur = max(0.1, sqrt(us*us+vs*vs)) !limit set to 0.1 + dth = thm - taf(2) + dqh = qm - qaf(2) + dthv = dth*(1.+0.61*qm) + 0.61*th*dqh + + hu_ = hu; ht_ = ht; hq_ = hq; + + IF (forc_height_mode == 'absolute') THEN + + IF (hu <= hroof+1) THEN + hu_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of u less than hroof+1, set it to hroof+1.' + ENDIF + + IF (ht <= hroof+1) THEN + ht_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of t less than hroof+1, set it to hroof+1.' + ENDIF + + IF (hq <= hroof+1) THEN + hq_ = hroof + 1. + IF (taux == spval) & ! only print warning for the first time-step + write(6,*) 'Warning: the obs height of q less than hroof+1, set it to hroof+1.' + ENDIF + + ELSE ! relative height + hu_ = hroof + hu + ht_ = hroof + ht + hq_ = hroof + hq + ENDIF + + zldis = hu_ - displa + + IF (zldis <= 0.0) THEN + write(6,*) 'the obs height of u less than the zero displacement heght' + CALL CoLM_stop('UrbanVegFlux received a reference height below displacement height.') + ENDIF + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0m,um,obu) + +! ====================================================================== +! BEGIN stability iteration +! ====================================================================== + + DO WHILE (it .le. itmax) + + tlbef = tl + + del2 = del + dele2 = dele + +!----------------------------------------------------------------------- +! Aerodynamical resistances +!----------------------------------------------------------------------- +! Evaluate stability-dependent variables using moz from prior iteration + + CALL moninobukm(hu_,ht_,hq_,displa,z0m,z0h,z0q,obu,um, & + hroof,0.,ustar,fh2m,fq2m,hroof,fmtop,fm,fh,fq,fht,fqt,phih) + +! Aerodynamic resistance + ! 09/16/2017: + ! NOTE that for ram, it is the resistance from Href to z0m+displa + ! however, for rah and raw is only from Href to canopy effective + ! exchange height. + ! So rah/raw is not comparable with that of 1D case + ram = 1./(ustar*ustar/um) + + ! 05/02/2016: calculate resistance from the top layer (effective + ! exchange height) to reference height. + ! For urban, from roof height to reference height + rah = 1./(vonkar/(fh-fht)*ustar) + raw = 1./(vonkar/(fq-fqt)*ustar) + +! update roughness length for sensible/latent heat + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + z0h = max(z0hg, z0h) + z0q = max(z0qg, z0q) + +!----------------------------------------------------------------------- +! new method to calculate rd and ueffect +! the kernel part of 3d model +!----------------------------------------------------------------------- + + ! initialization + rd(:) = 0. + rd_(:) = 0. + ueff_lay(:) = 0. + ueff_lay_(:) = 0. + + ! calculate canopy top wind speed (utop) and exchange coefficient (ktop) + ! need to update each time as obu changed after each iteration + utop = ustar/vonkar * fmtop + ktop = vonkar * (hroof-displa) * ustar / phih + + ueff_lay(3) = utop + ueff_lay_(3) = utop + + ! NOTE: another calculation method for double-check + ! real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, displah, & + ! htop, hbot, obu, ustar, ztop, zbot) + ! rd_(3) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, hroof, displau+z0mu) + + ! real(r8) FUNCTION frd(ktop, htop, hbot, ztop, zbot, displah, z0h, & + ! obu, ustar, z0mg, alpha, bee, fc) + rd(3) = frd(ktop, hroof, 0., hroof, displau+z0mu, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! real(r8) FUNCTION uintegralz(utop, fc, bee, alpha, z0mg, htop, hbot, ztop, zbot) + ! ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + + ! real(r8) FUNCTION ueffectz(utop, htop, hbot, ztop, zbot, z0mg, alpha, bee, fc) + ueff_lay(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + + IF (numlay == 3) THEN + ! real(r8) FUNCTION kintegral(ktop, fc, bee, alpha, z0mg, displah, & + ! htop, hbot, obu, ustar, ztop, zbot) + ! rd(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displau+z0mu, displav+z0mv) + rd(2) = frd(ktop, hroof, 0., displau+z0mu, displav+z0mv, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! rd(1) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displav+z0mv, z0qg) + rd(1) = frd(ktop, hroof, 0., displav+z0mv, z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! calculate ra2m, rd2m + ra2m = frd(ktop, hroof, 0., displav+z0mv, 2., displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + ELSE + ! rd_(2) = kintegral(ktop, 1., bee, alpha, z0mg, displa/hroof, & + ! hroof, 0., obug, ustarg, displau+z0mu, z0qg) + rd(2) = frd(ktop, hroof, 0., displau+z0mu, z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + ! calculate ra2m, rd2m + ra2m = frd(ktop, hroof, 0., displau+z0mu, 2., displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + + rd2m = frd(ktop, hroof, 0., 2., z0qg, displa/hroof, z0h_g, & + obug, ustarg, z0mg, alpha, bee, 1.) + ENDIF + + ! ueff_lay(2) = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., hroof, z0mg) + ! ueff_veg = uintegralz(utop, 1., bee, alpha, z0mg, hroof, 0., htop, hbot) + + ! ueff_lay_(2) = ueffectz(utop, hroof, 0., hroof, z0mg, z0mg, alpha, bee, 1.) + ueff_veg = ueffectz(utop, hroof, 0., htop, hbot, z0mg, alpha, bee, 1.) + + ! Masson, 2000: Account for different canyon orientations + ! 2/PI is a factor derived from 0-360deg integration + IF (alpha_opt == 1) THEN + ueff_lay(2) = 2/PI*ueff_lay(2) + ueff_veg = 2/PI*ueff_veg + rd(:) = PI/2*rd(:) + ENDIF + +!----------------------------------------------------------------------- +! Bulk boundary layer resistance of leaves +!----------------------------------------------------------------------- + + rb(:) = 0. + + DO i = 0, nurb + + IF (i == 3) THEN + cf = 0.01*sqrtdi*sqrt(ueff_veg) + rb(i) = 1./cf + CYCLE + ENDIF + + clev = canlev(i) + rb(i) = rhoair * cpair / ( 11.8 + 4.2*ueff_lay(clev) ) + + ! Cole & Sturrock (1977) Building and Environment, 12, 207-214. + ! rb(i) = rhoair * cpair / ( 5.8 + 4.1*ueff_lay(clev) ) + ! IF (ueff_lay(clev) > 5.) THEN + ! rb(i) = rhoair * cpair / (7.51*ueff_lay(clev)**0.78) + ! ELSE + ! rb(i) = rhoair * cpair / (5.8 + 4.1*ueff_lay(clev)) + ! ENDIF + ! rb(i) = rhoair * cpair & + ! / ( cpair*vonkar*vonkar*ueff_lay(clev)& + ! / (log(0.1*hroof/)*(2.3+log(0.1*hroof/))) ) + ENDDO + +!----------------------------------------------------------------------- +! stomatal resistances +!----------------------------------------------------------------------- + + IF (lai > 0.) THEN + + clev = canlev(3) + eah = qaf(clev) * psrf / ( 0.622 + 0.378 * qaf(clev) ) !pa + +!----------------------------------------------------------------------- +! note: calculate resistance for leaves +!----------------------------------------------------------------------- + + CALL stomata (vmax25,effcon ,c3c4 ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(3) ,tu(3) ,par ,& + o3coefv ,o3coefg ,lambda_wue ,& + rb(3)/lai,raw ,rstfac ,cint(:),& + assim ,respc ,rs & + ) + + rs_ = rs + +IF ( DEF_URBAN_Irrigation .and. rstfac < rstfac_irrig ) THEN + CALL stomata (vmax25,effcon ,c3c4 ,slti ,hlti ,& + shti ,hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,thm ,& + psrf ,po2m ,pco2m ,pco2a ,eah ,& + ei(3) ,tu(3) ,par ,& + o3coefv ,o3coefg ,lambda_wue ,& + rb(3)/lai,raw ,rstfac_irrig ,cint(:),& + assim ,respc ,rs & + ) +ENDIF + ELSE + rs = 2.e4; assim = 0.; respc = 0. + ENDIF + +! above stomatal resistances are for the canopy, the stomatal rsistances +! and the "rb" in the following calculations are the average for single leaf. thus, + rs = rs * lai + rs_= rs_* lai + +! calculate latent heat resistances + clev = canlev(3) + delta = 0.0 + IF (qsatl(3)-qaf(clev) .gt. 0.) delta = 1.0 + + rv = 1/( (1.-delta*(1.-fwet))*lsai/rb(3) & + + (1.-fwet)*delta*(lai/(rb(3)+rs)) ) + +!----------------------------------------------------------------------- +! Solve taf(:) and qaf(:) +!----------------------------------------------------------------------- + + IF (numlay .eq. 2) THEN + + ! - Equations: + ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) & + ! + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) & + ! + lsai/rb(3)*tl*fc(3) + AHE/(rho*cp)) & + ! / (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2) + lsai/rb(3)*fc(3)) + ! + ! Also written as: + ! taf(3) = (cah(3)*thm + cah(2)*taf(2) & + ! + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) + ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) + cfh(2)*twsha*fc(2) & + ! + cfh(3)*tl*fc(3) + AHE/(rho*cp)) & + ! / (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) & + ! + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rss)*qper*fgper*fg + fwetimp/rd(2)*qimp*fgimp*fg & + ! + lsai/(rb(3)+rs)*ql*fc(3) + AHE/rho) & + ! / (1/rd(3) + 1/(rd(2)+rss)*fgper*fg & + ! + fwetimp/rd(2)*fgimp*fg + lsai/(rb(3)+rs)*fc(3)) + ! + ! Also written as: + ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) + cfw(0)*qroof*fc(0)) & + ! / (caw(3) + caw(2) + cfw(0)*fc(0)) + ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg & + ! + cfw(3)*ql*fc(3) + AHE/rho) & + ! / (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg + cfw(3)*fc(3)) + + ! 06/20/2021, yuan: account for Anthropogenic heat + ! 92% heat release as SH, Pigeon et al., 2007 + + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + vehc*fsh + meta + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + fc(3)*lsai/rb(3) + aT = (tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah)*bT + + taf(2) = (tg*fg/rd(2) + Hahe(2)/(rhoair*cpair) + tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) & + + tu(3)*fc(3)*lsai/rb(3) + aT) / (cT * (1- bT/(cT*rd(3)))) + + taf(3) = (taf(2)/rd(3) + tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah) & + / (1/rah + 1/rd(3) + fc(0)/rb(0)) + + IF (qgper < qaf(2)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + fc(3)/rv + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = (qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw)*bQ + + qaf(2) = (qgper*fgper*fg/(rd(2)+rss_) + qgimp*fwet_gimp*fgimp*fg/rd(2) & + + qsatl(3)*fc(3)/rv + aQ + Lahe/rhoair/hvap) & + / (cQ * (1-bQ/(cQ*rd(3)))) + + qaf(3) = (qaf(2)/rd(3) + qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw) & + / (1/raw + 1/rd(3) + fwet_roof*fc(0)/rb(0)) + + ENDIF + + IF (numlay .eq. 3) THEN + + ! - Equations: + ! taf(3) = (thm/rah+1/rd(3)*taf(2)+AHE2/rho/cpair+1/rb(0)*troof*fc(0))/& + ! (1/rah+1/rd(3)+1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3)+1/rd(2)*taf1+1/rb(1)*twsun*fc(1)+1/rb(2)*twsha*fc(2)+& + ! AHE1/rho/cpair)/(1/rd(3)+1/rd(2)+1/rb(1)*fc(1)+1/rb(2)*fc(2)) + ! taf(1) = (1/rd(2)*taf(2)+1/rd(1)*tg*fg+1/rb(3)*tl*fc(3)+Hveh/rhoair/cpair)/& + ! (1/rd(2)+1/rd(1)*fg+1/rb(3)*fc(3)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm+1/rd(3)*qaf(2)+1/rb(0)*qroof*fc(0))/& + ! (1/raw+1/rd(3)+1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3)+1/rd(2)*qaf(1))/& + ! (1/rd(3) + 1/rd(2)) + ! qaf(1) = (1/rd(2)*qaf(2)+1/(rd(1)+rss)*qgper*fgper*fg+& + ! 1/rd(1)*qimp*fgimp*fg+1/(rb(3)+rs)*ql*fc(3)+h_veh/rho)/& + ! (1/rd(2)+1/(rd(1)+rss)*fgper*fg+1/rd(1)*fgimp*fg+1/(rb(3)+rs)*fc(3)) + + Hahe(1) = vehc*fsh + meta + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + cT = 1/rd(3) + 1/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + at = 1/(rd(2)*(1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3))) + bT = 1/(rd(3)*(1/rah+1/rd(3)+fc(0)/rb(0))) + + taf(2) = (tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) & + + (tu(3)*fc(3)*lsai/rb(3)+tg*fg/rd(1)+Hahe(1)/(rhoair*cpair))*aT & + + (tu(0)*fc(0)/rb(0)+thm/rah+Hahe(3)/(rhoair*cpair))*bT & + + Hahe(2)/(rhoair*cpair)) & + / (cT*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) + + taf(1) = (tu(3)*fc(3)*lsai/rb(3) + tg*fg/rd(1) + taf(2)/rd(2) & + + Hahe(1)/(rhoair*cpair)) / (1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3)) + + taf(3) = (tu(0)*fc(0)/rb(0) + taf(2)/rd(3) + thm/rah + Hahe(3)/(rhoair*cpair)) & + / (1/rah+1/rd(3)+fc(0)/rb(0)) + + IF (qgper < qaf(1)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + 1/rd(2) + bQ = 1/(rd(3)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = 1/(rd(2)*(1/rd(2)+fg*fgimp*fwet_gimp/rd(1)+fg*fgper/(rd(1)+rss_)+fc(3)/rv)) + + qaf(2) = ( (fg*fgimp*fwet_gimp*qgimp/rd(1) + fg*fgper*qgper/(rd(1)+rss_) & + + fc(3)*qsatl(3)/rv + Lahe/rhoair/hvap)*aQ & + + (qm/raw+fc(0)*fwet_roof*qsatl(0)/rb(0))*bQ ) & + / ( cQ*(1-bQ/(cQ*rd(3))-aQ/(cQ*rd(2))) ) + + qaf(1) = ( fg*fgimp*fwet_gimp*qgimp/rd(1) + fg*fgper*qgper/(rd(1)+rss_) & + + fc(3)*qsatl(3)/rv + qaf(2)/rd(2) + Lahe/rhoair/hvap ) & + / ( 1/rd(2) + fg*fgimp*fwet_gimp/rd(1) + fg*fgper/(rd(1)+rss_) + fc(3)/rv ) + + qaf(3) = ( fc(0)*fwet_roof*qsatl(0)/rb(0) + qaf(2)/rd(3) + qm/raw ) & + / ( 1/raw + 1/rd(3)+ fwet_roof*fc(0)/rb(0) ) + ENDIF + +!----------------------------------------------------------------------- +! IR radiation, sensible and latent heat fluxes and their derivatives +!----------------------------------------------------------------------- +! the partial derivatives of areodynamical resistance are ignored +! which cannot be determined analytically + + !NOTE: ONLY for vegetation + i = 3 + +! sensible heat fluxes and their derivatives + fsenl = rhoair * cpair * lsai/rb(3) * (tl - taf(botlay)) + + IF (botlay == 2) THEN + fsenl_dtl = rhoair * cpair * lsai/rb(3) & + * ( 1. - fc(3)*lsai/(rb(3)*cT*(1-bT/(cT*rd(3)))) ) + ELSE + fsenl_dtl = rhoair * cpair * lsai/rb(3) & + * ( 1. - fc(3)*lsai/(rb(3)*(1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3))) & + - fc(3)*lsai*aT*aT/(rb(3)*cT*(1-aT/(cT*rd(2))-bT/(cT*rd(3)))) ) + ENDIF + + +! latent heat fluxes and their derivatives + etr = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & + * (qsatl(i) - qaf(botlay)) + + IF (botlay == 2) THEN + etr_dtl = rhoair * (1.-fwet) * delta * lai/(rb(3)+rs) & + * (1.-fc(3)/(cQ*rv*(1-bQ/(cQ*rd(3))))) & + * qsatldT(3) + ELSE + etr_dtl = rhoair * (1.-fwet) * delta * lai/(rb(i)+rs) & + * ( 1. - fc(3)/(rv*(1/rd(2) + fg*fgimp*fwet_gimp/rd(1) + & + fg*fgper/(rss_+rd(1)) + fc(3)/rv)) & + - fc(3)*aQ*aQ/(rv*cQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + ENDIF + +IF ( DEF_URBAN_Irrigation ) THEN + IF (etr.ge.trsmx0*rstfac_irrig) THEN + etr = trsmx0*rstfac_irrig + etr_dtl = 0. + ENDIF +ELSE + IF (etr.ge.etrc) THEN + etr = etrc + etr_dtl = 0. + ENDIF +ENDIF + + evplwet = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & + * (qsatl(i) - qaf(botlay)) + + IF (botlay == 2) THEN + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(3) & + * (1.-fc(3)/(cQ*rv*(1-bQ/(cQ*rd(3))))) & + * qsatldT(3) + ELSE + evplwet_dtl = rhoair * (1.-delta*(1.-fwet)) * lsai/rb(i) & + * ( 1. - fc(3)/(rv*(1/rd(2) + fg*fgimp*fwet_gimp/rd(1) + & + fg*fgper/(rss_+rd(1)) + fc(3)/rv)) & + - fc(3)*aQ*aQ/(rv*CQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + ENDIF + + IF (evplwet.ge.ldew/deltim) THEN + evplwet = ldew/deltim + evplwet_dtl = 0. + ENDIF + + fevpl = etr + evplwet + fevpl_dtl = etr_dtl + evplwet_dtl + + erre = 0. + fevpl_noadj = fevpl + IF ( fevpl*fevpl_bef < 0. ) THEN + erre = -0.9*fevpl + fevpl = 0.1*fevpl + ENDIF + +IF ( DEF_URBAN_Irrigation ) THEN + etr_= rhoair * (1.-fwet) * delta * lai/(rb(i)+rs_) & + * (qsatl(i) - qaf(botlay)) + + IF (etr_.ge.etrc) THEN + etr_ = etrc + ENDIF +ENDIF + + +!----------------------------------------------------------------------- +! difference of temperatures by quasi-newton-raphson method for the non-linear system equations +!----------------------------------------------------------------------- + + ! calculate irab, dirab_dtl + B(5) = B_5*tl**4 + B1(5) = B1_5*tl**4 + dBdT(5) = dBdT_5*tl**3 + X = matmul(Ainv, B) + ! first 5 items of dBdT is 0, dBdT*(0,0,0,0,0,1) + dX = matmul(Ainv, dBdT*uvec) + + ! calculate longwave for vegetation + irab = ( (sum(X(1:4)*VegVF(1:4)) + frl*VegVF(5))*ev - B1(5) ) / fcover(5)*fg + irab = irab + dlveg ! plus the previous step dlveg + dirab_dtl = ( sum(dX(1:4)*VegVF(1:4))*ev - dBdT(5) ) / fcover(5)*fg + + ! solve for leaf temperature + dtl(it) = (sabv + irab - fsenl - hvap*fevpl) & + / (clai/deltim - dirab_dtl + fsenl_dtl + hvap*fevpl_dtl) + dtl_noadj = dtl(it) + + ! check magnitude of change in leaf temperature limit to maximum allowed value + + IF (it .le. itmax) THEN + + ! put brakes on large temperature excursions + IF (abs(dtl(it)).gt.delmax) THEN + dtl(it) = delmax*dtl(it)/abs(dtl(it)) + ENDIF + + IF ((it.ge.2) .and. (dtl(it-1)*dtl(it).le.0.)) THEN + dtl(it) = 0.5*(dtl(it-1) + dtl(it)) + ENDIF + + ENDIF + + tl = tlbef + dtl(it) + tu(3) = tl + +!----------------------------------------------------------------------- +! square roots differences of temperatures and fluxes for use as the condition of convergences +!----------------------------------------------------------------------- + + del = sqrt( dtl(it)*dtl(it) ) + dele = dtl(it) * dtl(it) * & + ( dirab_dtl**2 + fsenl_dtl**2 + (hvap*fevpl_dtl)**2 ) + dele = sqrt(dele) + +!----------------------------------------------------------------------- +! saturated vapor pressures and canopy air temperature, canopy air humidity +!----------------------------------------------------------------------- +! Recalculate leaf saturated vapor pressure (ei_)for updated leaf temperature +! and adjust specific humidity (qsatl_) proportionately + CALL qsadv(tu(i),psrf,ei(i),deiDT(i),qsatl(i),qsatldT(i)) + +! update vegetation/ground surface temperature, canopy air temperature, +! canopy air humidity + + IF (numlay .eq. 2) THEN + + ! - Equations: + ! taf(3) = (1/rah*thm + 1/rd(3)*taf(2) + 1/rb(0)*troof*fc(0) & + ! + AHE/(rho*cp))/(1/rah + 1/rd(3) + 1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3) + 1/rd(2)*tg*fg + 1/rb(1)*twsun*fc(1) + 1/rb(2)*twsha*fc(2) & + ! + lsai/rb(3)*tl*fc(3) + AHE/(rho*cp)) & + ! / (1/rd(3) + 1/rd(2)*fg + 1/rb(1)*fc(1) + 1/rb(2)*fc(2) + lsai/rb(3)*fc(3)) + ! + ! Also written as: + ! taf(3) = (cah(3)*thm + cah(2)*taf(2) & + ! + cfh(0)*troof*fc(0))/(cah(3) + cah(2) + cfh(0)*fc(0)) + ! taf(2) = (cah(2)*taf(3) + cgh(2)*tg*fg + cfh(1)*twsun*fc(1) & + ! + cfh(2)*twsha*fc(2) + cfh(3)*tl*fc(3) + AHE/(rho*cp)) & + ! / (cah(2) + cgh(2)*fg + cfh(1)*fc(1) + cfh(2)*fc(2) + cfh(3)*fc(3)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm + 1/rd(3)*qaf(2) & + ! + 1/rb(0)*qroof*fc(0))/(1/raw + 1/rd(3) + 1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3) + 1/(rd(2)+rss)*qper*fgper*fg & + ! + fwetimp/rd(2)*qimp*fgimp*fg + lsai/(rb(3)+rs)*ql*fc(3) + AHE/rho) & + ! / (1/rd(3) + 1/(rd(2)+rss)*fgper*fg & + ! + fwetimp/rd(2)*fgimp*fg + lsai/(rb(3)+rs)*fc(3)) + ! + ! Also written as: + ! qaf(3) = (caw(3)*qm + caw(2)*qaf(2) & + ! + cfw(0)*qroof*fc(0))/(caw(3) + caw(2) + cfw(0)*fc(0)) + ! qaf(2) = (caw(2)*qaf(3) + cgwper*qper*fgper*fg + cgwimp*qimp*fgimp*fg & + ! + cfw(3)*ql*fc(3) + AHE/rho) & + ! / (caw(2) + cgwper*fgper*fg + cgwimp*fgimp*fg + cfw(3)*fc(3)) + + ! 06/20/2021, yuan: account for AH + ! 92% heat release as SH, Pigeon et al., 2007 + + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + vehc*fsh + meta + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + fc(3)*lsai/rb(3) + aT = (tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah)*bT + + taf(2) = (tg*fg/rd(2) + Hahe(2)/(rhoair*cpair) + tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) & + + tu(3)*fc(3)*lsai/rb(3) + aT) / (cT * (1- bT/(cT*rd(3)))) + + taf(3) = (taf(2)/rd(3) + tu(0)*fc(0)/rb(0) + Hahe(3)/(rhoair*cpair) + thm/rah) & + / (1/rah + 1/rd(3) + fc(0)/rb(0)) + + IF (qgper < qaf(2)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + fc(3)/rv + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = (qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw)*bQ + + qaf(2) = (qgper*fgper*fg/(rd(2)+rss_) + qgimp*fwet_gimp*fgimp*fg/rd(2) & + + qsatl(3)*fc(3)/rv + aQ + Lahe/rhoair/hvap) / (cQ * (1-bQ/(cQ*rd(3)))) + + qaf(3) = (qaf(2)/rd(3) + qsatl(0)*fwet_roof*fc(0)/rb(0) + qm/raw) & + / (1/raw + 1/rd(3) + fwet_roof*fc(0)/rb(0)) + + ENDIF + + IF (numlay .eq. 3) THEN + + ! - Equations: + ! taf(3) = (thm/rah+1/rd(3)*taf(2)+AHE2/rho/cpair+1/rb(0)*troof*fc(0))/& + ! (1/rah+1/rd(3)+1/rb(0)*fc(0)) + ! taf(2) = (1/rd(3)*taf(3)+1/rd(2)*taf1+1/rb(1)*twsun*fc(1)+1/rb(2)*twsha*fc(2)+& + ! AHE1/rho/cpair)/(1/rd(3)+1/rd(2)+1/rb(1)*fc(1)+1/rb(2)*fc(2)) + ! taf(1) = (1/rd(2)*taf(2)+1/rd(1)*tg*fg+1/rb(3)*tl*fc(3)+Hveh/rhoair/cpair)/& + ! (1/rd(2)+1/rd(1)*fg+1/rb(3)*fc(3)) + ! + ! - Equations: + ! qaf(3) = (1/raw*qm+1/rd(3)*qaf(2)+1/rb(0)*qroof*fc(0))/& + ! (1/raw+1/rd(3)+1/rb(0)*fc(0)) + ! qaf(2) = (1/rd(3)*qaf(3)+1/rd(2)*qaf(1))/& + ! (1/rd(3) + 1/rd(2)) + ! qaf(1) = (1/rd(2)*qaf(2)+1/(rd(1)+rss)*qgper*fgper*fg+& + ! 1/rd(1)*qimp*fgimp*fg+1/(rb(3)+rs)*ql*fc(3)+h_veh/rho))/& + ! (1/rd(2)+1/(rd(1)+rss)*fgper*fg+1/rd(1)*fgimp*fg+1/(rb(3)+rs)*fc(3)) + + Hahe(1) = vehc*fsh + meta + Hahe(2) = 4*hlr/(4*hlr+1)*(Fhac+Fwst)*fsh + Fach + Hahe(3) = 1/(4*hlr+1)*(Fhac+Fwst)*fsh + + cT = 1/rd(3) + 1/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + at = 1/(rd(2)*(1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3))) + bT = 1/(rd(3)*(1/rah+1/rd(3)+fc(0)/rb(0))) + + taf(2) = (tu(1)*fc(1)/rb(1) + tu(2)*fc(2)/rb(2) & + + (tu(3)*fc(3)*lsai/rb(3)+tg*fg/rd(1)+Hahe(1)/(rhoair*cpair))*aT & + + (tu(0)*fc(0)/rb(0)+thm/rah+Hahe(3)/(rhoair*cpair))*bT & + + Hahe(2)/(rhoair*cpair)) / (cT*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) + + taf(1) = (tu(3)*fc(3)*lsai/rb(3) + tg*fg/rd(1) + taf(2)/rd(2) & + + Hahe(1)/(rhoair*cpair)) / (1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3)) + + taf(3) = (tu(0)*fc(0)/rb(0) + taf(2)/rd(3) + thm/rah + Hahe(3)/(rhoair*cpair)) & + / (1/rah+1/rd(3)+fc(0)/rb(0)) + + IF (qgper < qaf(1)) THEN + ! dew case. no soil resistance + rss_ = 0 + ELSE + rss_ = rss + ENDIF + + Lahe = (Fhac + Fwst + vehc)*flh + cQ = 1/rd(3) + 1/rd(2) + bQ = 1/(rd(3)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + aQ = 1/(rd(2)*(1/rd(2)+fg*fgimp*fwet_gimp/rd(1)+fg*fgper/(rd(1)+rss_)+fc(3)/rv)) + + qaf(2) = ((fg*fgimp*fwet_gimp*qgimp/rd(1)+fg*fgper*qgper/(rd(1)+rss_) & + + fc(3)*qsatl(3)/rv+Lahe/rhoair/hvap)*aQ & + + (qm/raw+fc(0)*fwet_roof*qsatl(0)/rb(0))*bQ) & + / (cQ*(1-bQ/(cQ*rd(3))-aQ/(cQ*rd(2)))) + + qaf(1) = (fg*fgimp*fwet_gimp*qgimp/rd(1)+fg*fgper*qgper/(rd(1)+rss_) & + + fc(3)*qsatl(3)/rv+qaf(2)/rd(2)+Lahe/rhoair/hvap) & + /(1/rd(2)+fg*fgimp*fwet_gimp/rd(1)+fg*fgper/(rd(1)+rss_)+fc(3)/rv) + + qaf(3) = (fc(0)*fwet_roof*qsatl(0)/rb(0)+qaf(2)/rd(3)+qm/raw) & + /(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0)) + + ENDIF + + !------------------------------------------------ + ! account for fwet for roof and impervious ground + IF (qaf(3) > qroof) THEN + fwet_roof = 1. !dew case + ELSE + fwet_roof = fwet_roof_ + ENDIF + + IF (qaf(botlay) > qgimp) THEN + fwet_gimp = 1. !dew case + ELSE + fwet_gimp = fwet_gimp_ + ENDIF + + ! weighted qg + ! NOTE: IF fwet_gimp=1, same as previous + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper) / fwetfac + + fgw(2) = fg*fwetfac + +! update co2 partial pressure within canopy air + ! 05/02/2016: may have some problem with gdh2o, however, + ! this variable seems never used here. Different height + ! level vegetation should have different gdh2o, i.e., + ! different rd(layer) values. + gah2o = 1.0/raw * tprcor/thm !mol m-2 s-1 + gdh2o = 1.0/rd(botlay) * tprcor/thm !mol m-2 s-1 + + pco2a = pco2m - 1.37*psrf/max(0.446,gah2o) * & + (assim - respc - rsoil) + +!----------------------------------------------------------------------- +! Update monin-obukhov length and wind speed including the stability effect +!----------------------------------------------------------------------- + + ! USE the top layer taf and qaf + dth = thm - taf(2) + dqh = qm - qaf(2) + + tstar = vonkar/(fh)*dth + qstar = vonkar/(fq)*dqh + + thvstar = tstar*(1.+0.61*qm)+0.61*th*qstar + zeta = zldis*vonkar*grav*thvstar / (ustar**2*thv) + IF (zeta .ge. 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF (zeta .ge. 0.) THEN + um = max(ur,.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu .lt. 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn .ge. 4) obu = zldis/(-0.01) + obuold = obu + +!----------------------------------------------------------------------- +! Test for convergence +!----------------------------------------------------------------------- + + it = it+1 + + IF (it .gt. itmin) THEN + fevpl_bef = fevpl + det = max(del,del2) + dee = max(dele,dele2) + IF (det .lt. dtmin .and. dee .lt. dlemin) EXIT + ENDIF + + ENDDO + +! ====================================================================== +! END stability iteration +! ====================================================================== + + zol = zeta + rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! canopy fluxes and total assimilation amd respiration + + IF (lai .gt. 0.001) THEN + rst = rs/lai + ELSE + rs = 2.0e4 + assim = 0. + respc = 0. + rst = 2.0e4 + ENDIF + respc = respc + rsoil + +IF ( DEF_URBAN_Irrigation ) THEN + etr_deficit = max(0., etr - etr_) +ENDIF + +! canopy fluxes and total assimilation and respiration + + fsenl = fsenl + fsenl_dtl*dtl(it-1) & + ! add the imbalanced energy below due to T adjustment to sensible heat + + (dtl_noadj-dtl(it-1)) * (clai/deltim - dirab_dtl & + + fsenl_dtl + hvap*fevpl_dtl) & + ! add the imbalanced energy below due to q adjustment to sensible heat + + hvap*erre + + etr = etr + etr_dtl*dtl(it-1) + evplwet = evplwet + evplwet_dtl*dtl(it-1) + fevpl = fevpl_noadj + fevpl = fevpl + fevpl_dtl*dtl(it-1) + + elwmax = ldew/deltim + + elwdif = max(0., evplwet-elwmax) + evplwet = min(evplwet, elwmax) + + fevpl = fevpl - elwdif + fsenl = fsenl + hvap*elwdif + + +!----------------------------------------------------------------------- +! Update dew accumulation (kg/m2) +!----------------------------------------------------------------------- + + ldew = max(0., ldew-evplwet*deltim) + + ! account for vegetation snow and update ldew_rain, ldew_snow, ldew + IF ( DEF_VEG_SNOW ) THEN + IF (tl > tfrz) THEN + qevpl = max (evplwet, 0.) + qdewl = abs (min (evplwet, 0.) ) + qsubl = 0. + qfrol = 0. + + IF (qevpl > ldew_rain/deltim) THEN + qsubl = qevpl - ldew_rain/deltim + qevpl = ldew_rain/deltim + ENDIF + ELSE + qevpl = 0. + qdewl = 0. + qsubl = max (evplwet, 0.) + qfrol = abs (min (evplwet, 0.) ) + + IF (qsubl > ldew_snow/deltim) THEN + qevpl = qsubl - ldew_snow/deltim + qsubl = ldew_snow/deltim + ENDIF + ENDIF + + ldew_rain = ldew_rain + (qdewl-qevpl)*deltim + ldew_snow = ldew_snow + (qfrol-qsubl)*deltim + + ldew = ldew_rain + ldew_snow + ENDIF + + IF ( DEF_VEG_SNOW ) THEN + ! update fwet_snow + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((10./(48.*(lai+sai)))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + ! phase change + + qmelt = 0. + qfrz = 0. + + IF (ldew_snow.gt.1.e-6 .and. tl.gt.tfrz) THEN + qmelt = min(ldew_snow/deltim,(tl-tfrz)*cpice*ldew_snow/(deltim*hfus)) + ldew_snow = max(0.,ldew_snow - qmelt*deltim) + ldew_rain = max(0.,ldew_rain + qmelt*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl = fwet_snow*tfrz + (1.-fwet_snow)*tl !Niu et al., 2004 + ENDIF + + IF (ldew_rain.gt.1.e-6 .and. tl.lt.tfrz) THEN + qfrz = min(ldew_rain/deltim,(tfrz-tl)*cpliq*ldew_rain/(deltim*hfus)) + ldew_rain = max(0.,ldew_rain - qfrz*deltim) + ldew_snow = max(0.,ldew_snow + qfrz*deltim) + !NOTE: There may be some problem, energy imbalance + ! However, detailed treatment could be somewhat trivial + tl = fwet_snow*tfrz + (1.-fwet_snow)*tl !Niu et al., 2004 + ENDIF + ENDIF + + ! vegetation heat change + dheatl = clai/deltim*dtl(it-1) + +!----------------------------------------------------------------------- +! balance check +!----------------------------------------------------------------------- + + err = sabv + irab + dirab_dtl*dtl(it-1) & + - fsenl - hvap*fevpl - dheatl + +#if (defined CoLMDEBUG) + IF (abs(err) .gt. .2) THEN + write(6,*) 'energy imbalance in UrbanVegFlux.F90', & + i,it-1,err,sabv,irab,fsenl,hvap*fevpl,dheatl + CALL CoLM_stop() + ENDIF +#endif + + + ! calculate longwave absorption + lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) + lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) + lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) + lgper = ( egper*X(4) - B1(4) ) / (1-egper) + lveg = ( (sum(X(1:4)*VegVF(1:4)) + frl*VegVF(5))*ev - B1(5) ) + lout = sum( X * SkyVF ) + + ! longwave absorption due to leaf temperature change + lwsun = lwsun + ( ewall*dX(1) ) / (1-ewall) * dtl(it-1) + lwsha = lwsha + ( ewall*dX(2) ) / (1-ewall) * dtl(it-1) + lgimp = lgimp + ( egimp*dX(3) ) / (1-egimp) * dtl(it-1) + lgper = lgper + ( egper*dX(4) ) / (1-egper) * dtl(it-1) + lveg = lveg + ( sum(dX(1:4)*VegVF(1:4))*ev - dBdT(5) ) * dtl(it-1) + lout = lout + sum( dX * SkyVF * dtl(it-1) ) + + ! Energy balance check + err = lwsun + lwsha + lgimp + lgper + lveg + lout + + IF (abs(err-frl) > 1e-6) THEN + print *, "Longwave - Energy Balance Check error!", err-frl + ENDIF + + ! convert to per unit area + IF (fcover(1) > 0.) lwsun = lwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) + IF (fcover(2) > 0.) lwsha = lwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) + IF (fcover(3) > 0.) lgimp = lgimp / fcover(3) * fg !/ fgimp + IF (fcover(4) > 0.) lgper = lgper / fcover(4) * fg !/ fgper + IF (fcover(5) > 0.) lveg = lveg / fcover(5) * fg !/ fv/fg + + ! add previous longwave + lwsun = lwsun + dlwsun + lwsha = lwsha + dlwsha + lgimp = lgimp + dlgimp + lgper = lgper + dlgper + lveg = lveg + dlveg + + tafu = taf(2) + +!----------------------------------------------------------------------- +! wind stresses +!----------------------------------------------------------------------- + + taux = - rhoair*us/ram + tauy = - rhoair*vs/ram + +!----------------------------------------------------------------------- +! fluxes from roof, walls to canopy space +!----------------------------------------------------------------------- + + ! sensible heat fluxes + fsenroof = rhoair*cpair/rb(0)*(troof-taf(3)) + fsenwsun = rhoair*cpair/rb(1)*(twsun-taf(2)) + fsenwsha = rhoair*cpair/rb(2)*(twsha-taf(2)) + + ! latent heat fluxes + fevproof = rhoair/rb(0)*(qsatl(0)-qaf(3)) + fevproof = fevproof*fwet_roof + + IF (botlay == 2) THEN + + bT = 1/(rd(3) * (1/rah+1/rd(3)+fc(0)/rb(0))) + cT = 1/rd(3) + fg/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + fc(3)*lsai/rb(3) + + cQ = 1/rd(3) + fg*fgper/(rd(2)+rss_) + fwet_gimp*fg*fgimp/rd(2) + fc(3)/rv + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + + cwsuns = rhoair*cpair/rb(1) & + *( 1. - fc(1)/(cT*rb(1)*(1-bT/(cT*rd(3)))) ) + + cwshas = rhoair*cpair/rb(2) & + *( 1. - fc(2)/(cT*rb(2)*(1-bT/(cT*rd(3)))) ) + + croofs = rhoair*cpair/rb(0) & + *( 1. - fc(0)*bT*bT / (cT*rb(0)*(1-bT/(cT*rd(3)))) & + - fc(0) / (rb(0)*(1/rah+1/rd(3)+fc(0)/rb(0))) ) + + croofl = rhoair*fwet_roof/rb(0)*qsatldT(0) & + * ( 1. - fwet_roof*fc(0)*bQ*bQ / (cQ*rb(0)*(1-bQ/(cQ*rd(3)))) & + - fwet_roof*fc(0) / (rb(0)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) ) + + croof = croofs + croofl*htvp_roof + ELSE + + cT = 1/rd(3) + 1/rd(2) + fc(1)/rb(1) + fc(2)/rb(2) + bT = 1/(rd(3)*(1/rah+1/rd(3)+fc(0)/rb(0))) + + cQ = 1/rd(3) + 1/rd(2) + bQ = 1/(rd(3) * (1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) + + cwsuns = rhoair*cpair/rb(1) & + *( 1. - fc(1)/(cT*rb(1)*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) ) + + cwshas = rhoair*cpair/rb(2) & + *( 1. - fc(2)/(cT*rb(2)*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) ) + + croofs = rhoair*cpair/rb(0) & + *( 1. - fc(0)*bT*bT/(cT*rb(0)*(1-aT/(rd(2)*cT)-bT/(rd(3)*cT))) & + - fc(0)/(rb(0)*(1/rah+1/rd(3)+fc(0)/rb(0))) ) + + croofl = rhoair*fwet_roof/rb(0)*qsatldT(0) & + *( 1. - fwet_roof*fc(0)/(rb(0)*(1/raw+1/rd(3)+fwet_roof*fc(0)/rb(0))) & + - fwet_roof*fc(0)*bQ*bQ/(rb(0)*cQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + + croof = croofs + croofl*htvp_roof + ENDIF + +!----------------------------------------------------------------------- +! fluxes from urban ground to canopy space +!----------------------------------------------------------------------- + + fsengimp = cpair*rhoair/rd(botlay)*(tgimp-taf(botlay)) + fsengper = cpair*rhoair/rd(botlay)*(tgper-taf(botlay)) + + fevpgper = rhoair/(rd(botlay)+rss_)*(qgper-qaf(botlay)) + fevpgimp = rhoair/rd(botlay) *(qgimp-qaf(botlay)) + + fevpgimp = fevpgimp*fwet_gimp + +!----------------------------------------------------------------------- +! Derivative of soil energy flux with respect to soil temperature +!----------------------------------------------------------------------- + + IF (botlay == 2) THEN + cgrnds = cpair*rhoair/rd(2)*( 1. - fg/(cT*rd(2)*(1-bT/(cT*rd(3)))) ) + + cgperl = rhoair/(rd(2)+rss_)*dqgperdT*(1-fg*fgper/(cQ*(rd(2)+rss_)*(1-bQ/(cQ*rd(3)))) ) + cgimpl = rhoair/rd(2) *dqgimpdT*(1-fwet_gimp*fg*fgimp/(cQ*rd(2)*(1-bQ/(cQ*rd(3)))) ) + cgimpl = cgimpl*fwet_gimp + + ELSE !botlay == 1 + cgrnds = cpair*rhoair/rd(1)* & + ( 1. - fg/(rd(1)*(1/rd(2)+fg/rd(1)+fc(3)*lsai/rb(3))) & + - fg*aT*aT/(rd(1)*cT*(1-aT/(cT*rd(2))-bT/(cT*rd(3)))) ) + + cgperl = rhoair/(rd(1)+rss_)*dqgperdT & + *( 1. - fg*fgper/((rss_+rd(1))*(1/rd(2)+fg*fgper/(rss_+rd(1)) & + +fg*fgimp*fwet_gimp/rd(1)+fc(3)/rv)) & + - fg*fgper*aQ*aQ/((rss_+rd(1))*cQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + + cgimpl = rhoair/rd(1)*dqgimpdT & + *( 1. - fg*fgimp*fwet_gimp/(rd(1)*(1/rd(2)+fg*fgper/(rss_+rd(1)) & + +fg*fgimp*fwet_gimp/rd(1)+fc(3)/rv)) & + - fg*fgimp*fwet_gimp*aQ*aQ/(rd(1)*cQ*(1-aQ/(cQ*rd(2))-bQ/(cQ*rd(3)))) ) + cgimpl = cgimpl*fwet_gimp + ENDIF + + cgimp = cgrnds + cgimpl*htvp_gimp + cgper = cgrnds + cgperl*htvp_gper + +!----------------------------------------------------------------------- +! 2 m height air temperature above apparent sink height +!----------------------------------------------------------------------- + + !tref = thm + vonkar/(fh)*dth * (fh2m/vonkar - fh/vonkar) + !qref = qm + vonkar/(fq)*dqh * (fq2m/vonkar - fq/vonkar) + + ! assumption: (tg-t2m):(tg-taf) = 2:(displa+z0m) + IF (numlay == 2) THEN + tref = ( (displau+z0mu-2.)*tg + 2.*taf(2) ) / (displau+z0mu) + qref = ( (displau+z0mu-2.)*qg + 2.*qaf(2) ) / (displau+z0mu) + ELSE + tref = (((displau+z0mu+displav+z0mv)*0.5-2.)*tg + taf(1) + taf(2) ) & + / ( (displau+z0mu+displav+z0mv)*0.5 ) + qref = (((displau+z0mu+displav+z0mv)*0.5-2.)*qg + qaf(1) + qaf(2) ) & + / ( (displau+z0mu+displav+z0mv)*0.5 ) + ENDIF + + END SUBROUTINE UrbanVegFlux +!---------------------------------------------------------------------- + + + SUBROUTINE dewfraction (sigf,lai,sai,dewmx,ldew,ldew_rain,ldew_snow,fwet,fdry) +!======================================================================= +! Original author: Yongjiu Dai, September 15, 1999 +! +! determine fraction of foliage covered by water and +! fraction of foliage that is dry and transpiring +! +! !REVISIONS: +! +! 2024.04.16, Hua Yuan: add option to account for vegetation snow process +! 2018.06 , Hua Yuan: remove sigf, to compatible with PFT +!======================================================================= + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: sigf !fraction of veg cover, excluding snow-covered veg [-] + real(r8), intent(in) :: lai !leaf area index [-] + real(r8), intent(in) :: sai !stem area index [-] + real(r8), intent(in) :: dewmx !maximum allowed dew [0.1 mm] + real(r8), intent(in) :: ldew !depth of water on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_rain !depth of rain on foliage [kg/m2/s] + real(r8), intent(in) :: ldew_snow !depth of snow on foliage [kg/m2/s] + real(r8), intent(out) :: fwet !fraction of foliage covered by water&snow [-] + real(r8), intent(out) :: fdry !fraction of foliage that is green and dry [-] + + real(r8) :: lsai !lai + sai + real(r8) :: dewmxi !inverse of maximum allowed dew [1/mm] + real(r8) :: vegt !sigf*lsai, NOTE: remove sigf + real(r8) :: fwet_rain !fraction of foliage covered by water [-] + real(r8) :: fwet_snow !fraction of foliage covered by snow [-] +! +!----------------------------------------------------------------------- +! Fwet is the fraction of all vegetation surfaces which are wet +! including stem area which contribute to evaporation + lsai = lai + sai + dewmxi = 1.0/dewmx + ! 06/2018, yuan: remove sigf, to compatible with PFT + vegt = lsai + + fwet = 0 + IF (ldew > 0.) THEN + fwet = ((dewmxi/vegt)*ldew)**.666666666666 + ! Check for maximum limit of fwet + fwet = min(fwet,1.0) + ENDIF + + ! account for vegetation snow + ! calculate fwet_rain, fwet_snow, fwet + IF ( DEF_VEG_SNOW ) THEN + + fwet_rain = 0 + IF(ldew_rain > 0.) THEN + fwet_rain = ((dewmxi/vegt)*ldew_rain)**.666666666666 + ! Check for maximum limit of fwet_rain + fwet_rain = min(fwet_rain,1.0) + ENDIF + + fwet_snow = 0 + IF(ldew_snow > 0.) THEN + fwet_snow = ((dewmxi/(48.*vegt))*ldew_snow)**.666666666666 + ! Check for maximum limit of fwet_snow + fwet_snow = min(fwet_snow,1.0) + ENDIF + + fwet = fwet_rain + fwet_snow - fwet_rain*fwet_snow + fwet = min(fwet,1.0) + ENDIF + + ! fdry is the fraction of lai which is dry because only leaves can + ! transpire. Adjusted for stem area which does not transpire + fdry = (1.-fwet)*lai/lsai + + END SUBROUTINE dewfraction + +END MODULE MOD_Urban_Flux +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_GroundFlux.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_GroundFlux.F90 new file mode 100644 index 0000000000..53a5cba0e9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_GroundFlux.F90 @@ -0,0 +1,229 @@ +#include + +MODULE MOD_Urban_GroundFlux + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanGroundFlux + +CONTAINS + + SUBROUTINE UrbanGroundFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & + ur, thm, th, thv, zlnd, zsno, fsno_gimp, & + lbi, wliq_gimpsno,wice_gimpsno, & + fcover, tgimp, tgper, qgimp, qgper, tref, qref, & + z0m, z0hg, zol, ustar, qstar, tstar, fm, fh, fq) + +!======================================================================= +! +! !DESCRIPTION: +! This is the main subroutine to execute the calculation +! of bare ground fluxes +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! 07/2022, Hua Yuan: Urban 2m T/q -> above bare ground 2m. +! +!======================================================================= + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: & + lbi + real(r8), intent(in) :: & + ! atmospherical variables and observational height + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] [not used] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + ur, &! wind speed at reference height [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + + zlnd, &! roughness length for soil [m] + zsno, &! roughness length for snow [m] + fsno_gimp, &! fraction of impervious ground covered by snow + fcover(0:5), &! coverage of aboveground urban components [-] + + wliq_gimpsno, &! liqui water [kg/m2] + wice_gimpsno, &! ice lens [kg/m2] + + tgimp, &! ground impervious temperature [K] + tgper, &! ground pervious temperature [K] + qgimp, &! ground impervious specific humidity [kg/kg] + qgper ! ground pervious specific humidity [kg/kg] + + real(r8), intent(out) :: & + tref, &! 2 m height air temperature [kelvin] + qref ! 2 m height air humidity + + real(r8), intent(out) :: & + z0m, &! effective roughness [m] + z0hg, &! roughness length over ground, sensible heat [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + +!-------------------------- Local Variables ---------------------------- + integer niters, &! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + tg, &! ground surface temperature [K] + qg, &! ground specific humidity [kg/kg] + fg, &! ground fractional cover [-] + fgimp, &! weight of impervious ground + fgper, &! weight of pervious ground + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0qg ! roughness length over ground, latent heat [m] + + real(r8) fwet_gimp, fwetfac + +!----------------------------------------------------------------------- + +! initial roughness length + !NOTE: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_gimp > 0) THEN + z0mg = zsno + ELSE + z0mg = zlnd + ENDIF + z0hg = z0mg + z0qg = z0mg + +! potential temperature at the reference height + beta = 1. !- (in computing W_*) + zii = 1000. !m (pbl height) + z0m = z0mg + + fg = 1 - fcover(0) + fgimp = fcover(3)/fg + fgper = fcover(4)/fg + + ! weighted tg + tg = tgimp*fgimp + tgper*fgper + + ! wet fraction impervious ground + !------------------------------------------- + IF (lbi < 1) THEN + fwet_gimp = fsno_gimp !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_gimp = (max(0., wliq_gimpsno+wice_gimpsno))**(2/3.) + fwet_gimp = min(1., fwet_gimp) + ENDIF + + ! dew case + IF (qm > qgimp) THEN + fwet_gimp = 1. + ENDIF + + ! weighted qg + fwetfac = fgimp*fwet_gimp + fgper + qg = (qgimp*fgimp*fwet_gimp + qgper*fgper)/fwetfac + +!----------------------------------------------------------------------- +! Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!----------------------------------------------------------------------- +! Initialization variables + nmozsgn = 0 + obuold = 0. + + dth = thm-tg + dqh = qm-qg + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-0. + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + +! Evaluated stability-dependent variables using moz from prior iteration + niters=6 + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters !begin stability iteration + !---------------------------------------------------------------- + displax = 0. + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF (zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF (zeta >= 0.) THEN + um = max(ur,0.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION !end stability iteration + !---------------------------------------------------------------- + + zol = zeta + !rib = min(5.,zol*ustar**2/(vonkar**2/fh*um**2)) + +! 2 m height air temperature + tref = thm + vonkar/fh*dth * (fh2m/vonkar - fh/vonkar) + qref = qm + vonkar/fq*dqh * (fq2m/vonkar - fq/vonkar) + + END SUBROUTINE UrbanGroundFlux + +END MODULE MOD_Urban_GroundFlux +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 new file mode 100644 index 0000000000..29b0d5ce6b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Hydrology.F90 @@ -0,0 +1,407 @@ +#include + +MODULE MOD_Urban_Hydrology +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The urban hydrological processes mainly falls into three categories: +! 1) previous surfaces; 2) roofs and imperious surfaces; 3) urban water +! bodies (lakes). +! +! For pervious surfaces, the process is similar to soil water +! processes, involving the calculation of runoff and soil water +! transport. For urban water bodies, a lake model is used for +! simulation. For roofs and impermeable surfaces, snow accumulation and +! ponding processes are considered. The snow accumulation process is +! consistent with soil snow processes. The ponding process considers +! the surface as an impermeable area, with the maximum capacity of +! liquid water not exceeding a predetermined value (max ponding = 1 kg +! m−2). Any excess water is treated as runoff. The coverage ratio of +! ponded areas is calculated using a similar leaf wetness index +! calculation scheme. +! +! Create by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +! 10/2022, Hua Yuan: Add wet fraction for roof and impervious ground; +! set max ponding for roof and impervious from 10mm -> 1mm. +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanHydrology + +CONTAINS + + SUBROUTINE UrbanHydrology ( & + ! model running information + ipatch ,patchtype ,lbr ,lbi ,& + lbp ,lbl ,snll ,deltim ,& + ! forcing + pg_rain ,pgper_rain ,pgimp_rain ,pg_snow ,& + pg_rain_lake ,pg_snow_lake ,& + ! surface parameters or status + froof ,fgper ,flake ,bsw ,& + porsl ,psi0 ,hksati ,pondmx ,& + ssi ,wimp ,smpmin ,theta_r ,& + fsatmax ,fsatdcf ,elvstd ,BVIC ,& + rootr,rootflux ,etr ,fseng ,fgrnd ,& + t_gpersno ,t_lakesno ,t_lake ,dz_lake ,& + z_gpersno ,z_lakesno ,zi_gpersno ,zi_lakesno ,& + dz_roofsno ,dz_gimpsno ,dz_gpersno ,dz_lakesno ,& + wliq_roofsno ,wliq_gimpsno ,wliq_gpersno ,wliq_lakesno ,& + wice_roofsno ,wice_gimpsno ,wice_gpersno ,wice_lakesno ,& + qseva_roof ,qseva_gimp ,qseva_gper ,qseva_lake ,& + qsdew_roof ,qsdew_gimp ,qsdew_gper ,qsdew_lake ,& + qsubl_roof ,qsubl_gimp ,qsubl_gper ,qsubl_lake ,& + qfros_roof ,qfros_gimp ,qfros_gper ,qfros_lake ,& + sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& + lake_icefrac ,scv_lake ,snowdp_lake ,imelt_lake ,& + fioldl ,w_old ,& + forc_us ,forc_vs ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! END SNICAR model variables +! irrigaiton + qflx_irrig_drip,qflx_irrig_flood,qflx_irrig_paddy ,& + ! output + rsur ,rnof ,qinfl ,zwt ,& + wdsrf ,wa ,qcharge ,smp ,hk) + +!======================================================================= +! this is the main SUBROUTINE to execute the calculation of URBAN +! hydrological processes +! +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: denice, denh2o, tfrz + USE MOD_SoilSnowHydrology + USE MOD_Lake + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + ipatch ,&! patch index + patchtype ,&! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=land ice, 4=land water bodies, 99=ocean + lbr ,&! lower bound of array + lbi ,&! lower bound of array + lbp ,&! lower bound of array + lbl ! lower bound of array + + integer, intent(inout) :: & + snll ! number of snow layers + + real(r8), intent(in) :: & + deltim ,&! time step (s) + pg_rain ,&! rainfall after removal of interception (mm h2o/s) + pg_snow ,&! snowfall after removal of interception (mm h2o/s) + pgper_rain ,&! rainfall after removal of interception (mm h2o/s) + pgimp_rain ,&! rainfall after removal of interception (mm h2o/s) + pg_rain_lake ,&! rainfall onto lake (mm h2o/s) + pg_snow_lake ,&! snowfall onto lake (mm h2o/s) + froof ,&! roof fractional cover [-] + fgper ,&! weight of impervious ground [-] + flake ,&! lake fractional cover [-] + ! wtfact ,&! fraction of model area with high water table + ! (updated to gridded 'fsatmax' data) + pondmx ,&! ponding depth (mm) + ssi ,&! irreducible water saturation of snow + wimp ,&! water impermeable IF porosity less than wimp + smpmin ,&! restriction for min of soil poten. (mm) + + elvstd ,&! standard deviation of elevation [m] + BVIC ,&! b parameter in Fraction of saturated soil in a grid calculated by VIC + + bsw (1:nl_soil) ,&! Clapp-Hornberger "B" + porsl (1:nl_soil) ,&! saturated volumetric soil water content(porosity) + psi0 (1:nl_soil) ,&! saturated soil suction (mm) (NEGATIVE) + hksati(1:nl_soil) ,&! hydraulic conductivity at saturation (mm h2o/s) + theta_r(1:nl_soil) ,&! residual moisture content [-] + fsatmax ,&! maximum saturated area fraction [-] + fsatdcf ,&! decay factor in calculation of saturated area fraction [1/m] + rootr (1:nl_soil) ,&! root resistance of a layer, all layers add to 1.0 + + etr ,&! vegetation transpiration + qseva_roof ,&! ground surface evaporation rate (mm h2o/s) + qseva_gimp ,&! ground surface evaporation rate (mm h2o/s) + qseva_gper ,&! ground surface evaporation rate (mm h2o/s) + qseva_lake ,&! ground surface evaporation rate (mm h2o/s) + qsdew_roof ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_gimp ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_gper ,&! ground surface dew formation (mm h2o /s) [+] + qsdew_lake ,&! ground surface dew formation (mm h2o /s) [+] + qsubl_roof ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_gimp ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_gper ,&! sublimation rate from snow pack (mm h2o /s) [+] + qsubl_lake ,&! sublimation rate from snow pack (mm h2o /s) [+] + qfros_roof ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gimp ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gper ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_lake ,&! surface dew added to snow pack (mm h2o /s) [+] + sm_roof ,&! snow melt (mm h2o/s) + sm_gimp ,&! snow melt (mm h2o/s) + sm_gper ,&! snow melt (mm h2o/s) + w_old ! liquid water mass of the column at the previous time step (mm) + + real(r8), intent(inout) :: rootflux(1:nl_soil) + + real(r8), intent(in) :: forc_us + real(r8), intent(in) :: forc_vs + +! SNICAR model variables +! Aerosol Fluxes (Jan. 07, 2023) + ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] + real(r8), intent(in) :: forc_aer (14) + + real(r8), intent(inout) :: & + mss_bcpho (lbp:0) ,&! mass of hydrophobic BC in snow (col,lyr) [kg] + mss_bcphi (lbp:0) ,&! mass of hydrophillic BC in snow (col,lyr) [kg] + mss_ocpho (lbp:0) ,&! mass of hydrophobic OC in snow (col,lyr) [kg] + mss_ocphi (lbp:0) ,&! mass of hydrophillic OC in snow (col,lyr) [kg] + mss_dst1 (lbp:0) ,&! mass of dust species 1 in snow (col,lyr) [kg] + mss_dst2 (lbp:0) ,&! mass of dust species 2 in snow (col,lyr) [kg] + mss_dst3 (lbp:0) ,&! mass of dust species 3 in snow (col,lyr) [kg] + mss_dst4 (lbp:0) ! mass of dust species 4 in snow (col,lyr) [kg] +! Aerosol Fluxes (Jan. 07, 2023) +! END SNICAR model variables + +! For irrigation + real(r8), intent(in) :: & + qflx_irrig_drip ,&! drip irrigation rate [mm/s] + qflx_irrig_flood ,&! flood irrigation rate [mm/s] + qflx_irrig_paddy ! paddy irrigation rate [mm/s] +! END irrigation + + integer, intent(in) :: & + imelt_lake(maxsnl+1:nl_soil) ! lake flag for melting or freezing snow and soil layer [-] + + real(r8), intent(inout) :: & + lake_icefrac( 1:nl_lake) ,&! lake ice fraction + fioldl (maxsnl+1:nl_soil) ,&! fraction of ice relative to the total water content [-] + dz_lake ( 1:nl_lake) ,&! lake layer depth [m] + z_gpersno (lbp:nl_soil) ,&! layer depth (m) + dz_roofsno (lbr:nl_roof) ,&! layer thickness (m) + dz_gimpsno (lbi:nl_soil) ,&! layer thickness (m) + dz_gpersno (lbp:nl_soil) ,&! layer thickness (m) + zi_gpersno(lbp-1:nl_soil) ,&! interface level below a "z" level (m) + t_lake ( 1:nl_lake) ,&! lake temperature [K] + t_gpersno (lbp:nl_soil) ,&! soil/snow skin temperature (K) + wliq_roofsno(lbr:nl_roof) ,&! liquid water (kg/m2) + wliq_gimpsno(lbi:nl_soil) ,&! liquid water (kg/m2) + wliq_gpersno(lbp:nl_soil) ,&! liquid water (kg/m2) + wice_roofsno(lbr:nl_roof) ,&! ice lens (kg/m2) + wice_gimpsno(lbi:nl_soil) ,&! ice lens (kg/m2) + wice_gpersno(lbp:nl_soil) ,&! ice lens (kg/m2) + + zi_lakesno (maxsnl :nl_soil),&! interface level below a "z" level (m) + t_lakesno (maxsnl+1:nl_soil),&! soil/snow skin temperature (K) + z_lakesno (maxsnl+1:nl_soil),&! layer depth (m) + dz_lakesno (maxsnl+1:nl_soil),&! layer thickness (m) + wliq_lakesno(maxsnl+1:nl_soil),&! liquid water (kg/m2) + wice_lakesno(maxsnl+1:nl_soil),&! ice lens (kg/m2) + + sm_lake ,&! snow melt (mm h2o/s) + scv_lake ,&! lake snow mass (kg/m2) + snowdp_lake ,&! lake snow depth + fseng ,&! sensible heat from ground + fgrnd ,&! ground heat flux + zwt ,&! the depth from ground (soil) surface to water table [m] + wdsrf ,&! depth of surface water [mm] + wa ! water storage in aquifer [mm] + + real(r8), intent(out) :: & + rsur ,&! surface runoff (mm h2o/s) + rnof ,&! total runoff (mm h2o/s) + qinfl ,&! infiltration rate (mm h2o/s) + qcharge ! groundwater recharge (positive to aquifer) [mm/s] + + real(r8), intent(out) :: & + smp(1:nl_soil) ,&! soil matrix potential [mm] + hk (1:nl_soil) ! hydraulic conductivity [mm h2o/m] + +!-------------------------- Local Variables ---------------------------- + + real(r8) :: & + fg ,&! ground fractional cover [-] + gwat ,&! net water input from top (mm/s) + rnof_roof ,&! total runoff (mm h2o/s) + rnof_gimp ,&! total runoff (mm h2o/s) + rnof_gper ,&! total runoff (mm h2o/s) + rnof_lake ,&! total runoff (mm h2o/s) + rsur_roof ,&! surface runoff (mm h2o/s) + rsur_gimp ,&! surface runoff (mm h2o/s) + rsur_gper ,&! surface runoff (mm h2o/s) + rsur_lake ,&! surface runoff (mm h2o/s) + dfseng ,&! change of lake sensible heat [W/m2] + dfgrnd ! change of lake ground heat flux [W/m2] + + real(r8) :: a, aa, xs1 + +!----------------------------------------------------------------------- + + fg = 1 - froof + dfseng = 0. + dfgrnd = 0. + +!======================================================================= +! [1] for pervious road, the same as soil +!======================================================================= + + rootflux(:) = rootr(:)*etr + + CALL WATER_2014 (ipatch,patchtype,lbp ,nl_soil ,deltim ,& + z_gpersno ,dz_gpersno ,zi_gpersno ,bsw ,porsl ,& + psi0 ,hksati ,theta_r ,fsatmax ,fsatdcf ,& + elvstd ,BVIC ,rootr ,rootflux ,t_gpersno ,& + wliq_gpersno,wice_gpersno,smp ,hk ,pgper_rain ,& + sm_gper ,etr ,qseva_gper ,qsdew_gper ,qsubl_gper ,& + qfros_gper ,& + !NOTE: temporal input, as urban mode doesn't support split soil&snow + ! set all the same for soil and snow surface, + ! and fsno=0. (no physical meaning here) + qseva_gper ,qsdew_gper ,qsubl_gper ,qfros_gper ,& + qseva_gper ,qsdew_gper ,qsubl_gper ,qfros_gper ,& + 0. ,& ! fsno, not active + rsur_gper ,rnof_gper ,qinfl ,pondmx ,ssi ,& + wimp ,smpmin ,zwt ,wdsrf ,wa ,qcharge ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! irrigation variables + qflx_irrig_drip ,qflx_irrig_flood ,qflx_irrig_paddy ) + +!======================================================================= +! [2] for roof and impervious road +!======================================================================= + + IF (lbr >= 1) THEN + gwat = pg_rain + sm_roof - qseva_roof + ELSE + CALL snowwater (lbr,deltim,ssi,wimp,& + pg_rain,qseva_roof,qsdew_roof,qsubl_roof,qfros_roof,& + dz_roofsno(lbr:0),wice_roofsno(lbr:0),wliq_roofsno(lbr:0),gwat) + ENDIF + + wliq_roofsno(1) = wliq_roofsno(1) + gwat*deltim + + ! Renew the ice and liquid mass due to condensation + IF (lbr >= 1) THEN + ! make consistent with how evap_grnd removed in infiltration + wliq_roofsno(1) = max(0., wliq_roofsno(1) + qsdew_roof * deltim) + wice_roofsno(1) = max(0., wice_roofsno(1) + (qfros_roof-qsubl_roof) * deltim) + ENDIF + + ! only consider ponding and surface runoff + ! NOTE: set max ponding depth = 1mm (liq+ice) + xs1 = wliq_roofsno(1) - 1. + IF (xs1 > 0.) THEN + wliq_roofsno(1) = 1. + ELSE + xs1 = 0. + ENDIF + + rsur_roof = xs1 / deltim + rnof_roof = rsur_roof + + ! ================================================ + + IF (lbi >= 1) THEN + gwat = pgimp_rain + sm_gimp - qseva_gimp + ELSE + CALL snowwater (lbi,deltim,ssi,wimp,& + pgimp_rain,qseva_gimp,qsdew_gimp,qsubl_gimp,qfros_gimp,& + dz_gimpsno(lbi:0),wice_gimpsno(lbi:0),wliq_gimpsno(lbi:0),gwat) + ENDIF + + wliq_gimpsno(1) = wliq_gimpsno(1) + gwat*deltim + + ! Renew the ice and liquid mass due to condensation + IF (lbi >= 1) THEN + ! make consistent with how evap_grnd removed in infiltration + wliq_gimpsno(1) = max(0., wliq_gimpsno(1) + qsdew_gimp * deltim) + wice_gimpsno(1) = max(0., wice_gimpsno(1) + (qfros_gimp-qsubl_gimp) * deltim) + ENDIF + + ! only consider ponding and surface runoff + ! NOTE: set max ponding depth = 1mm + xs1 = wliq_gimpsno(1) - 1. + IF (xs1 > 0.) THEN + wliq_gimpsno(1) = 1. + ELSE + xs1 = 0. + ENDIF + + rsur_gimp = xs1 / deltim + rnof_gimp = rsur_gimp + +!======================================================================= +! [3] lake hydrology +!======================================================================= + + CALL snowwater_lake ( DEF_USE_Dynamic_Lake, & + ! "in" snowater_lake arguments + ! --------------------------- + maxsnl ,nl_soil ,nl_lake ,deltim ,& + ssi ,wimp ,porsl ,pg_rain_lake ,& + pg_snow_lake ,dz_lake ,imelt_lake(:0) ,fioldl(:0) ,& + qseva_lake ,qsubl_lake ,qsdew_lake ,qfros_lake ,& + + ! "inout" snowater_lake arguments + ! --------------------------- + z_lakesno ,dz_lakesno ,zi_lakesno ,t_lakesno ,& + wice_lakesno ,wliq_lakesno ,t_lake ,lake_icefrac ,& + gwat ,& + dfseng ,dfgrnd ,snll ,scv_lake ,& + snowdp_lake ,sm_lake ,forc_us ,forc_vs ,& +! SNICAR model variables + forc_aer ,& + mss_bcpho ,mss_bcphi ,mss_ocpho ,mss_ocphi ,& + mss_dst1 ,mss_dst2 ,mss_dst3 ,mss_dst4 ,& +! END SNICAR model variables + urban_call=.true.) + + ! We assume the land water bodies have zero extra liquid water capacity + ! (i.e.,constant capacity), all excess liquid water are put into the runoff, + ! this unreasonable assumption should be updated in the future version + a = (sum(wliq_lakesno(snll+1:))-w_old)/deltim + aa = qseva_lake-(qsubl_lake-qsdew_lake) + rsur_lake = max(0., pg_rain_lake - aa - a) + rnof_lake = rsur_lake + + ! Set zero to the empty node + IF (snll > maxsnl) THEN + wice_lakesno(maxsnl+1:snll) = 0. + wliq_lakesno(maxsnl+1:snll) = 0. + t_lakesno (maxsnl+1:snll) = 0. + z_lakesno (maxsnl+1:snll) = 0. + dz_lakesno (maxsnl+1:snll) = 0. + ENDIF + + fseng = fseng + dfseng*flake + fgrnd = fgrnd + dfgrnd*flake + +!======================================================================= +! [4] surface and total runoff weighted by fractional coverages +!======================================================================= + + ! 10/01/2021, yuan: exclude lake part + rsur = rsur_roof*froof + rsur_gimp*fg*(1-fgper) + rsur_gper*fg*fgper + !rsur = rsur*(1.-flake) + rsur_lake*flake + rnof = rnof_roof*froof + rnof_gimp*fg*(1-fgper) + rnof_gper*fg*fgper + !rnof = rnof*(1.-flake) + rnof_lake*flake + + END SUBROUTINE UrbanHydrology + +END MODULE MOD_Urban_Hydrology +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_ImperviousTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_ImperviousTemperature.F90 new file mode 100644 index 0000000000..b6fdf67f96 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_ImperviousTemperature.F90 @@ -0,0 +1,304 @@ +#include + +MODULE MOD_Urban_ImperviousTemperature +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The main difference between calculating the temperature conduction +! for an impervious ground and a pervious surface lies in the need to +! USE the thermal properties (thermal conductivity and heat capacity) +! of the imperious surface layer instead of the soil thermal +! properties. Additionally, when snow, ice, and water are present, the +! heat capacity of the first impervious surface layer needs to be +! adjusted. The impervious surface does not consider the transmission +! of water below the surface, and the phase change process only +! considers the first impervious surface layer (surface water/ice) and +! the overlying snow cover layer. +! +! Created by Yongjiu Dai and Hua Yuan, 05/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanImperviousTem + +CONTAINS + + SUBROUTINE UrbanImperviousTem (patchtype,lb,deltim, & + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& + cv_gimp,tk_gimp,dz_gimpsno,z_gimpsno,zi_gimpsno,& + t_gimpsno,wice_gimpsno,wliq_gimpsno,scv_gimp,snowdp_gimp,& + lgimp,clgimp,sabgimp,fsengimp,fevpgimp,cgimp,htvp,& + imelt,sm,xmf,fact) + +!======================================================================= +! Snow and impervious road temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of road soil is computed from +! the algorithm of Johansen (as reported by Farouki 1981), impervious +! and pervious from LOOK-UP table and of snow is from the formulation +! used in SNTHERM (Jordan 1991). +! o Boundary conditions: +! F = Rnet - Hg - LEg (top), F = 0 (base of the soil column). +! o Soil / snow temperature is predicted from heat conduction +! in 10 soil layers and up to 5 snow layers. The thermal +! conductivities at the interfaces between two neighbor layers (j,j+1) +! are derived from an assumption that the flux across the interface is +! equal to that from the node j to the interface and the flux from the +! interface to the node j+1. The equation is solved using the +! Crank-Nicholson method and resulted in a tridiagonal system +! equation. +! +! Phase change (see MOD_PhaseChange.F90) +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2020 +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_SoilThermalParameters + USE MOD_PhaseChange, only: meltf_urban + USE MOD_Utils, only: tridia + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor: turn 1st layer T to surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids (1:nl_soil) !thermal conductivity of minerals [W/m-K] + real(r8), intent(in) :: porsl (1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] + + real(r8), intent(in) :: dkdry (1:nl_soil) !thermal conductivity of dry soil [W/m-K] + real(r8), intent(in) :: dksatu (1:nl_soil) !thermal conductivity of sat soil [W/m-K] + real(r8), intent(in) :: dksatf (1:nl_soil) !thermal cond. of sat frozen soil [W/m-K] + + real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric frac of quartz in mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric frac of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric frac of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric frac of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric frac of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric frac of sand + + real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal cond. + real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal cond. + + real(r8), intent(in) :: cv_gimp (1:nl_soil) !heat capacity of urban impervious [J/m3/K] + real(r8), intent(in) :: tk_gimp (1:nl_soil) !thermal cond. of urban impervious [W/m/K] + + real(r8), intent(in) :: dz_gimpsno(lb :nl_soil) !layer thickness [m] + real(r8), intent(in) :: z_gimpsno (lb :nl_soil) !node depth [m] + real(r8), intent(in) :: zi_gimpsno(lb-1:nl_soil) !interface depth [m] + + real(r8), intent(in) :: sabgimp !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: lgimp !atmospheric longwave radiation [W/m2] + real(r8), intent(in) :: clgimp !deriv. of longwave wrt to soil temp [w/m2/k] + real(r8), intent(in) :: fsengimp !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fevpgimp !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: cgimp !deriv. of gimp energy flux to T [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor (or sublimation) [j/kg] + + real(r8), intent(inout) :: t_gimpsno (lb:nl_soil) !soil temperature [K] + real(r8), intent(inout) :: wice_gimpsno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_gimpsno(lb:nl_soil) !liqui water [kg/m2] + real(r8), intent(inout) :: scv_gimp !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp_gimp !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change in soil + real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) cv (lb:nl_soil) !heat capacity [J/(m2 K)] + real(r8) tk (lb:nl_soil) !thermal conductivity [W/(m K)] + + real(r8) hcap(1:nl_soil) !J/(m3 K) + real(r8) thk(lb:nl_soil) !W/(m K) + real(r8) rhosnow !partial density of water (ice + liquid) + + real(r8) at (lb:nl_soil) !"a" vector for tridiagonal matrix + real(r8) bt (lb:nl_soil) !"b" vector for tridiagonal matrix + real(r8) ct (lb:nl_soil) !"c" vector for tridiagonal matrix + real(r8) rt (lb:nl_soil) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_gimpsno_bef(lb:nl_soil) !soil/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + real(r8) brr(lb:nl_soil) !temporary set + + real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil + real(r8) vf_ice (1:nl_soil) !volumetric fraction ice len within soil + + integer i,j + +!----------------------------------------------------------------------- + + wice_gimpsno(2:) = 0.0 !ice lens [kg/m2] + wliq_gimpsno(2:) = 0.0 !liquid water [kg/m2] + +!======================================================================= +! soil ground and wetland heat capacity + DO i = 1, nl_soil + vf_water(i) = wliq_gimpsno(i)/(dz_gimpsno(i)*denh2o) + vf_ice(i) = wice_gimpsno(i)/(dz_gimpsno(i)*denice) + CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& + wf_gravels(i),wf_sand(i),k_solids(i),& + csol(i),dkdry(i),dksatu(i),dksatf(i),& + BA_alpha(i),BA_beta(i),& + t_gimpsno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) + cv(i) = hcap(i)*dz_gimpsno(i) + ENDDO + IF(lb==1 .and. scv_gimp>0.) cv(1) = cv(1) + cpice*scv_gimp + +! Snow heat capacity + IF(lb <= 0)THEN + cv(:0) = cpliq*wliq_gimpsno(:0) + cpice*wice_gimpsno(:0) + ENDIF + +! Snow thermal conductivity + IF(lb <= 0)THEN + DO i = lb, 0 + rhosnow = (wice_gimpsno(i)+wliq_gimpsno(i))/dz_gimpsno(i) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(i) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(i) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(i) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(i) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(i) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(i) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO i = lb, nl_soil-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top soil node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and soil + IF((i==0) .and. (z_gimpsno(i+1)-zi_gimpsno(i) 0.) tk(1:) = tk_gimp(1:) + WHERE (cv_gimp > 0.) cv(1:) = cv_gimp(1:)*dz_gimpsno(1:) + + ! snow exist when there is no snow layer + IF (lb == 1 .and. scv_gimp > 0.0) THEN + cv(1) = cv(1) + cpice*scv_gimp + ENDIF + + ! ponding water or ice exist + cv(1) = cv(1) + cpliq*wliq_gimpsno(1) + cpice*wice_gimpsno(1) + +! net ground heat flux into the surface and its temperature derivative + hs = sabgimp + lgimp - (fsengimp+fevpgimp*htvp) + dhsdT = - cgimp + clgimp + + t_gimpsno_bef(lb:) = t_gimpsno(lb:) + + j = lb + fact(j) = deltim / cv(j) * dz_gimpsno(j) & + / (0.5*(z_gimpsno(j)-zi_gimpsno(j-1)+capr*(z_gimpsno(j+1)-zi_gimpsno(j-1)))) + + DO j = lb + 1, nl_soil + fact(j) = deltim/cv(j) + ENDDO + + DO j = lb, nl_soil - 1 + fn(j) = tk(j)*(t_gimpsno(j+1)-t_gimpsno(j))/(z_gimpsno(j+1)-z_gimpsno(j)) + ENDDO + fn(nl_soil) = 0. + +! set up vector r and vectors a, b, c that define tridiagonal matrix + j = lb + dzp = z_gimpsno(j+1)-z_gimpsno(j) + at(j) = 0. + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp + rt(j) = t_gimpsno(j) + fact(j)*( hs - dhsdT*t_gimpsno(j) + cnfac*fn(j) ) + + + DO j = lb + 1, nl_soil - 1 + dzm = (z_gimpsno(j)-z_gimpsno(j-1)) + dzp = (z_gimpsno(j+1)-z_gimpsno(j)) + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_gimpsno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDDO + + j = nl_soil + dzm = (z_gimpsno(j)-z_gimpsno(j-1)) + at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*tk(j-1)/dzm + ct(j) = 0. + rt(j) = t_gimpsno(j) - cnfac*fact(j)*fn(j-1) + +! solve for t_gimpsno + i = size(at) + CALL tridia (i ,at ,bt ,ct ,rt ,t_gimpsno) + +!======================================================================= +! melting or freezing +!======================================================================= + + DO j = lb, nl_soil - 1 + fn1(j) = tk(j)*(t_gimpsno(j+1)-t_gimpsno(j))/(z_gimpsno(j+1)-z_gimpsno(j)) + ENDDO + fn1(nl_soil) = 0. + + j = lb + brr(j) = cnfac*fn(j) + (1.-cnfac)*fn1(j) + + DO j = lb + 1, nl_soil + brr(j) = cnfac*(fn(j)-fn(j-1)) + (1.-cnfac)*(fn1(j)-fn1(j-1)) + ENDDO + + CALL meltf_urban (lb,1,deltim, & + fact(lb:1),brr(lb:1),hs,dhsdT, & + t_gimpsno_bef(lb:1),t_gimpsno(lb:1), & + wliq_gimpsno(lb:1),wice_gimpsno(lb:1),imelt(lb:1), & + scv_gimp,snowdp_gimp,sm,xmf) + + END SUBROUTINE UrbanImperviousTem + +END MODULE MOD_Urban_ImperviousTemperature +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 new file mode 100644 index 0000000000..1863d32c8f --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LAIReadin.F90 @@ -0,0 +1,83 @@ +#include + +#ifdef URBAN_MODEL +MODULE MOD_Urban_LAIReadin + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanLAI_readin + +CONTAINS + + SUBROUTINE UrbanLAI_readin (year, time, dir_landdata) +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Read in urban LAI, SAI and urban tree cover data. +! +! Create by Hua Yuan, 11/2021 +! +! +! !REVISIONS: +! 08/2023, Wenzong Dong: add codes to read urban tree LAI. +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Namelist + USE MOD_MPAS_MPI + USE MOD_LandUrban + USE MOD_Vars_Global + USE MOD_Const_LC + USE MOD_Vars_TimeVariables + USE MOD_Vars_TimeInvariants + USE MOD_Urban_Vars_TimeInvariants + USE MOD_NetCDFVector + USE MOD_UserDefFun +#ifdef SinglePoint + USE MOD_SingleSrfdata +#endif + + IMPLICIT NONE + + integer, intent(in) :: year + integer, intent(in) :: time + character(len=256), intent(in) :: dir_landdata + + character(len=256) :: lndname + character(len=256) :: cyear, ctime + integer :: u, npatch, iyear + + ! READ in Leaf area index and stem area index + write(ctime,'(i2.2)') time + write(cyear,'(i4.4)') min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year) ) + +#ifdef SinglePoint + iyear = findloc_ud(SITE_LAI_year == min(DEF_LAI_END_YEAR, max(DEF_LAI_START_YEAR,year)) ) + urb_lai(:) = SITE_LAI_monthly(time,iyear) + urb_sai(:) = SITE_SAI_monthly(time,iyear) +#else + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LAI/urban_LAI_'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'TREE_LAI', landurban, urb_lai) + + lndname = trim(dir_landdata)//'/urban/'//trim(cyear)//'/LAI/urban_SAI_'//trim(ctime)//'.nc' + CALL ncio_read_vector (lndname, 'TREE_SAI', landurban, urb_sai) +#endif + ! loop for urban patch to assign fraction of green leaf + IF (.true.) THEN + DO u = 1, numurban + npatch = urban2patch(u) + tlai(npatch) = urb_lai(u) + tsai(npatch) = urb_sai(u) + urb_green(u) = 1. !TODO: usage? fraction of green leaf + green(npatch)= 1. !fraction of green leaf + ENDDO + ENDIF + + END SUBROUTINE UrbanLAI_readin + +END MODULE MOD_Urban_LAIReadin +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LUCY.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LUCY.F90 new file mode 100644 index 0000000000..a07505998b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_LUCY.F90 @@ -0,0 +1,181 @@ +#include + +MODULE MOD_Urban_LUCY +! ----------------------------------------------------------------------- +! !DESCRIPTION: +! Anthropogenic model to calculate anthropogenic heat flux for the rest +! +! Original: Wenzong Dong, May, 2022 +! +! ----------------------------------------------------------------------- +! !USE + USE MOD_Precision + USE MOD_TimeManager + USE MOD_Namelist + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_TimeManager + IMPLICIT NONE + SAVE + PUBLIC :: LUCY + +CONTAINS + + SUBROUTINE LUCY( idate , deltim , patchlonr, fix_holiday, & + week_holiday, hum_prof, wdh_prof , weh_prof , pop_den, & + vehicle , Fahe , vehc , meta ) + +! ----------------------------------------------------------------------- +! !DESCRIPTION: +! Anthropogenic heat fluxes other than building heat were calculated +! +! !REFERENCES: +! 1) Grimmond, C. S. B. (1992). The suburban energy balance: +! Methodological considerations and results for a mid-latitude west +! coast city under winter and spring conditions. International Journal +! of Climatology, 12(5), 481-497. https://doi.org/10.1002/joc.3370120506 +! +! 2) Allen, L., Lindberg, F., & Grimmond, C. S. B. (2011). Global to +! city scale urban anthropogenic heat flux: Model and variability. +! International Journal of Climatology, 31(13), 1990-2005. +! https://doi.org/10.1002/joc.2210 +! +! ----------------------------------------------------------------------- + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: & + idate(3) ! calendar (year, julian day, seconds) + + real(r8), intent(in) :: & + fix_holiday(365) ,&! Fixed public holidays, holiday(0) or workday(1) + week_holiday(7) ! week holidays + + real(r8), intent(in) :: & + deltim ,&! seconds in a time step [second] + patchlonr ,&! longitude of patch [radian] + hum_prof(24) ,&! Diurnal metabolic heat profile [W/person] + wdh_prof(24) ,&! Diurnal traffic flow profile of weekday + weh_prof(24) ,&! Diurnal traffic flow profile of weekend + pop_den ,&! population density [person per square kilometer] + vehicle(3) ! vehicle numbers per thousand people + + real(r8) :: & + vehc_prof(24,2) ,&! + carscell ,&! cars numbers per thousand people + frescell ,&! freights numbers per thousand people + mbkscell ! motobikes numbers per thousand people + + real(r8), intent(out) :: & + Fahe ,&! flux from metabolic and vehicle + vehc ,&! flux from vehicle + meta ! flux from metabolic + + real(r8) :: & + londeg ,&! longitude of path [degree] + car_sp ,&! distance traveled [km] + traf_frac ,&! vehicle heat profile of hour [-] + meta_prof ,&! metabolic heat profile of hour [-] + carflx ,&! flux from car [W/m2] + motflx ,&! flux from motorbike [W/m2] + freflx ! flux from freight [W/m2] + +!-------------------------- Local Variables ---------------------------- + real(r8):: ldate(3) ! local time (year, julian day, seconds) + integer :: & + iweek ,&! day of week + ihour ,&! hour of day + day ,&! day of month + month ,&! month of year + day_inx ,&! holiday index, day=1(workday), day=1(holiday) + EC ,&! emission factor of car [J/m] + EF ,&! emission factor of freight [J/m] + EM ! emission factor of motorbike [J/m] + +!----------------------------------------------------------------------- + + ! initialization + meta = 0. + vehc = 0. + Fahe = 0. + + ! set vehicle distance traveled + car_sp = 50 + + ! emission factor Sailor and Lu (2004), + ! all vehicle are set to same value + EC = 3975 + EM = 3975 + EF = 3975 + + IF (DEF_simulation_time%greenwich) THEN + ! convert GMT time to local time + londeg = patchlonr*180/PI + CALL gmt2local(idate, londeg, ldate) + ENDIF + + vehc_prof(:,1) = wdh_prof + vehc_prof(:,2) = weh_prof + + CALL julian2monthday(int(ldate(1)), int(ldate(2)), month, day) + CALL timeweek(int(ldate(1)), month, day, iweek) + + ihour = CEILING(ldate(3)*1./3600) + + IF (day==366) day=365 + IF (fix_holiday(day)==0 .or. week_holiday(iweek)==0) THEN + day_inx = 1 + ELSE + day_inx = 2 + ENDIF + + ! set traffic flow to be used of this time step + traf_frac = vehc_prof(ihour,day_inx) + ! set heat release per people of this time step + meta_prof = hum_prof (ihour) + + carscell = vehicle(1) + mbkscell = vehicle(2) + frescell = vehicle(3) + + ! heat release of metabolism [W/m2] + meta = pop_den*meta_prof/1e6 + ! heat release of cars [W/m2] + IF (carscell > 0) THEN + carflx = carscell*pop_den/1000 + carflx = carflx*traf_frac & + *EC*(car_sp*1000)/1e6 + carflx = carflx/3600 + ELSE + carflx = 0. + ENDIF + + ! heat release of motorbikes [W/m2] + IF (mbkscell > 0) THEN + motflx = mbkscell*pop_den/1000 + motflx = motflx*traf_frac & + *EM*(car_sp*1000)/1e6 + motflx = motflx/3600 + ELSE + motflx = 0. + ENDIF + + ! heat release of freight [W/m2] + IF (frescell > 0)THEN + freflx = frescell*pop_den/1000 + freflx = freflx*traf_frac & + *EF*(car_sp*1000)/1e6 + freflx = freflx/3600 + ELSE + freflx = 0. + ENDIF + + ! total vehicle heat flux + vehc = carflx + motflx + freflx + ! total anthropogenic heat flux exclude building part + Fahe = meta + vehc + + END Subroutine LUCY + +END MODULE MOD_Urban_LUCY +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Longwave.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Longwave.F90 new file mode 100644 index 0000000000..760774abef --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Longwave.F90 @@ -0,0 +1,678 @@ +#include + +MODULE MOD_Urban_Longwave + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical, only: stefnc + USE MOD_Urban_Shortwave, only: MatrixInverse + USE MOD_Urban_Shortwave, only: ShadowWall_dir + USE MOD_Urban_Shortwave, only: ShadowWall_dif + USE MOD_Urban_Shortwave, only: ShadowTree + USE MOD_3DCanopyRadiation, only: tee, phi + + IMPLICIT NONE + SAVE + PRIVATE + + PUBLIC :: UrbanOnlyLongwave !Urban Longwave radiation transfer + PUBLIC :: UrbanVegLongwave !Urban Longwave radiation transfer with trees + +CONTAINS + + SUBROUTINE UrbanOnlyLongwave (theta, HL, fb, fgper, H, LW, & + twsun, twsha, tgimp, tgper, ewall, egimp, egper, & + Ainv, B, B1, dBdT, SkyVF, fcover) + +!----------------------------------------------------------------------- +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++| ______ +! |++++++| |++++++| +! ______+++++| |++++++| +! |++++++|++++| |++++++| +! sunlit |[]++[]|++++| |++++++| shaded +! wall |++++++| |++++++| wall +! |[]++[]| |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|____________________________________ +! +! +! !DESCRIPTION: +! +! The process of long-wave radiation transmission in the absence of +! vegetation is similar to the incident diffuse case of short-wave +! radiation transmission in the absence of vegetation (where long-wave +! radiation is approximated as a diffuse source). The long-wave +! radiation flux reaching each component surface is calculated, as well +! as the long-wave radiation emitted outward from each component +! surface. Multiple scattering and absorption between components are +! considered, and a long-wave radiation transmission equilibrium +! equation is established for solving. +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + theta, &! Sun zenith angle [radian] + HL, &! Ratio of building height to ground width [-] + fb, &! Fraction of building area [-] + fgper, &! Fraction of impervious ground [-] + H, &! Building average height [m] + LW, &! Downward longwave radiation [W/m2] + + twsun, &! Temperature of sunlit wall [K] + twsha, &! Temperature of shaded wall [K] + tgimp, &! Temperature of impervious road [K] + tgper, &! Temperature of pervious road [K] + + ewall, &! Emissivity of walls [-] + egimp, &! Emissivity of ground [-] + egper ! Emissivity of ground [-] + + real(r8), intent(out) :: & + Ainv(4,4), &! Inverse of Radiation transfer matrix + B(4), &! Vectors of incident radiation on each surface + B1(4), &! Vectors of incident radiation on each surface + dBdT(4), &! Vectors of incident radiation on each surface + SkyVF(4), &! View factor to sky + fcover(0:4) ! View factor to sky + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + W, &! Urban ground average width [m] + L, &! Urban building average length [m] + HW, &! Ratio of H to W, H/W [-] + fg, &! Fraction of ground [-] + fgimp, &! Fraction of snow ground [-] + + Fsw, &! View factor from sky to wall [-] + Fsg, &! View factor from sky to ground [-] + Fgw, &! View factor from ground to wall [-] + Fgs, &! View factor from ground to sky [-] + Fww, &! View factor from wall to wall [-] + Fwg, &! View factor from wall to ground [-] + Fws, &! View factor from wall to sky [-] + + Sw, &! Shadow of wall [-] + fwsun, &! Fraction of sunlit wall [-] + fwsha, &! Fraction of shaded wall [-] + Iwsun, &! Incident radiation on sunlit wall [W/m2] + Iwsha, &! Incident radiation on shaded wall [W/m2] + Ig, &! Incident radiation on ground [W/m2] + Igimp, &! Incident radiation on impervious ground [W/m2] + Igper ! Incident radiation on pervious ground [W/m2] + + real(r8) :: A(4,4) !Radiation transfer matrix + + ! Temporal + real(r8) :: tmp, eb +!----------------------------------------------------------------------- + + ! Calculate urban structure parameters + !------------------------------------------------- + !W = H/HW + !L = W*sqrt(fb)/(1-sqrt(fb)) + !HL = H/L !NOTE: Same as HL = HW*(1-sqrt(fb))/sqrt(fb) + fg = 1. - fb + fgimp = 1. - fgper + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L/L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + ! Adjusted as below: + Fws = Fsw*fg/fb/(4*HL) + Fwg = Fsw*fg/fb/(4*HL) + Fww = 1 - Fws - Fwg + + ! Calculate sunlit wall fraction + !------------------------------------------------- + + ! Building shadow on the ground + Sw = ShadowWall_dir(fb/fg, HL, theta) + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + ! o A: radiation transfer matrix + ! o B: incident radiation on each surface + ! o X: radiation emit from each surface + !------------------------------------------------- + A(1,:) = (/1-Fww*fwsun*(1-ewall), -Fww*fwsun*(1-ewall), & + -Fgw*fwsun*(1-ewall), -Fgw*fwsun*(1-ewall) /) + + A(2,:) = (/ -Fww*fwsha*(1-ewall), 1-Fww*fwsha*(1-ewall), & + -Fgw*fwsha*(1-ewall), -Fgw*fwsha*(1-ewall) /) + + A(3,:) = (/ -Fwg*fgimp*(1-egimp), -Fwg*fgimp*(1-egimp), & + 1._r8, 0._r8 /) + + A(4,:) = (/ -Fwg*fgper*(1-egper), -Fwg*fgper*(1-egper), & + 0._r8, 1._r8 /) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Incident LW radiation on sunlit/shaded wall and + ! impervious/pervious ground + Iwsun = LW*Fsw*fwsun + Iwsha = LW*Fsw*fwsha + Ig = LW*Fsg + Igimp = Ig*fgimp + Igper = Ig*fgper + + ! Vector of initial LW radiation on each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + B(1) = Iwsun*(1.-ewall) + 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B(2) = Iwsha*(1.-ewall) + 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + !B(1) = Iwsun*(1.-ewall) + 2*fwsun*HW*stefnc*ewall*twsun**4 + !B(2) = Iwsha*(1.-ewall) + 2*fwsha*HW*stefnc*ewall*twsha**4 + B(3) = Igimp*(1.-egimp) + fgimp*stefnc*egimp*tgimp**4 + B(4) = Igper*(1.-egper) + fgper*stefnc*egper*tgper**4 + + B1(1) = 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B1(2) = 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + !B1(1) = 2*fwsun*HW*stefnc*ewall*twsun**4 + !B1(2) = 2*fwsha*HW*stefnc*ewall*twsha**4 + B1(3) = fgimp*stefnc*egimp*tgimp**4 + B1(4) = fgper*stefnc*egper*tgper**4 + + dBdT(1) = 16*fwsun*HL*fb/fg*stefnc*ewall*twsun**3 + dBdT(2) = 16*fwsha*HL*fb/fg*stefnc*ewall*twsha**3 + !dBdT(1) = 2*fwsun*HW*stefnc*ewall*twsun**3 + !dBdT(2) = 2*fwsha*HW*stefnc*ewall*twsha**3 + dBdT(3) = 4*fgimp*stefnc*egimp*tgimp**3 + dBdT(4) = 4*fgper*stefnc*egper*tgper**3 + + SkyVF(1:2) = Fws + SkyVF(3:4) = Fgs + + fcover(0) = fb + fcover(1) = 4*fwsun*HL*fb + fcover(2) = 4*fwsha*HL*fb + fcover(3) = fg*fgimp + fcover(4) = fg*fgper + + !NOTE: the below codes put into the THERMAL.F90 + ! Equation solve + ! X = matmul(Ainv, B) + + ! LW radiation absorption by each surface (per m^2) + !lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) !/ fgimp + !lgper = ( egper*X(4) - B1(4) ) / (1-egper) !/ fgper + + ! Out-going LW of urban canopy + !lout = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs + !lout = sum( X * SkyVF ) + + ! Energy balance check + !eb = lwsun + lwsha + lgimp + lgper + lout + + !IF (abs(eb-LW) > 1e-6) THEN + ! print *, "Longwave - Energy Balance Check error!", eb-LW + !ENDIF + + !NOTE: put it outside, after temperature change of roof, wall and ground + ! absorption change due to temperature change, as restart variables. + !dX = matmul(Ainv, dBdT*dT) + !lwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) !/ fgimp + !lgper = ( egper*dX(4) - dBdT(4)*dT(4) ) / (1-egper) !/ fgper + + !lout = lout + sum( dX * SkyVF ) + + END SUBROUTINE UrbanOnlyLongwave + + + SUBROUTINE UrbanVegLongwave (theta, HL, fb, fgper, H, LW, & + twsun, twsha, tgimp, tgper, ewall, egimp, egper, lai, sai, fv, hv, & + ev, Ainv, B, B1, dBdT, SkyVF, VegVF, fcover) + +!----------------------------------------------------------------------- +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++| ______ +! |++++++| ___ |++++++| +! ______+++++| ||||| |++++++| +! |++++++|++++| ||||||| |++++++| +! sunlit |[]++[]|++++| ||||| |++++++| shaded +! wall |++++++| | tree |++++++| wall +! |[]++[]| | |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|___________________________________ +! +! !DESCRIPTION: +! +! The calculation of longwave radiation when considering vegetation +! (trees only) is similar to the shortwave radiation transmission with +! vegetation. On the basis of the longwave radiation transmission +! balance equation without vegetation, a balanced equation with +! vegetation is constructed, and the solution process is similar. +! +! Created by Hua Yuan, 09/2021 +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + theta, &! Sun zenith angle [radian] + HL, &! Ratio of building height to ground width [-] + fb, &! Fraction of building area [-] + fgper, &! Fraction of impervious ground [-] + H, &! Building average height [m] + LW, &! Downward longwave radiation [W/m2] + + twsun, &! Temperature of sunlit wall [K] + twsha, &! Temperature of shaded wall [K] + tgimp, &! Temperature of impervious road [K] + tgper, &! Temperature of pervious road [K] + + ewall, &! Emissivity of walls [-] + egimp, &! Emissivity of ground [-] + egper, &! Emissivity of ground [-] + lai, &! leaf area index [m2/m2] + sai, &! stem area index [m2/m2] + fv, &! Fraction of tree cover [-] + hv ! Crown central height [m] + + real(r8), intent(out) :: & + ev, &! emissivity of vegetation + Ainv(5,5), &! Inverse of Radiation transfer matrix + B(5), &! Vectors of incident radiation on each surface + B1(5), &! Vectors of incident radiation on each surface + dBdT(5), &! Vectors of incident radiation on each surface + SkyVF(5), &! View factor to sky + VegVF(5), &! View factor to sky + fcover(0:5) ! View factor to sky + +!-------------------------- Local Variables ---------------------------- + real(r16),parameter :: DD1=1.0_r16 !quad accuracy real number + + real(r8) :: & + W, &! Urban ground average width [m] + L, &! Urban building average length [m] + HW, &! Ratio of H to W, H/W [-] + fg, &! Fraction of ground [-] + fgimp, &! Fraction of pervious ground [-] + + Fsw, &! View factor from sky to wall [-] + Fsg, &! View factor from sky to ground [-] + Fgw, &! View factor from ground to wall [-] + Fgs, &! View factor from ground to sky [-] + Fww, &! View factor from wall to wall [-] + Fwg, &! View factor from wall to ground [-] + Fws, &! View factor from wall to sky [-] + + Fvg, &! View factor from tree to ground [-] + Fvs, &! View factor from tree to sky [-] + Fvw, &! View factor from tree to walls (sunlit+shaded) [-] + Fwv, &! View factor from wall to tree [-] + Fgv, &! View factor from ground to tree [-] + Fsv, &! View factor from sky to tree [-] + + Fgvs, &! View factor from ground->|tree|-> to sky [-] + Fgvw, &! View factor from ground->|tree|-> to walls [-] + Fsvg, &! View factor from sky->|tree|-> to ground [-] + Fsvw, &! View factor from sky->|tree|-> to walls [-] + Fwvw, &! View factor from walls->|tree|-> to walls [-] + Fwvs, &! View factor from walls->|tree|-> to sky [-] + Fwvg, &! View factor from walls->|tree|-> to ground [-] + + Fsw_, &! Fsw - Fsvw + Fsvw*Td [-] + Fsg_, &! Fsg - Fsvg + Fsvg*Td [-] + Fgw_, &! Fgw - Fgvw + Fgvw*Td [-] + Fgs_, &! Fgs - Fgvs + Fgvs*Td [-] + Fwg_, &! Fwg - Fwvg + Fwvg*Td [-] + Fww_, &! Fww - Fwvw + Fwvw*Td [-] + Fws_, &! Fws - Fwvs + Fwvs*Td [-] + + Sw, &! Shadow of wall [-] + Sw_, &! Shadow of wall [-] + Sv, &! Shadow of trees [-] + Swv, &! Overlapped shadow between wall and trees [-] + fv_, &! Fraction of trees [-] + Td, &! Transmission of tree [-] + fwsun, &! Fraction of sunlit wall [-] + fwsha, &! Fraction of shaded wall [-] + Iwsun, &! Incident radiation on sunlit wall [W/m2] + Iwsha, &! Incident radiation on shaded wall [W/m2] + Ig, &! Incident radiation on ground [W/m2] + Igimp, &! Incident radiation on impervious ground [W/m2] + Igper, &! Incident radiation on pervious ground [W/m2] + Iv ! Incident radiation on trees [W/m2] + + ! Radiation transfer matrix and vectors + !------------------------------------------------- + real(r8) :: A(5,5) !Radiation transfer matrix + + ! Temporal + real(r8) :: tmp, eb, fac1, fac2, lsai +!----------------------------------------------------------------------- + + ! Calculate urban structure parameters + !------------------------------------------------- + !W = H/HW + !L = W*sqrt(fb)/(1-sqrt(fb)) + !HL = H/L !NOTE: Same as HL = HW*(1-sqrt(fb))/sqrt(fb) + L = H/HL + fg = 1. - fb + + fgimp = 1. - fgper + + ! Calculate transmission and albedo of tree + !------------------------------------------------- + lsai = (lai+sai)*fv/cos(PI/3)/ShadowTree(fv, PI/3) + Td = tee(DD1*3/8.*lsai) + ev = 1 - Td + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L*L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + Fws = Fsw*fg/fb/(4*HL) + Fwg = Fsw*fg/fb/(4*HL) + Fww = 1 - Fws - Fwg + + ! View factor from tree to walls, ground and sky + !------------------------------------------------- + + Sw = ShadowWall_dif(fb/fg, HL) + Sw_ = ShadowWall_dif(fb/fg, (H-hv)/L) + + !NOTE: fg*(fv/fg - fv/fg * Sw_) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to ground only) + Swv = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sw+Sv-Swv > 1) THEN + Swv = Sw+Sv-1 + ENDIF + + ! Calibrated building ground shadow + Fsv = Sv + Fsvw = Swv + Fsvg = Fsv - Fsvw + + ! View factor from veg to sky and walls above canopy + Fvs = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + + Sw_ = ShadowWall_dif(fb/fg, hv/L) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to ground only) + Swv = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sw+Sv-Swv > 1) THEN + Swv = Sw+Sv-1 + ENDIF + + ! Calibrated building ground shadow + Fgv = Sv + Fgvw = Swv + Fgvs = Fgv - Fgvw + + ! View factor from veg to sky and walls below+above canopy + Fvg = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + Fvw + + Fvw = 1 - Fvs - Fvg + + !Fvs = Fsv*fg/min(4*fv,2*fg) + !Fvg = Fgv*fg/min(4*fv,2*fg) + !Fvw = 1 - Fvs - Fvg + + ! Canopy mode: + Fwv = max(fv,0.5*(Fsv+Fgv))*2*fg*Fvw/(4*HL*fb) + Fwv = min(0.8, Fwv) + + fac1 = 1.*hv/H + fac2 = 1.*(H-hv)/H + Fwvw = Fwv/(1 + Fws*fac1/Fww + Fwg*fac2/Fww) + Fwvs = Fws*fac1/Fww*Fwvw + Fwvg = Fwg*fac2/Fww*Fwvw + + ! set upper limit + Fwvw = min(Fww, Fwvw) + Fwvs = min(Fws, Fwvs) + Fwvg = min(Fwg, Fwvg) + + Fwv = Fwvw + Fwvs + Fwvg + + ! View factors with trees + !--------------------------------------------------------- + Fsw_ = Fsw - Fsvw + Fsvw*Td + Fsg_ = Fsg - Fsvg + Fsvg*Td + Fgw_ = Fgw - Fgvw + Fgvw*Td + Fgs_ = Fgs - Fgvs + Fgvs*Td + Fwg_ = Fwg - Fwvg + Fwvg*Td + Fww_ = Fww - Fwvw + Fwvw*Td + Fws_ = Fws - Fwvs + Fwvs*Td + + ! Calculate wall sunlit fraction + !------------------------------------------------- + + ! Building wall shadow + Sw = ShadowWall_dir(fb/fg, HL, theta) + + Sw_ = Sw; fv_ = fv; + + Sw_ = ShadowWall_dir(fb/fg, (H-hv)/L, theta) + fv_ = fv - fv*Sw_ + + ! Tree shadow (to all area) + Sv = ShadowTree(fv_, theta) + + ! Overlapped shadow between tree and building + ! (to ground only) + Swv = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sw+Sv-Swv > 1) THEN + Swv = Sw+Sv-1 + ENDIF + + ! Calibrated building ground shadow + Sw = Sw - Swv + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg+fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + !------------------------------------------------- + A(1,:) = (/1-Fww_*fwsun*(1-ewall), -Fww_*fwsun*(1-ewall), -Fgw_*fwsun*(1-ewall), & + -Fgw_*fwsun*(1-ewall), -Fvw *fwsun*(1-ewall) /) + + A(2,:) = (/ -Fww_*fwsha*(1-ewall), 1-Fww_*fwsha*(1-ewall), -Fgw_*fwsha*(1-ewall), & + -Fgw_*fwsha*(1-ewall), -Fvw *fwsha*(1-ewall) /) + + A(3,:) = (/ -Fwg_*fgimp*(1-egimp), -Fwg_*fgimp*(1-egimp), 1._r8, & + 0._r8, -Fvg *fgimp*(1-egimp) /) + + A(4,:) = (/ -Fwg_*fgper*(1-egper), -Fwg_*fgper*(1-egper), 0._r8, & + 1._r8, -Fvg *fgper*(1-egper) /) + + A(5,:) = (/ 0._r8, 0._r8, 0._r8, & + 0._r8, 1._r8 /) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Incident LW radiation on sunlit/shaded wall and + ! impervious/pervious ground + Iwsun = LW*Fsw_*fwsun + Iwsha = LW*Fsw_*fwsha + Ig = LW*Fsg_ + Igimp = Ig*fgimp + Igper = Ig*fgper + Iv = LW*Fsv + + ! Vector of initial LW radiation on each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + B(1) = Iwsun*(1.-ewall) + 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B(2) = Iwsha*(1.-ewall) + 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + B(3) = Igimp*(1.-egimp) + fgimp*stefnc*egimp*tgimp**4 + B(4) = Igper*(1.-egper) + fgper*stefnc*egper*tgper**4 + ! leaf temperature iteration in urban flux calculation + ! see MOD_Urban_Flux.F90 + ! B(5) = 4*fv/fg*stefnc*ev*tl**4 !NOTE: 4*fv/fg or 2*fv/fg + !4*fv/fg. equivalent to 2fc + B(5) = max(2*fv/fg,Fsv+Fgv)*stefnc*ev + + B1(1) = 4*fwsun*HL*fb/fg*stefnc*ewall*twsun**4 + B1(2) = 4*fwsha*HL*fb/fg*stefnc*ewall*twsha**4 + B1(3) = fgimp*stefnc*egimp*tgimp**4 + B1(4) = fgper*stefnc*egper*tgper**4 + ! leaf temperature iteration in urban flux calculation + ! B1(5) = 4*fv/fg*stefnc*ev*tl**4 + B1(5) = max(2*fv/fg,Fsv+Fgv)*stefnc*ev + + dBdT(1) = 16*fwsun*HL*fb/fg*stefnc*ewall*twsun**3 + dBdT(2) = 16*fwsha*HL*fb/fg*stefnc*ewall*twsha**3 + dBdT(3) = 4*fgimp*stefnc*egimp*tgimp**3 + dBdT(4) = 4*fgper*stefnc*egper*tgper**3 + ! leaf temperature iteration in urban flux calculation + ! dBdT(5) = 16*fv/fg*stefnc*ev*tl**3 + dBdT(5) = 4*max(2*fv/fg,Fsv+Fgv)*stefnc*ev + + SkyVF(1:2) = Fws_ + SkyVF(3:4) = Fgs_ + SkyVF(5) = Fvs + + VegVF(1:2) = Fwv + VegVF(3:4) = Fgv + VegVF(5) = Fsv + + fcover(0) = fb + fcover(1) = 4*fwsun*HL*fb + fcover(2) = 4*fwsha*HL*fb + fcover(3) = fg*fgimp + fcover(4) = fg*fgper + fcover(5) = fv + + !NOTE: the below codes are put in the leaf temperature iteration process + ! after each iteration, update the below iterms + !B(5) = 4*fv/fg*stefnc*ev*tl**4 + !B1(5) = 4*fv/fg*stefnc*ev*tl**4 + !dBdT(5) = 16*fv/fg*stefnc*ev*tl**3 + ! Equation solve + !X = matmul(Ainv, B) + + ! LW radiation absorption by each surface (per m^2) + !lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) !/ fgimp + !lgper = ( egper*X(4) - B1(4) ) / (1-egper) !/ fgper + + !NOTE: before leaf temperature iteration + !lv = ((X(1)*Fwv + X(2)*Fwv + X(3)*Fgv + X(4)*Fgv + LW*Fsv)*ev - B1(5))!/(fv/fg) + + ! Out-going LW of urban canopy + !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs + !lout = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + !lout = sum( X * SkyVF ) + + ! Energy balance check + !eb = lwsun + lwsha + lgimp + lgper + lv + lout + + !IF (abs(eb-LW) > 1e-6) THEN + ! print *, "Longwave tree - Energy Balance Check error!", eb-LW + !ENDIF + + ! Radiation difference due to the last temperature change of the leaf + ! dBdT: the first 4 iterms is 0 + !dX = matmul(Ainv, dBdT) + ! Finally solve the first 4 items, the leaf has been solved + !lwsun = lwsun + ( ewall*dX(1) ) / (1-ewall) * dtl!/ (4*fwsun*HL*fb/fg) + !lwsha = lwsha + ( ewall*dX(2) ) / (1-ewall) * dtl!/ (4*fwsha*HL*fb/fg) + !lgimp = lwimp + ( egimp*dX(3) ) / (1-egimp) * dtl!/ fgimp + !lgper = lgper + ( egper*dX(4) ) / (1-egper) * dtl!/ fgper + + ! update after each temperature iteration + !lv = lv + ((dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv)*ev - dBdT(5))*dtl!/(fv/fg) + !dlvdt = (dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv)*ev - dBdT(5) + + !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs + !lout = lout + sum( dX * SkyVF * dtl ) + + ! put it outside + ! absorption change due to temperature change, as restart variables. + ! now the leaf temperature does not change, the last iterm of dBdT is 0. + !dX = matmul(Ainv, dBdT*dT) + + !lwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) !/ (4*fwsun*HL*fb/fg) + !lwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) !/ (4*fwsha*HL*fb/fg) + !lgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) !/ fgimp + !lgper = ( esnow*dX(4) - dBdT(4)*dT(4) ) / (1-esnow) !/ fgper + !lv = ((dX(1)*Fwv + dX(2)*Fwv + dX(3)*Fgv + dX(4)*Fgv + dX(5)*Fgv)*ev)!/(fv/fg) + + !lout = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + !SkyVF(1:2) = Fws_; SkyVF(3:4) = Fgs_; SkyVF(5) = Fvs + !lout = lout + sum( dX * SkyVF ) + + END SUBROUTINE UrbanVegLongwave + +END MODULE MOD_Urban_Longwave +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_NetSolar.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_NetSolar.F90 new file mode 100644 index 0000000000..2992510f3a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_NetSolar.F90 @@ -0,0 +1,184 @@ +#include + +MODULE MOD_Urban_NetSolar + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: netsolar_urban + +CONTAINS + + SUBROUTINE netsolar_urban (ipatch,idate,dlon,deltim,& + forc_sols,forc_soll,forc_solsd,forc_solld,lai,sai,rho,tau,& + alb,ssun,ssha,sroof,swsun,swsha,sgimp,sgper,slake,& + sr,sabv,par,sabroof,sabwsun,sabwsha,sabgimp,sabgper,sablake,& + solvd,solvi,solnd,solni,srvd,srvi,srnd,srni,& + solvdln,solviln,solndln,solniln,srvdln,srviln,srndln,srniln) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! Net solar absorbed by urban surface. +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_TimeManager, only: isgreenwich + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: ipatch ! patch index + integer, intent(in) :: idate(3) ! model time + + real(r8), intent(in) :: dlon ! longitude in radians + real(r8), intent(in) :: deltim ! seconds in a time step [second] + + real(r8), intent(in) :: & + forc_sols, &! atm vis direct beam solar rad onto srf [W/m2] + forc_soll, &! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd, &! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ! atm nir diffuse solar rad onto srf [W/m2] + + real(r8), intent(in) :: & + lai, &! leaf area index + sai, &! stem area index + rho(2,2), &! leaf reflectance (iw=iband, il=life and dead) + tau(2,2) ! leaf transmittance (iw=iband, il=life and dead) + + real(r8), dimension(1:2,1:2), intent(in) :: & + alb, &! averaged albedo [-] + ssun, &! sunlit canopy absorption for solar radiation + ssha, &! shaded canopy absorption for solar radiation + sroof, &! roof absorption for solar radiation + swsun, &! sunlit wall absorption for solar radiation + swsha, &! shaded wall absorption for solar radiation + sgimp, &! impervious ground absorption for solar radiation + sgper, &! pervious ground absorption for solar radiation + slake ! lake absorption for solar radiation + + + real(r8), intent(out) :: & + sr, &! total reflected solar radiation (W/m2) + par, &! PAR absorbed by sunlit vegetation [W/m2] + sabv, &! solar absorbed by sunlit vegetation [W/m2] + sabroof, &! roof absorbed solar radiation (W/m2) + sabwsun, &! sunlit wall absorbed solar radiation (W/m2) + sabwsha, &! shaded wall absorbed solar radiation (W/m2) + sabgimp, &! impervious ground absorbed solar radiation (W/m2) + sabgper, &! pervious ground absorbed solar radiation (W/m2) + sablake, &! solar absorbed by ground [W/m2] + solvd, &! incident direct beam vis solar radiation (W/m2) + solvi, &! incident diffuse beam vis solar radiation (W/m2) + solnd, &! incident direct beam nir solar radiation (W/m2) + solni, &! incident diffuse beam nir solar radiation (W/m2) + srvd, &! reflected direct beam vis solar radiation (W/m2) + srvi, &! reflected diffuse beam vis solar radiation (W/m2) + srnd, &! reflected direct beam nir solar radiation (W/m2) + srni, &! reflected diffuse beam nir solar radiation (W/m2) + solvdln, &! incident direct beam vis solar radiation at local noon(W/m2) + solviln, &! incident diffuse beam vis solar radiation at local noon(W/m2) + solndln, &! incident direct beam nir solar radiation at local noon(W/m2) + solniln, &! incident diffuse beam nir solar radiation at local noon(W/m2) + srvdln, &! reflected direct beam vis solar radiation at local noon(W/m2) + srviln, &! reflected diffuse beam vis solar radiation at local noon(W/m2) + srndln, &! reflected direct beam nir solar radiation at local noon(W/m2) + srniln ! reflected diffuse beam nir solar radiation at local noon(W/m2) + +!-------------------------- Local Variables ---------------------------- + integer :: local_secs + real(r8) :: radpsec + +!----------------------------------------------------------------------- + + sabroof = 0. + sabwsun = 0. + sabwsha = 0. + sabgimp = 0. + sabgper = 0. + sablake = 0. + sabv = 0. + par = 0. + + IF (forc_sols+forc_soll+forc_solsd+forc_solld > 0.) THEN + + sabroof = forc_sols *sroof(1,1) + forc_soll *sroof(2,1) & + + forc_solsd*sroof(1,2) + forc_solld*sroof(2,2) + + sabwsun = forc_sols *swsun(1,1) + forc_soll *swsun(2,1) & + + forc_solsd*swsun(1,2) + forc_solld*swsun(2,2) + + sabwsha = forc_sols *swsha(1,1) + forc_soll *swsha(2,1) & + + forc_solsd*swsha(1,2) + forc_solld*swsha(2,2) + + sabgimp = forc_sols *sgimp(1,1) + forc_soll *sgimp(2,1) & + + forc_solsd*sgimp(1,2) + forc_solld*sgimp(2,2) + + sabgper = forc_sols *sgper(1,1) + forc_soll *sgper(2,1) & + + forc_solsd*sgper(1,2) + forc_solld*sgper(2,2) + + sabv = forc_sols *ssun (1,1) + forc_soll *ssun (2,1) & + + forc_solsd*ssun (1,2) + forc_solld*ssun (2,2) + + par = forc_sols *ssun (1,1) + forc_solsd*ssun (1,2) + + ! LAI PAR + !TODO: to distinguish lai and sai + !par = par * lai*(1.-rho(1,1)-tau(1,1)) / & + ! ( lai*(1.-rho(1,1)-tau(1,1)) + & + ! sai*(1.-rho(1,2)-tau(1,2)) ) + + ! for lake + sablake = forc_sols *slake(1,1) + forc_soll *slake(2,1) & + + forc_solsd*slake(1,2) + forc_solld*slake(2,2) + + ENDIF + + solvd = forc_sols + solvi = forc_solsd + solnd = forc_soll + solni = forc_solld + srvd = solvd*alb(1,1) + srvi = solvi*alb(1,2) + srnd = solnd*alb(2,1) + srni = solni*alb(2,2) + sr = srvd + srvi + srnd + srni + + ! calculate the local secs + radpsec = pi/12./3600. + IF ( isgreenwich ) THEN + local_secs = idate(3) + nint((dlon/radpsec)/deltim)*deltim + local_secs = mod(local_secs,86400) + ELSE + local_secs = idate(3) + ENDIF + + IF (local_secs == 86400/2) THEN + solvdln = forc_sols + solviln = forc_solsd + solndln = forc_soll + solniln = forc_solld + srvdln = solvdln*alb(1,1) + srviln = solviln*alb(1,2) + srndln = solndln*alb(2,1) + srniln = solniln*alb(2,2) + ELSE + solvdln = spval + solviln = spval + solndln = spval + solniln = spval + srvdln = spval + srviln = spval + srndln = spval + srniln = spval + ENDIF + + END SUBROUTINE netsolar_urban + +END MODULE MOD_Urban_NetSolar +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_PerviousTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_PerviousTemperature.F90 new file mode 100644 index 0000000000..6943f651fe --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_PerviousTemperature.F90 @@ -0,0 +1,314 @@ +#include + +MODULE MOD_Urban_PerviousTemperature +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The urban's pervious ground is equivalent to soil, and the heat +! transfer process of the surface soil is calculated consistently. This +! includes considering 10 layers of soil and up to 5 layers of snow, +! with a layering scheme consistent with the soil (snow). The phase +! change process is considered, and soil thermal parameters are +! obtained from global data. The difference lies in the fact that the +! shortwave and longwave radiation received at the surface, as well as +! the turbulent exchange flux (sensible heat, latent heat), are solved +! by the corresponding MODULE for the urban model. +! +! Created by Yongjiu Dai and Hua Yuan, 05/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanPerviousTem + +CONTAINS + + SUBROUTINE UrbanPerviousTem (patchtype,lb,deltim, & + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz_gpersno,z_gpersno,zi_gpersno,& + t_gpersno,wice_gpersno,wliq_gpersno,scv_gper,snowdp_gper,& + lgper,clgper,sabgper,fsengper,fevpgper,cgper,htvp,& + imelt,sm,xmf,fact) + +!======================================================================= +! Snow and pervious road temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of road soil is computed from +! the algorithm of Johansen (as reported by Farouki 1981), impervious +! and perivious from LOOK-UP table and of snow is from the formulation +! used in SNTHERM (Jordan 1991). +! o Boundary conditions: +! F = Rnet - Hg - LEg (top), F = 0 (base of the soil column). +! o Soil / snow temperature is predicted from heat conduction +! in 10 soil layers and up to 5 snow layers. The thermal +! conductivities at the interfaces between two neighbor layers +! (j,j+1) are derived from an assumption that the flux across the +! interface is equal to that from the node j to the interface and the +! flux from the interface to the node j+1. The equation is solved +! using the Crank-Nicholson method and resulted in a tridiagonal +! system equation. +! +! Phase change (see MOD_PhaseChange.F90) +! +! Original author: Yongjiu Dai, 09/15/1999; 08/30/2002; 05/2020 +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_SoilThermalParameters + USE MOD_Utils, only: tridia + USE MOD_PhaseChange, only: meltf + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: lb !lower bound of array + integer, intent(in) :: patchtype !land patch type + !(0=soil,1=urban or built-up,2=wetland, + !3=land ice, 4=deep lake, 5=shallow lake) + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor: turn 1st layer T to surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: csol (1:nl_soil) !heat capacity of soil solids [J/(m3 K)] + real(r8), intent(in) :: k_solids (1:nl_soil) !thermal cond. of minerals soil [W/m-K] + real(r8), intent(in) :: porsl (1:nl_soil) !soil porosity [-] + real(r8), intent(in) :: psi0 (1:nl_soil) !soil water suction, negative potential [mm] + + real(r8), intent(in) :: dkdry (1:nl_soil) !thermal cond. of dry soil [W/m-K] + real(r8), intent(in) :: dksatu (1:nl_soil) !thermal cond. of sat soil [W/m-K] + real(r8), intent(in) :: dksatf (1:nl_soil) !thermal cond. of sat frozen soil [W/m-K] + + real(r8), intent(in) :: vf_quartz (1:nl_soil) !volumetric frac of quartz in mineral soil + real(r8), intent(in) :: vf_gravels(1:nl_soil) !volumetric frac of gravels + real(r8), intent(in) :: vf_om (1:nl_soil) !volumetric frac of organic matter + real(r8), intent(in) :: vf_sand (1:nl_soil) !volumetric frac of sand + real(r8), intent(in) :: wf_gravels(1:nl_soil) !gravimetric frac of gravels + real(r8), intent(in) :: wf_sand (1:nl_soil) !gravimetric frac of sand + + real(r8), intent(in) :: BA_alpha (1:nl_soil) !alpha in Balland and Arp(2005) thermal cond. + real(r8), intent(in) :: BA_beta (1:nl_soil) !beta in Balland and Arp(2005) thermal cond. + +#ifdef Campbell_SOIL_MODEL + real(r8), intent(in) :: bsw (1:nl_soil) !clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + real(r8), intent(in) :: theta_r (1:nl_soil),& !soil parameter for vanGenuchten scheme + alpha_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + n_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + L_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + sc_vgm (1:nl_soil),& !soil parameter for vanGenuchten scheme + fc_vgm (1:nl_soil) !soil parameter for vanGenuchten scheme +#endif + + real(r8), intent(in) :: dz_gpersno(lb :nl_soil) !layer thickness [m] + real(r8), intent(in) :: z_gpersno (lb :nl_soil) !node depth [m] + real(r8), intent(in) :: zi_gpersno(lb-1:nl_soil) !interface depth [m] + + real(r8), intent(in) :: sabgper !solar radiation absorbed by ground [W/m2] + real(r8), intent(in) :: lgper !atmospheric longwave radiation [W/m2] + real(r8), intent(in) :: clgper !deriv. of longwave wrt to soil temp [w/m2/k] + real(r8), intent(in) :: fsengper !sensible heat flux from ground [W/m2] + real(r8), intent(in) :: fevpgper !evaporation heat flux from ground [mm/s] + real(r8), intent(in) :: cgper !deriv. of soil energy flux to T [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor (or sublimation) [j/kg] + + real(r8), intent(inout) :: t_gpersno (lb:nl_soil) !soil temperature [K] + real(r8), intent(inout) :: wice_gpersno(lb:nl_soil) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_gpersno(lb:nl_soil) !liquid water [kg/m2] + real(r8), intent(inout) :: scv_gper !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp_gper !snow depth [m] + + real(r8), intent(out) :: sm !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf !total latent heat of phase change in soil + real(r8), intent(out) :: fact (lb:nl_soil) !used in computing tridiagonal matrix + integer, intent(out) :: imelt(lb:nl_soil) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) cv(lb:nl_soil) !heat capacity [J/(m2 K)] + real(r8) tk(lb:nl_soil) !thermal conductivity [W/(m K)] + + real(r8) hcap(1:nl_soil) !J/(m3 K) + real(r8) thk(lb:nl_soil) !W/(m K) + real(r8) rhosnow !partial density of water (ice + liquid) + + real(r8) at(lb:nl_soil) !"a" vector for tridiagonal matrix + real(r8) bt(lb:nl_soil) !"b" vector for tridiagonal matrix + real(r8) ct(lb:nl_soil) !"c" vector for tridiagonal matrix + real(r8) rt(lb:nl_soil) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_soil) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_gpersno_bef(lb:nl_soil) !soil/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + real(r8) brr(lb:nl_soil) !temporary set + + real(r8) vf_water(1:nl_soil) !volumetric fraction liquid water within soil + real(r8) vf_ice(1:nl_soil) !volumetric fraction ice len within soil + + integer i,j + +!======================================================================= +! soil ground and wetland heat capacity + DO i = 1, nl_soil + vf_water(i) = wliq_gpersno(i)/(dz_gpersno(i)*denh2o) + vf_ice(i) = wice_gpersno(i)/(dz_gpersno(i)*denice) + CALL soil_hcap_cond(vf_gravels(i),vf_om(i),vf_sand(i),porsl(i),& + wf_gravels(i),wf_sand(i),k_solids(i),& + csol(i),dkdry(i),dksatu(i),dksatf(i),& + BA_alpha(i),BA_beta(i),& + t_gpersno(i),vf_water(i),vf_ice(i),hcap(i),thk(i)) + cv(i) = hcap(i)*dz_gpersno(i) + ENDDO + IF(lb==1 .and. scv_gper>0.) cv(1) = cv(1) + cpice*scv_gper + +! Snow heat capacity + IF(lb <= 0)THEN + cv(:0) = cpliq*wliq_gpersno(:0) + cpice*wice_gpersno(:0) + ENDIF + +! Snow thermal conductivity + IF(lb <= 0)THEN + DO i = lb, 0 + rhosnow = (wice_gpersno(i)+wliq_gpersno(i))/dz_gpersno(i) + + ! presently option [1] is the default option + ! [1] Jordan (1991) pp. 18 + thk(i) = tkair+(7.75e-5*rhosnow+1.105e-6*rhosnow*rhosnow)*(tkice-tkair) + + ! [2] Sturm et al (1997) + ! thk(i) = 0.0138 + 1.01e-3*rhosnow + 3.233e-6*rhosnow**2 + ! [3] Ostin and Andersson presented in Sturm et al., (1997) + ! thk(i) = -0.871e-2 + 0.439e-3*rhosnow + 1.05e-6*rhosnow**2 + ! [4] Jansson(1901) presented in Sturm et al. (1997) + ! thk(i) = 0.0293 + 0.7953e-3*rhosnow + 1.512e-12*rhosnow**2 + ! [5] Douville et al., (1995) + ! thk(i) = 2.2*(rhosnow/denice)**1.88 + ! [6] van Dusen (1992) presented in Sturm et al. (1997) + ! thk(i) = 0.021 + 0.42e-3*rhosnow + 0.22e-6*rhosnow**2 + + ENDDO + ENDIF + +! Thermal conductivity at the layer interface + DO i = lb, nl_soil-1 + +! the following consideration is try to avoid the snow conductivity +! to be dominant in the thermal conductivity of the interface. +! Because when the distance of bottom snow node to the interface +! is larger than that of interface to top soil node, +! the snow thermal conductivity will be dominant, and the result is that +! lees heat transfer between snow and soil + IF((i==0) .and. (z_gpersno(i+1)-zi_gpersno(i) + +MODULE MOD_Urban_RoofFlux + + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanRoofFlux + +CONTAINS + + + SUBROUTINE UrbanRoofFlux (hu, ht, hq, us, vs, tm, qm, rhoair, psrf, & + ur, thm, th, thv, zsno, fsno_roof, hroof, htvp_roof, & + lbr, wliq_roofsno, wice_roofsno, troof, qroof, dqroofdT, & + croofs, croofl, croof, fsenroof, fevproof, & + z0m, z0hg, zol, ustar, qstar, tstar, fm, fh, fq) + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This is the main subroutine to execute the calculation +! of roof fluxes - not used now. +! +! Created by Hua Yuan, 11/2022 +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Const_Physical, only: cpair,vonkar,grav + USE MOD_FrictionVelocity + IMPLICIT NONE + +!----------------------- Dummy argument -------------------------------- + integer, intent(in) :: & + lbr ! lower bound of array + + real(r8), intent(in) :: & + ! atmospherical variables and observational height + hu, &! observational height of wind [m] + ht, &! observational height of temperature [m] + hq, &! observational height of humidity [m] + us, &! wind component in eastward direction [m/s] + vs, &! wind component in northward direction [m/s] + tm, &! temperature at agcm reference height [kelvin] [not used] + qm, &! specific humidity at agcm reference height [kg/kg] + rhoair, &! density air [kg/m3] + psrf, &! atmosphere pressure at the surface [pa] [not used] + + ur, &! wind speed at reference height [m/s] + thm, &! intermediate variable (tm+0.0098*ht) + th, &! potential temperature (kelvin) + thv, &! virtual potential temperature (kelvin) + + zsno, &! roughness length for snow [m] + fsno_roof,&! fraction of impervious ground covered by snow + hroof, &! average building height [m] + + wliq_roofsno,&! liquid water [kg/m2] + wice_roofsno,&! ice lens [kg/m2] + + troof, &! ground impervious temperature [K] + qroof, &! ground impervious specific humidity [kg/kg] + dqroofdT, &! d(qroof)/dT + htvp_roof ! latent heat of vapor of water (or sublimation) [j/kg] + + real(r8), intent(out) :: & + croofs, &! deriv of roof sensible heat flux wrt soil temp [w/m**2/k] + croofl, &! deriv of roof latent heat flux wrt soil temp [w/m**2/k] + croof ! deriv of roof total heat flux wrt soil temp [w/m**2/k] + + real(r8), intent(out) :: & + fsenroof, &! sensible heat flux from roof [W/m2] + fevproof ! evaporation heat flux from roof [W/m2] + + real(r8), intent(out) :: & + z0m, &! effective roughness [m] + z0hg, &! roughness length over ground, sensible heat [m] + zol, &! dimensionless height (z/L) used in Monin-Obukhov theory + ustar, &! friction velocity [m/s] + tstar, &! temperature scaling parameter + qstar, &! moisture scaling parameter + fm, &! integral of profile function for momentum + fh, &! integral of profile function for heat + fq ! integral of profile function for moisture + +!-------------------------- Local Variables ---------------------------- + integer niters,&! maximum number of iterations for surface temperature + iter, &! iteration index + nmozsgn ! number of times moz changes sign + + real(r8) :: & + beta, &! coefficient of convective velocity [-] + displax, &! zero-displacement height [m] + tg, &! ground surface temperature [K] + qg, &! ground specific humidity [kg/kg] + fg, &! ground fractional cover [-] + froof, &! weight of impervious ground + dth, &! diff of virtual temp. between ref. height and surface + dqh, &! diff of humidity between ref. height and surface + dthv, &! diff of vir. poten. temp. between ref. height and surface + obu, &! monin-obukhov length (m) + obuold, &! monin-obukhov length from previous iteration + ram, &! aerodynamical resistance [s/m] + rah, &! thermal resistance [s/m] + raw, &! moisture resistance [s/m] + raih, &! temporary variable [kg/m2/s] + raiw, &! temporary variable [kg/m2/s] + fh2m, &! relation for temperature at 2m + fq2m, &! relation for specific humidity at 2m + fm10m, &! integral of profile function for momentum at 10m + thvstar, &! virtual potential temperature scaling parameter + um, &! wind speed including the stability effect [m/s] + wc, &! convective velocity [m/s] + wc2, &! wc**2 + zeta, &! dimensionless height used in Monin-Obukhov theory + zii, &! convective boundary height [m] + zldis, &! reference height "minus" zero displacement height [m] + z0mg, &! roughness length over ground, momentum [m] + z0qg ! roughness length over ground, latent heat [m] + + real(r8) fwet_roof + +!----------------------------------------------------------------------- +! initial roughness length + !TODO: change to original + !z0mg = (1.-fsno)*zlnd + fsno*zsno + IF (fsno_roof > 0) THEN + z0mg = zsno + ELSE + z0mg = 0.01 + ENDIF + z0hg = z0mg + z0qg = z0mg + +! potential temperature at the reference height + beta = 1. !- (in computing W_*) + zii = 1000. !m (pbl height) + z0m = z0mg + + ! wet fraction for roof and impervious ground + !------------------------------------------- + ! roof + IF (lbr < 1) THEN + fwet_roof = fsno_roof !for snow layer exist + ELSE + ! surface wet fraction. assuming max ponding = 1 kg/m2 + fwet_roof = (max(0., wliq_roofsno+wice_roofsno))**(2/3.) + fwet_roof = min(1., fwet_roof) + ENDIF + + ! dew case + IF (qm > qroof) THEN + fwet_roof = 1. + ENDIF + +!----------------------------------------------------------------------- +! Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!----------------------------------------------------------------------- +! Initialization variables + nmozsgn = 0 + obuold = 0. + + dth = thm-troof + dqh = qm-qroof + dthv = dth*(1.+0.61*qm)+0.61*th*dqh + zldis = hu-hroof-0. + + CALL moninobukini(ur,th,thm,thv,dth,dqh,dthv,zldis,z0mg,um,obu) + +! Evaluated stability-dependent variables using moz from prior iteration + niters=6 + + !---------------------------------------------------------------- + ITERATION : DO iter = 1, niters !begin stability iteration + !---------------------------------------------------------------- + displax = hroof + CALL moninobuk(hu,ht,hq,displax,z0mg,z0hg,z0qg,obu,um,& + ustar,fh2m,fq2m,fm10m,fm,fh,fq) + + tstar = vonkar/fh*dth + qstar = vonkar/fq*dqh + + z0hg = z0mg/exp(0.13 * (ustar*z0mg/1.5e-5)**0.45) + z0qg = z0hg + + thvstar=tstar*(1.+0.61*qm)+0.61*th*qstar + zeta=zldis*vonkar*grav*thvstar/(ustar**2*thv) + IF (zeta >= 0.) THEN !stable + zeta = min(2.,max(zeta,1.e-6)) + ELSE !unstable + zeta = max(-100.,min(zeta,-1.e-6)) + ENDIF + obu = zldis/zeta + + IF (zeta >= 0.) THEN + um = max(ur,0.1) + ELSE + wc = (-grav*ustar*thvstar*zii/thv)**(1./3.) + wc2 = beta*beta*(wc*wc) + um = sqrt(ur*ur+wc2) + ENDIF + + IF (obuold*obu < 0.) nmozsgn = nmozsgn+1 + IF (nmozsgn >= 4) EXIT + + obuold = obu + + !---------------------------------------------------------------- + ENDDO ITERATION !end stability iteration + !---------------------------------------------------------------- + +! Get derivative of fluxes with respect to ground temperature + ram = 1./(ustar*ustar/um) + rah = 1./(vonkar/fh*ustar) + raw = 1./(vonkar/fq*ustar) + + raih = rhoair*cpair/rah + raiw = rhoair/raw + croofs = raih + croofl = raiw*dqroofdT*fwet_roof + croof = croofs + htvp_roof*croofl + + zol = zeta + +! surface fluxes of momentum, sensible and latent +! using ground temperatures from previous time step + !taux = -rhoair*us/ram + !tauy = -rhoair*vs/ram + fsenroof = -raih*dth + fevproof = -raiw*dqh*fwet_roof + + END SUBROUTINE UrbanRoofFlux + +END MODULE MOD_Urban_RoofFlux +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_RoofTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_RoofTemperature.F90 new file mode 100644 index 0000000000..25d72a226a --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_RoofTemperature.F90 @@ -0,0 +1,252 @@ +#include + +MODULE MOD_Urban_RoofTemperature +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The layer division scheme of the roof is the same as the wall (equal +! depth), and the thickness is read from external data. The temperature +! transfer is similar to the wall, but considering the influence of +! snow and water accumulation on the thermal properties of the first +! layer of the roof, as well as impervious surfaces. At the same time, +! the heat exchange between the innermost layer of the roof and the +! indoor roof surface air is considered, and the phase change process +! is only considered for the first layer of the roof and the snow cover +! layer. +! +! Created by Yongjiu Dai and Hua Yuan, 05/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanRoofTem + +CONTAINS + + + SUBROUTINE UrbanRoofTem (lb,deltim,capr,cnfac,& + cv_roof,tk_roof,dz_roofsno,z_roofsno,zi_roofsno,& + t_roofsno,wice_roofsno,wliq_roofsno,scv_roof,snowdp_roof,& + troof_inner,lroof,clroof,sabroof,fsenroof,fevproof,croof,htvp,& + imelt_roof,sm_roof,xmf_roof,fact,tkdz_roof) + +!======================================================================= +! Snow and roof temperatures +! o The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! o The thermal conductivity of roof is given by LOOK-UP table, and of +! snow is from the formulation used in SNTHERM (Jordan 1991). +! o Boundary conditions: +! F = Rnet - Hg - LEg (top), +! For urban sunwall, shadewall, and roof columns, there is a non-zero +! heat flux across the bottom "building inner surface" layer and the +! equations are derived assuming a prescribed or adjusted internal +! building temperature. T = T_roof_inner (at the roof inner surface). +! o Roof / snow temperature is predicted from heat conduction +! in N roof layers and up to 5 snow layers. The thermal +! conductivities at the interfaces between two neighbor layers (j, +! j+1) are derived from an assumption that the flux across the +! interface is equal to that from the node j to the interface and the +! flux from the interface to the node j+1. The equation is solved +! using the Crank-Nicholson method and resulted in a tridiagonal +! system equation. +! +! Phase change (see MOD_PhaseChange.F90) +! +! Original author: Yongjiu Dai, 05/2020 +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_Utils, only: tridia + USE MOD_PhaseChange, only: meltf_urban + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer , intent(in) :: lb !lower bound of array + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor: turn 1st layer T to surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: cv_roof(1:nl_roof) !heat capacity of urban roof [J/m3/K] + real(r8), intent(in) :: tk_roof(1:nl_roof) !thermal conductivity of urban roof [W/m/K] + + real(r8), intent(in) :: dz_roofsno(lb:nl_roof) !layer thickness [m] + real(r8), intent(in) :: z_roofsno (lb:nl_roof) !node depth [m] + real(r8), intent(in) :: zi_roofsno(lb-1:nl_roof) !interface depth [m] + + real(r8), intent(in) :: troof_inner !temperature at the roof inner surface [K] + real(r8), intent(in) :: lroof !atmospheric longwave radiation [W/m2] + real(r8), intent(in) :: clroof !atmospheric longwave radiation [W/m2] + real(r8), intent(in) :: sabroof !solar radiation absorbed by roof [W/m2] + real(r8), intent(in) :: fsenroof !sensible heat flux from roof [W/m2] + real(r8), intent(in) :: fevproof !evaporation heat flux from roof [mm/s] + real(r8), intent(in) :: croof !deriv. of roof energy flux to T [w/m2/k] + real(r8), intent(in) :: htvp !latent heat of vapor (or sublimation) [j/kg] + + real(r8), intent(inout) :: t_roofsno (lb:nl_roof) !roof layers' temperature [K] + real(r8), intent(inout) :: wice_roofsno(lb:nl_roof) !ice lens [kg/m2] + real(r8), intent(inout) :: wliq_roofsno(lb:nl_roof) !liquid water [kg/m2] + real(r8), intent(inout) :: scv_roof !snow cover, water equivalent [mm, kg/m2] + real(r8), intent(inout) :: snowdp_roof !snow depth [m] + + real(r8), intent(out) :: sm_roof !rate of snowmelt [kg/(m2 s)] + real(r8), intent(out) :: xmf_roof !total latent heat of phase change of roof + real(r8), intent(out) :: fact(lb:nl_roof) !used in computing tridiagonal matrix + real(r8), intent(out) :: tkdz_roof !heat diffusion with inner room space + integer , intent(out) :: imelt_roof(lb:nl_roof) !flag for melting or freezing [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) cv (lb:nl_roof) !heat capacity [J/(m2 K)] + real(r8) thk(lb:nl_roof) !thermal conductivity of layer + real(r8) tk (lb:nl_roof) !thermal conductivity [W/(m K)] + + real(r8) at (lb:nl_roof) !"a" vector for tridiagonal matrix + real(r8) bt (lb:nl_roof) !"b" vector for tridiagonal matrix + real(r8) ct (lb:nl_roof) !"c" vector for tridiagonal matrix + real(r8) rt (lb:nl_roof) !"r" vector for tridiagonal solution + + real(r8) fn (lb:nl_roof) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(lb:nl_roof) !heat diffusion through the layer interface [W/m2] + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_roofsno_bef(lb:nl_roof) !roof/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + real(r8) brr(lb:nl_roof) !temporary set + real(r8) bw !snow density [kg/m3] + + integer i,j + +!----------------------------------------------------------------------- + + wice_roofsno(2:) = 0.0 !ice lens [kg/m2] + wliq_roofsno(2:) = 0.0 !liquid water [kg/m2] + +! heat capacity + IF (lb <= 0) THEN + DO j = lb, 0 + cv(j) = max(1.0e-6_r8,(cpliq*wliq_roofsno(j) + cpice*wice_roofsno(j))) + ENDDO + ENDIF + + cv(1:) = cv_roof(1:)*dz_roofsno(1:) + + ! snow exist when there is no snow layer + IF (lb == 1 .and. scv_roof > 0.0) THEN + cv(1) = cv(1) + cpice*scv_roof + ENDIF + + ! ponding water or ice exist + cv(1) = cv(1) + cpliq*wliq_roofsno(1) + cpice*wice_roofsno(1) + +! thermal conductivity + ! Thermal conductivity of snow, which from Yen (1980) + IF (lb <= 0) THEN + DO j = lb, 0 + bw = (wice_roofsno(j)+wliq_roofsno(j))/(dz_roofsno(j)) + thk(j) = tkair + (7.75e-5_r8 *bw + 1.105e-6_r8*bw*bw)*(tkice-tkair) ! Yen, 1980 + !thk(j) = 0.024 - 1.23e-4_r8*bw + 2.5e-6_r8*bw*bw ! Calonne et al., 2011 + ENDDO + ENDIF + +! thermal conductivity at the layer interface + thk(1:) = tk_roof(1:) + IF (lb <= 0) THEN + DO j = lb, 0 + tk(j) = thk(j)*thk(j+1)*(z_roofsno(j+1)-z_roofsno(j)) & + /(thk(j)*(z_roofsno(j+1)-zi_roofsno(j))+thk(j+1)*(zi_roofsno(j)-z_roofsno(j))) + ENDDO + ENDIF + + DO j = 1, nl_roof-1 + tk(j) = thk(j)*thk(j+1)*(z_roofsno(j+1)-z_roofsno(j)) & + /(thk(j)*(z_roofsno(j+1)-zi_roofsno(j))+thk(j+1)*(zi_roofsno(j)-z_roofsno(j))) + ENDDO + tk(nl_roof) = thk(nl_roof) + +! net ground heat flux into the roof surface and its temperature derivative + hs = sabroof + lroof - (fsenroof+fevproof*htvp) + dhsdT = - croof + clroof + + t_roofsno_bef(lb:) = t_roofsno(lb:) + + j = lb + fact(j) = deltim / cv(j) * dz_roofsno(j) & + / (0.5*(z_roofsno(j)-zi_roofsno(j-1)+capr*(z_roofsno(j+1)-zi_roofsno(j-1)))) + + DO j = lb + 1, nl_roof + fact(j) = deltim/cv(j) + ENDDO + + DO j = lb, nl_roof - 1 + fn(j) = tk(j)*(t_roofsno(j+1)-t_roofsno(j))/(z_roofsno(j+1)-z_roofsno(j)) + ENDDO + + j = nl_roof + fn(j) = tk(j)*(troof_inner - cnfac*t_roofsno(j))/(zi_roofsno(j)-z_roofsno(j)) + tkdz_roof = tk(j)/(zi_roofsno(j)-z_roofsno(j)) + +! set up vector r and vectors a, b, c that define tridiagonal matrix + j = lb + dzp = z_roofsno(j+1)-z_roofsno(j) + at(j) = 0. + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp + rt(j) = t_roofsno(j) + fact(j)*( hs - dhsdT*t_roofsno(j) + cnfac*fn(j) ) + + DO j = lb + 1, nl_roof - 1 + dzm = (z_roofsno(j)-z_roofsno(j-1)) + dzp = (z_roofsno(j+1)-z_roofsno(j)) + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_roofsno(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDDO + + j = nl_roof + dzm = (z_roofsno(j)-z_roofsno(j-1)) + dzp = (zi_roofsno(j)-z_roofsno(j)) + at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j-1)/dzm+tk(j)/dzp) + ct(j) = 0. + rt(j) = t_roofsno(j) + fact(j)*(fn(j) - cnfac*fn(j-1)) + +! solve for t_roofsno + i = size(at) + CALL tridia (i ,at ,bt ,ct ,rt ,t_roofsno) + +!======================================================================= +! melting or freezing +!======================================================================= + + DO j = lb, nl_roof - 1 + fn1(j) = tk(j)*(t_roofsno(j+1)-t_roofsno(j))/(z_roofsno(j+1)-z_roofsno(j)) + ENDDO + + j = nl_roof + fn1(j) = tk(j)*(troof_inner - cnfac*t_roofsno(j))/(zi_roofsno(j)-z_roofsno(j)) + + j = lb + brr(j) = cnfac*fn(j) + (1.-cnfac)*fn1(j) + + DO j = lb + 1, nl_roof + brr(j) = cnfac*(fn(j)-fn(j-1)) + (1.-cnfac)*(fn1(j)-fn1(j-1)) + ENDDO + + CALL meltf_urban (lb,1,deltim, & + fact(lb:1),brr(lb:1),hs,dhsdT, & + t_roofsno_bef(lb:1),t_roofsno(lb:1), & + wliq_roofsno(lb:1),wice_roofsno(lb:1),imelt_roof(lb:1), & + scv_roof,snowdp_roof,sm_roof,xmf_roof) + + END SUBROUTINE UrbanRoofTem + +END MODULE MOD_Urban_RoofTemperature +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 new file mode 100644 index 0000000000..2b331f176e --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Shortwave.F90 @@ -0,0 +1,777 @@ +#include + +MODULE MOD_Urban_Shortwave + + USE MOD_Precision + USE MOD_LandUrban + USE MOD_Vars_Global + USE MOD_3DCanopyRadiation, only: tee, phi + USE MOD_MPAS_MPI + + IMPLICIT NONE + SAVE + PRIVATE + + PUBLIC :: UrbanOnlyShortwave !Radiation transfer for shortwave radiation without trees + PUBLIC :: UrbanVegShortwave !Radiation transfer for shortwave radiation with trees + + PUBLIC :: MatrixInverse !Inverse of radiation transfer matrix for multiple reflections + PUBLIC :: ShadowWall_dir !Shadow of wall for direct radiation + PUBLIC :: ShadowWall_dif !Shadow of wall for diffuse radiation + PUBLIC :: ShadowTree !Shadow of trees + +CONTAINS + + + SUBROUTINE UrbanOnlyShortwave ( theta, HL, fb, fgper, H, & + aroof, awall, agimp, agper, fwsun, sroof, swsun, swsha, sgimp, sgper, albu) + +!----------------------------------------------------------------------- +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++| ______ +! |++++++| |++++++| +! ______+++++| |++++++| +! |++++++|++++| |++++++| +! sunlit |[]++[]|++++| |++++++| shaded +! wall |++++++| |++++++| wall +! |[]++[]| |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|____________________________________ +! +! +! !DESCRIPTION: +! +! Calculate the ground shadow area, the area of the sunny and shady +! walls taking into account mutual shading between buildings; +! calculate the visibility factor F between the sky, walls, and +! ground; calculate the initial radiation reaching each component +! surface, considering multiple scattering processes, and establish +! the radiation transfer balance equation for both incident direct +! and diffuse radiation cases for solving. +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + theta, &! Sun zenith angle [radian] + HL, &! Ratio of building height to their side length [-] + fb, &! Fraction of building area [-] + fgper, &! Fraction of impervious ground [-] + H ! Building average height [m] + + real(r8), intent(in) :: & + aroof, &! albedo of roof [-] + awall, &! albedo of walls [-] + agimp, &! albedo of impervious road [-] + agper ! albedo of pervious road [-] + + real(r8), intent(out) :: & + fwsun, &! Fraction of sunlit wall [-] + sroof(2), &! Urban building roof absorption [-] + swsun(2), &! Urban sunlit wall absorption [-] + swsha(2), &! Urban shaded wall absorption [-] + sgimp(2), &! Urban impervious ground absorption [-] + sgper(2), &! Urban pervious ground absorption [-] + albu(2) ! Urban overall albedo [-] + +!-------------------------- Local Variables ---------------------------- + real(r8) :: & + W, &! Urban ground average width [m] + L, &! Urban building average length [m] + HW, &! Ratio of H to W, H/W [-] + fg, &! Fraction of ground [-] + fgimp, &! Weight of pervious ground [-] + + Fsw, &! View factor from sky to wall [-] + Fsg, &! View factor from sky to ground [-] + Fgw, &! View factor from ground to wall [-] + Fgs, &! View factor from ground to sky [-] + Fww, &! View factor from wall to wall [-] + Fwg, &! View factor from wall to ground [-] + Fws, &! View factor from wall to sky [-] + + Sw, &! Shadow of wall [-] + fwsha, &! Fraction of shaded wall [-] + Ewsun, &! Incident radiation on sunlit wall [-] + Ewsha, &! Incident radiation on shaded wall [-] + Eg, &! Incident radiation on ground [-] + Egimp, &! Incident radiation on impervious ground [-] + Egper, &! Incident radiation on pervious ground [-] + + A(4,4), &! Radiation transfer matrix + Ainv(4,4), &! Inverse of Radiation transfer matrix + B(4), &! Vectors of incident radiation on each surface + X(4) ! Radiation emit from each surface in balance condition + + ! Temporal + real(r8) :: fac1, fac2, eb + +!----------------------------------------------------------------------- + + ! Calculate urban structure parameters + !------------------------------------------------- + !W = H/HW + !L = W*sqrt(fb)/(1-sqrt(fb)) + !HL = H/L !NOTE: Same as: HL = HW*(1-sqrt(fb))/sqrt(fb) + fg = 1. - fb + + fgimp = 1. - fgper + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L/L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + ! Adjusted as below: + Fws = Fsw*fg/fb/(2*HL)*0.75 + Fwg = Fsw*fg/fb/(2*HL)*0.25 + Fww = 1 - Fws - Fwg + + ! Calculate sunlit wall fraction + !------------------------------------------------- + + ! Building wall shadow on the ground + Sw = ShadowWall_dir(fb/fg, HL, theta) + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + ! o A: radiation transfer matrix + ! o B: incident radiation on each surface + ! o X: radiation emit from each surface + !------------------------------------------------- + A(1,:) = (/1-Fww*fwsun*awall, -Fww*fwsun*awall, -Fgw*fwsun*awall, -Fgw*fwsun*awall/) + A(2,:) = (/ -Fww*fwsha*awall, 1-Fww*fwsha*awall, -Fgw*fwsha*awall, -Fgw*fwsha*awall/) + A(3,:) = (/ -Fwg*fgimp*agimp, -Fwg*fgimp*agimp, 1._r8, 0._r8/) + A(4,:) = (/ -Fwg*fgper*agper, -Fwg*fgper*agper, 0._r8, 1._r8/) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Radiation transfer for incident direct case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Sw + Ewsha = 0. + Eg = 1.-Ewsun + Egimp = Eg*fgimp + Egper = Eg*fgper + + ! Vector of first scattering radiation on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper/) + + ! Matrix computing to resolve multiple reflections + X = matmul(Ainv, B) + + !------------------------------------------------- + ! SAVE results for output + !------------------------------------------------- + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(1) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(1) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(1) = X(3)/agimp*(1-agimp)!/fgimp + sgper(1) = X(4)/agper*(1-agper)!/fgper + + ! albedo of urban canopy + albu(1) = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs + + ! Energy balance check + eb = swsun(1) + swsha(1) + sgimp(1) + sgper(1) + albu(1) + IF (abs(eb-1) > 1e-6) THEN + print *, "Direct - Energy Balance Check error!", eb-1 + ENDIF + + ! Radiation transfer for incident diffuse case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Fsw*fwsun + Ewsha = Fsw*fwsha + Eg = Fsg + Egimp = Eg*fgimp + Egper = Eg*fgper + + ! Vector of first scattering radiation on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper/) + + ! Equation solve + X = matmul(Ainv, B) + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(2) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(2) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(2) = X(3)/agimp*(1-agimp)!/fgimp + sgper(2) = X(4)/agper*(1-agper)!/fgper + + !albedo of urban canopy + albu(2) = X(1)*Fws + X(2)*Fws + X(3)*Fgs + X(4)*Fgs + + ! energy balance check + eb = swsun(2) + swsha(2) + sgimp(2) + sgper(2) + albu(2) + IF (abs(eb-1) > 1e-6) THEN + print *, "Diffuse - Energy Balance Check error!", eb-1 + ENDIF + + ! convert to per unit area absorption + IF (fb > 0.) THEN + swsun = swsun/(4*fwsun*HL*fb)*fg + swsha = swsha/(4*fwsha*HL*fb)*fg + ENDIF + IF (fgimp > 0.) sgimp = sgimp/fgimp + IF (fgper > 0.) sgper = sgper/fgper + + ! roof absorption + sroof = 1. - aroof + + ! albedo account for both roof and urban's wall and ground + albu = aroof*fb + albu*fg + + END SUBROUTINE UrbanOnlyShortwave + + + SUBROUTINE UrbanVegShortwave ( theta, HL, fb, fgper, H, & + aroof, awall, agimp, agper, lai, sai, fv, hv, rho, tau, & + fwsun, sroof, swsun, swsha, sgimp, sgper, sveg, albu ) + +!----------------------------------------------------------------------- +! Sun +! \\\ +! \\\ +! ______ +! |++++++| roof +! |++++++| ______ +! |++++++| ___ |++++++| +! ______+++++| ||||| |++++++| +! |++++++|++++| ||||||| |++++++| +! sunlit |[]++[]|++++| ||||| |++++++| shaded +! wall |++++++| | tree |++++++| wall +! |[]++[]| | |++++++| +! |++++++| impervious/pervious ground +! __________|++++++|____________________________________ +! +! +! !DESCRIPTION: +! +! The process of shortwave radiation transfer in a city considering +! vegetation (trees only) is based on the radiation transfer without +! vegetation (UrbanOnlyShortwave), taking into account the visibility +! factors F between the various components including the vegetation, in +! order to calculate the radiation transfer matrix during radiation +! balance. A similar method is used to solve the radiation absorption +! of walls, ground, and vegetation. The additional part compared to +! urban radiation transfer without vegetation (UrbanOnlyShortwave) is +! the consideration of the visibility factors and shadow area +! calculation including the vegetation. +! +! Created by Hua Yuan, 09/2021 +! +! !REVISIONS: +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: & + theta, &! Sun zenith angle [radian] + HL, &! Ratio of building height to their side length [-] + fb, &! Fraction of building area [-] + fgper, &! Fraction of impervious ground [-] + H ! Building average height [m] + + real(r8), intent(in) :: & + aroof, &! albedo of roof [-] + awall, &! albedo of walls [-] + agimp, &! albedo of impervious road [-] + agper ! albedo of pervious road [-] + + real(r8), intent(in) :: & + lai, &! leaf area index + sai, &! stem area index + fv, &! Fraction of tree cover [-] + hv, &! Central height of vegetation crown + rho, &! effective rho (lai + sai) + tau ! effective tau (lai + sai) + + real(r8), intent(out) :: & + fwsun, &! Fraction of sunlit wall [-] + sroof(2), &! Urban building roof absorption [-] + swsun(2), &! Urban sunlit wall absorption [-] + swsha(2), &! Urban shaded wall absorption [-] + sgimp(2), &! Urban impervious ground absorption [-] + sgper(2), &! Urban pervious ground absorption [-] + sveg(2), &! Urban building tree absorption [-] + albu(2) ! Urban overall albedo [-] + +!-------------------------- Local Variables ---------------------------- + real(r16),parameter :: DD1=1.0_r16 !quad accuracy real number + + real(r8) :: & + W, &! Urban ground average width + L, &! Urban building average length + HW, &! Ratio of H to W, H/W [-] + fg, &! Fraction of ground [-] + fgimp, &! Weight of pervious ground [-] + + Fsw, &! View factor from sky to wall [-] + Fsg, &! View factor from sky to ground [-] + Fgw, &! View factor from ground to wall [-] + Fgs, &! View factor from ground to sky [-] + Fww, &! View factor from wall to wall [-] + Fwg, &! View factor from wall to ground [-] + Fws, &! View factor from wall to sky [-] + + Fvg, &! View factor from tree to ground [-] + Fvs, &! View factor from tree to sky [-] + Fvw, &! View factor from tree to walls (sunlit+shaded) [-] + Fwv, &! View factor from wall to tree [-] + Fgv, &! View factor from ground to tree [-] + Fsv, &! View factor from sky to tree [-] + + Fgvs, &! View factor from ground->|tree|-> to sky [-] + Fgvw, &! View factor from ground->|tree|-> to walls [-] + Fsvg, &! View factor from sky->|tree|-> to ground [-] + Fsvw, &! View factor from sky->|tree|-> to walls [-] + Fwvw, &! View factor from walls->|tree|-> to walls [-] + Fwvs, &! View factor from walls->|tree|-> to sky [-] + Fwvg, &! View factor from walls->|tree|-> to ground [-] + + Fsw_, &! Fsw - Fsvw + Fsvw*Td [-] + Fsg_, &! Fsg - Fsvg + Fsvg*Td [-] + Fgw_, &! Fgw - Fgvw + Fgvw*Td [-] + Fgs_, &! Fgs - Fgvs + Fgvs*Td [-] + Fwg_, &! Fwg - Fwvg + Fwvg*Td [-] + Fww_, &! Fww - Fwvw + Fwvw*Td [-] + Fws_, &! Fws - Fwvs + Fwvs*Td [-] + + Sw, &! Shadow of wall [-] + Sw_, &! Shadow of wall [-] + Sv, &! Shadow of trees [-] + Svw, &! Overlapped shadow between wall and trees [-] + fv_, &! Fraction of trees [-] + Td, &! Transmission of tree [-] + av, &! albedo of tree [-] + fwsha, &! Fraction of shaded wall [-] + Ewsun, &! Incident radiation on sunlit wall [-] + Ewsha, &! Incident radiation on shaded wall [-] + Eg, &! Incident radiation on ground [-] + Egimp, &! Incident radiation on impervious ground [-] + Egper, &! Incident radiation on pervious ground [-] + Ev ! Incident radiation on trees [-] + + ! Radiation transfer matrix and vectors + !------------------------------------------------- + real(r8) :: A(5,5) !Radiation transfer matrix + real(r8) :: Ainv(5,5) !Inverse of Radiation transfer matrix + real(r8) :: B(5) !Vectors of incident radiation on each surface + real(r8) :: X(5) !Radiation emit from each surface in balance condition + + ! Temporal + real(r8) :: fac1, fac2, eb, sumw, ws, wg, ww + + real(r8) :: phi_tot !albedo of a single tree + real(r8) :: phi_dif !Temporal + real(r8) :: pa2 !Temporal + real(r8) :: lsai !lai+sai +!----------------------------------------------------------------------- + + ! Calculate urban structure parameters + !------------------------------------------------- + !W = H/HW + !L = W*sqrt(fb)/(1-sqrt(fb)) + !HL = H/L !NOTE: Same as: HL = HW*(1-sqrt(fb))/sqrt(fb) + L = H/HL + fg = 1. - fb + + fgimp = 1. - fgper + + ! Calculate transmission and albedo of tree + !------------------------------------------------- + lsai = (lai+sai)*fv/cos(PI/3)/ShadowTree(fv, PI/3) + Td = tee(DD1*3/8.*lsai) + CALL phi(.true., 3/8.*lsai, tau+rho, tau, rho, phi_tot, phi_dif, pa2) + av = phi_tot + + ! Calculate view factors + !------------------------------------------------- + + ! View factor from sky to wall(sunlit+shaded) and ground + Fsw = ShadowWall_dif(fb/fg, HL) + Fsg = 1 - Fsw + + ! View factor from ground to walls and sky + Fgw = Fsw + Fgs = Fsg + + ! View factor from wall to wall, sky and ground + ! Fws*4*H*L*L/L = Fws*4H/L*fb = Fsw*fg + ! Fws*4HL*fb = Fsw*fg + ! Fws = Fsw*fg/(4HL*fb) + ! adjusted as below: + Fws = Fsw*fg/fb/(2*HL)*0.75 + Fwg = Fsw*fg/fb/(2*HL)*0.25 + Fww = 1 - Fws - Fwg + + ! View factor from tree to walls, ground and sky + !------------------------------------------------- + + Sw = ShadowWall_dif(fb/fg, HL) + Sw_ = ShadowWall_dif(fb/fg, (H-hv)/L) + + !NOTE: fg*(fv/fg - fv/fg * Sw_) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to ground only) + Svw = Sv * (Sw-Sw_) + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sv+Sw-Svw > 1) THEN + Svw = Sv+Sw-1 + ENDIF + + ! Calibrated building ground shadow + Fsv = Sv + Fsvw = Svw + Fsvg = Fsv - Fsvw + + ! View factor from veg to sky and walls above canopy + Fvs = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + + Sw_ = ShadowWall_dif(fb/fg, hv/L) + fv_ = fv - fv*Sw_ + Sv = ShadowTree(fv_, PI/3) + + ! Overlapped shadow between tree and building + ! (to ground only) + Svw = Sv * (Sw-Sw_) + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sv+Sw-Svw > 1) THEN + Svw = Sv+Sw-1 + ENDIF + + ! Calibrated building ground shadow + Fgv = Sv + Fgvw = Svw + Fgvs = Fgv - Fgvw + + ! View factor from veg to sky and walls below+above canopy + Fvg = 0.5*(1-Sw_) + Fvw = 0.5*Sw_ + Fvw + + Fvw = 1 - Fvs - Fvg + + !Fvs = Fsv*fg/min(4*fv,2*fg) + !Fvg = Fgv*fg/min(4*fv,2*fg) + !Fvw = 1 - Fvs - Fvg + + !ws = (phi_tot - phi_dif)/2 + !wg = (phi_tot + phi_dif)/2 + !ww = (phi_tot + phi_dif)/2 + !sumw = Fvs*ws + Fvg*wg + Fvw*ww + !Fvs = Fvs*ws/sumw + !Fvg = Fvg*wg/sumw + !Fvw = Fvw*ww/sumw + + ! Canopy mode: + Fwv = max(fv,0.5*(Fsv+Fgv))*2*fg*Fvw/(4*HL*fb) + Fwv = min(0.8, Fwv) + + fac1 = 1.*hv/H + fac2 = 1.*(H-hv)/H + Fwvw = Fwv/(1 + Fws*fac1/Fww + Fwg*fac2/Fww) + Fwvs = Fws*fac1/Fww*Fwvw + Fwvg = Fwg*fac2/Fww*Fwvw + + ! set upper limit + Fwvw = min(Fww, Fwvw) + Fwvs = min(Fws, Fwvs) + Fwvg = min(Fwg, Fwvg) + + Fwv = Fwvw + Fwvs + Fwvg + + ! View factors with trees + !--------------------------------------------------------- + Fsw_ = Fsw - Fsvw + Fsvw*Td + Fsg_ = Fsg - Fsvg + Fsvg*Td + Fgw_ = Fgw - Fgvw + Fgvw*Td + Fgs_ = Fgs - Fgvs + Fgvs*Td + Fwg_ = Fwg - Fwvg + Fwvg*Td + Fww_ = Fww - Fwvw + Fwvw*Td + Fws_ = Fws - Fwvs + Fwvs*Td + + ! Calculate sunlit wall fraction + !------------------------------------------------- + + ! Building wall shadow + Sw = ShadowWall_dir(fb/fg, HL, theta) + + Sw_ = Sw; fv_ = fv; + + Sw_ = ShadowWall_dir(fb/fg, (H-hv)/L, theta) + fv_ = fv - fv*Sw_ + + ! Tree shadow (to all area) + Sv = ShadowTree(fv_, theta) + + ! Overlapped shadow between tree and building + ! (to ground only) + Svw = (Sw-Sw_) * Sv + + ! convert Sv to ground ratio + Sv = min(1., Sv/fg) + + ! robust check + IF (Sv+Sw-Svw > 1) THEN + Svw = Sv+Sw-1 + ENDIF + + ! Calibrated building ground shadow + Sw = Sw - Svw + + ! Sunlit/shaded wall fraction + fwsun = 0.5 * (Sw*fg + fb) / (4/PI*fb*HL*tan(theta) + fb) + fwsha = 1. - fwsun + + ! Calculate radiation transfer matrix + ! AX = B + !------------------------------------------------- + A(1,:) = (/1-Fww_*fwsun*awall, -Fww_*fwsun*awall, & + -Fgw_*fwsun*awall, -Fgw_*fwsun*awall, -Fvw*fwsun*awall/) + + A(2,:) = (/ -Fww_*fwsha*awall, 1-Fww_*fwsha*awall, & + -Fgw_*fwsha*awall, -Fgw_*fwsha*awall, -Fvw*fwsha*awall/) + + A(3,:) = (/ -Fwg_*fgimp*agimp, -Fwg_*fgimp*agimp, & + 1._r8, 0._r8, -Fvg*fgimp*agimp/) + + A(4,:) = (/ -Fwg_*fgper*agper, -Fwg_*fgper*agper, & + 0._r8, 1._r8, -Fvg*fgper*agper/) + + A(5,:) = (/ -Fwv*av , -Fwv*av , & + -Fgv*av , -Fgv*av , 1._r8/) + + ! Inverse of matrix A + Ainv = MatrixInverse(A) + + ! Radiation transfer for incident direct case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Sw + Ewsha = Svw*Td + Eg = 1-Sw-Sv+(Sv-Svw)*Td + Egimp = Eg*fgimp + Egper = Eg*fgper + Ev = Sv + + ! Vector of first scattering radiation on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper, Ev*av/) + + ! Matrix computing to resolve multiple reflections + X = matmul(Ainv, B) + + !------------------------------------------------- + ! SAVE results for output + !------------------------------------------------- + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(1) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(1) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(1) = X(3)/agimp*(1-agimp)!/fgimp + sgper(1) = X(4)/agper*(1-agper)!/fgper + sveg (1) = X(5)/av *(1-av-Td)!/(fv/fg) + + ! albedo of urban canopy + albu(1) = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + + ! Energy balance check + eb = swsun(1) + swsha(1) + sgimp(1) + sgper(1) + sveg(1) + albu(1) + IF (abs(eb-1) > 1e-6) THEN + print *, "Direct tree - Energy Balance Check error!", eb-1 + ENDIF + + ! Radiation transfer for incident diffuse case + !------------------------------------------------- + + ! Incident radiation on sunlit/shaded wall and + ! impervious/pervious ground + Ewsun = Fsw_*fwsun + Ewsha = Fsw_*fwsha + Eg = Fsg_ + Egimp = Eg*fgimp + Egper = Eg*fgper + Ev = Fsv + + ! Vector of first scattering radiation on each surface + B(:) = (/Ewsun*awall, Ewsha*awall, Egimp*agimp, Egper*agper, Ev*av/) + + ! Equation solve + X = matmul(Ainv, B) + + ! Radiation absorption by each surface + !NOTE: for 3D, absorption per unit area: 4*HL*fb/fg + ! for canyon: absorption per unit area: 2*HW + swsun(2) = X(1)/awall*(1-awall)!/(4*fwsun*HL*fb/fg) + swsha(2) = X(2)/awall*(1-awall)!/(4*fwsha*HL*fb/fg) + sgimp(2) = X(3)/agimp*(1-agimp)!/fgimp + sgper(2) = X(4)/agper*(1-agper)!/fgper + sveg (2) = X(5)/ av*(1-av-Td)!/(fv/fg) + + ! albedo of urban canopy + albu(2) = X(1)*Fws_ + X(2)*Fws_ + X(3)*Fgs_ + X(4)*Fgs_ + X(5)*Fvs + + ! Energy balance check + eb = swsun(2) + swsha(2) + sgimp(2) + sgper(2) + sveg(2) + albu(2) + IF (abs(eb-1) > 1e-6) THEN + print *, "Diffuse tree - Energy Balance Check error!", eb-1 + ENDIF + + ! convert to per unit area absorption + IF (fb > 0.) THEN + swsun = swsun/(4*fwsun*HL*fb)*fg + swsha = swsha/(4*fwsha*HL*fb)*fg + ENDIF + IF (fgimp > 0.) sgimp = sgimp/fgimp + IF (fgper > 0.) sgper = sgper/fgper + IF ( fv > 0.) sveg = sveg/fv*fg + + ! roof absorption + sroof = 1. - aroof + + ! albedo account for both roof and urban's wall and ground + albu = aroof*fb + albu*fg + + END SUBROUTINE UrbanVegShortwave + + !------------------------------------------------- + ! calculate shadow of wall for incident direct radiation + FUNCTION ShadowWall_dir(f, HL, theta) result(Sw) + + IMPLICIT NONE + + real(r8), intent(in) :: f + real(r8), intent(in) :: HL + real(r8), intent(in) :: theta + + real(r8) :: Sw + + Sw = 1 - exp( -4/PI*f*HL*tan(theta) ) + + END FUNCTION ShadowWall_dir + + !------------------------------------------------- + ! calculate shadow of wall for incident diffuse radiation + FUNCTION ShadowWall_dif(f, HL) result(Sw) + + IMPLICIT NONE + + real(r8), intent(in) :: f + real(r8), intent(in) :: HL + + real(r8) :: Sw + + Sw = 1 - exp( -4/PI*f*HL*tan( (53-sqrt(f*HL*100))/180*PI ) ) + + END FUNCTION ShadowWall_dif + + !------------------------------------------------- + ! calculate shadow of tree + FUNCTION ShadowTree(f, theta) result(Sv) + + IMPLICIT NONE + + real(r8), intent(in) :: f + real(r8), intent(in) :: theta + + real(r8) :: mu + real(r8) :: Sv + + mu = cos(theta) + Sv = max( f, (1.-exp(-f/mu))/(1.-f*exp(-1./mu)) ) + + END FUNCTION ShadowTree + + + !------------------------------------------------- + ! Returns the inverse of a matrix calculated by finding the LU + ! decomposition. Depends on LAPACK. + FUNCTION MatrixInverse(A) result(Ainv) + + IMPLICIT NONE + + real(r8), dimension(:,:), intent(in) :: A + real(r8), dimension(size(A,1),size(A,2)) :: Ainv + real(r8), dimension(size(A,1)) :: work !work array for LAPACK + integer, dimension(size(A,1)) :: ipiv !pivot indices + integer :: n, info + + ! External procedures defined in LAPACK + external DGETRF + external DGETRI + + ! Store A in Ainv to prevent it from being overwritten by LAPACK + Ainv = A + n = size(A,1) + + ! DGETRF computes an LU factorization of a general M-by-N matrix A + ! using partial pivoting with row interchanges. + CALL DGETRF(n, n, Ainv, n, ipiv, info) + IF (info /= 0) THEN + CALL CoLM_stop('Matrix is numerically singular!') + ENDIF + + ! DGETRI computes the inverse of a matrix using the LU factorization + ! computed by DGETRF. + CALL DGETRI(n, Ainv, n, ipiv, work, n, info) + IF (info /= 0) THEN + CALL CoLM_stop('Matrix inversion failed!') + ENDIF + + END FUNCTION MatrixInverse + +END MODULE MOD_Urban_Shortwave +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 new file mode 100644 index 0000000000..3a5f772250 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Thermal.F90 @@ -0,0 +1,1402 @@ +#include + +MODULE MOD_Urban_Thermal + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! This is the main subroutine to execute the calculation of urban +! thermal processes and surface fluxes +! +! Created by Hua Yuan, 09/2021 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + PRIVATE + + PUBLIC :: UrbanTHERMAL + +CONTAINS + + + SUBROUTINE UrbanTHERMAL ( & + + ! model running information + ipatch ,patchtype ,lbr ,lbi ,& + lbp ,lbl ,deltim ,patchlatr ,& + ! forcing + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,forc_t ,forc_q ,forc_psrf ,& + forc_rhoair ,forc_frl ,forc_po2m ,forc_pco2m ,& + forc_sols ,forc_soll ,forc_solsd ,forc_solld ,& + theta ,sabroof ,sabwsun ,sabwsha ,& + sabgimp ,sabgper ,sablake ,sabv ,& + par ,Fhac ,Fwst ,Fach ,& + Fahe ,Fhah ,vehc ,meta ,& + ! LUCY model input parameters + fix_holiday ,week_holiday ,hum_prof ,pop_den ,& + vehicle ,weh_prof ,wdh_prof ,idate ,& + patchlonr ,& + ! surface parameters + froof ,flake ,hroof ,hlr ,& + fgper ,pondmx ,eroof ,ewall ,& + egimp ,egper ,trsmx0 ,zlnd ,& + zsno ,capr ,cnfac ,vf_quartz ,& + vf_gravels ,vf_om ,vf_sand ,wf_gravels ,& + wf_sand ,csol ,porsl ,psi0 ,& +#ifdef Campbell_SOIL_MODEL + bsw ,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r ,alpha_vgm ,n_vgm ,L_vgm ,& + sc_vgm ,fc_vgm ,& +#endif + k_solids ,dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,& + cv_roof ,cv_wall ,cv_gimp ,& + tk_roof ,tk_wall ,tk_gimp ,dz_roofsno ,& + dz_gimpsno ,dz_gpersno ,dz_lakesno ,dz_wall ,& + z_roofsno ,z_gimpsno ,z_gpersno ,z_lakesno ,& + z_wall ,zi_roofsno ,zi_gimpsno ,zi_gpersno ,& + zi_lakesno ,zi_wall ,dz_lake ,lakedepth ,& + dewmx ,sqrtdi ,rootfr ,effcon ,& + vmax25 ,c3c4 ,slti ,hlti ,shti,& + hhti ,trda ,trdm ,trop ,& + g1 ,g0 ,gradm ,binter ,& + extkn ,lambda ,& + + ! surface status + fsno_roof ,fsno_gimp ,fsno_gper ,scv_roof ,& + scv_gimp ,scv_gper ,scv_lake ,snowdp_roof ,& + snowdp_gimp ,snowdp_gper ,snowdp_lake ,fwsun ,& + dfwsun ,lai ,sai ,htop ,& + hbot ,fveg ,sigf ,extkd ,& + lwsun ,lwsha ,lgimp ,lgper ,& + t_grnd ,t_roofsno ,t_wallsun ,t_wallsha ,& + t_gimpsno ,t_gpersno ,t_lakesno ,wliq_roofsno ,& + wliq_gimpsno ,wliq_gpersno ,wliq_lakesno ,wice_roofsno ,& + wice_gimpsno ,wice_gpersno ,wice_lakesno ,t_lake ,& + lake_icefrac ,savedtke1 ,lveg ,tleaf ,& + ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + troom ,troof_inner ,twsun_inner ,twsha_inner ,& + troommax ,troommin ,tafu ,& + +! SNICAR model variables + snofrz ,sabg_lyr ,& +! END SNICAR model variables + + ! output + taux ,tauy ,fsena ,fevpa ,& + lfevpa ,fsenl ,fevpl ,etr ,& + fseng ,fevpg ,olrg ,fgrnd ,& + fsen_roof ,fsen_wsun ,fsen_wsha ,fsen_gimp ,& + fsen_gper ,fsen_urbl ,troof ,twall ,& + lfevp_roof ,lfevp_gimp ,lfevp_gper ,lfevp_urbl ,& + qseva_roof ,qseva_gimp ,qseva_gper ,qseva_lake ,& + qsdew_roof ,qsdew_gimp ,qsdew_gper ,qsdew_lake ,& + qsubl_roof ,qsubl_gimp ,qsubl_gper ,qsubl_lake ,& + qfros_roof ,qfros_gimp ,qfros_gper ,qfros_lake ,& + imelt_roof ,imelt_gimp ,imelt_gper ,imelt_lake ,& + sm_roof ,sm_gimp ,sm_gper ,sm_lake ,& + sabg ,rstfac ,rootr ,etr_deficit ,& + tref ,qref ,trad ,rst ,& + assim ,respc ,errore ,emis ,& + z0m ,zol ,rib ,ustar ,& + qstar ,tstar ,fm ,fh ,& + fq ,hpbl ) + + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Vars_Global + USE MOD_Const_Physical, only: denh2o,roverg,hvap,hsub,rgas,cpair,& + stefnc,denice,tfrz,vonkar,grav + USE MOD_Urban_Shortwave + USE MOD_Urban_Longwave + USE MOD_Urban_GroundFlux + USE MOD_Urban_Flux + USE MOD_Urban_RoofTemperature + USE MOD_Urban_WallTemperature + USE MOD_Urban_PerviousTemperature + USE MOD_Urban_ImperviousTemperature + USE MOD_Lake + USE MOD_Urban_BEM + USE MOD_Urban_LUCY, only: LUCY + USE MOD_Eroot, only: eroot +#ifdef vanGenuchten_Mualem_SOIL_MODEL + USE MOD_Hydro_SoilFunction, only: soil_psi_from_vliq +#endif + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + integer, intent(in) :: & + idate(3) ,& + ipatch ,&! patch index + patchtype ,&! land patch type (0=soil, 1=urban or built-up, 2=wetland, + ! 3=glacier/ice sheet, 4=land water bodies) + lbr ,&! lower bound of array + lbi ,&! lower bound of array + lbp ,&! lower bound of array + lbl ! lower bound of array + + real(r8), intent(in) :: & + deltim ,&! seconds in a time step [second] + patchlatr ! latitude in radians + + real(r8), intent(in) :: & + patchlonr ,&! longitude of patch [radian] + fix_holiday(365) ,&! Fixed public holidays, holiday(0) or workday(1) + week_holiday(7) ,&! week holidays + hum_prof(24) ,&! Diurnal metabolic heat profile + weh_prof(24) ,&! Diurnal traffic flow profile of weekend + wdh_prof(24) ,&! Diurnal traffic flow profile of weekday + pop_den ,&! population density + vehicle(3) ! vehicle numbers per thousand people + + real(r8), intent(in) :: & + ! atmospherical variables and observational height + forc_hgt_u ,&! observational height of wind [m] + forc_hgt_t ,&! observational height of temperature [m] + forc_hgt_q ,&! observational height of humidity [m] + forc_us ,&! wind component in eastward direction [m/s] + forc_vs ,&! wind component in northward direction [m/s] + forc_t ,&! temperature at agcm reference height [kelvin] + forc_q ,&! specific humidity at agcm reference height [kg/kg] + forc_psrf ,&! atmosphere pressure at the surface [pa] + forc_rhoair ,&! density air [kg/m3] + forc_frl ,&! atmospheric infrared (longwave) radiation [W/m2] + forc_po2m ,&! O2 concentration in atmos. (pascals) + forc_pco2m ,&! CO2 concentration in atmos. (pascals) + forc_sols ,&! atm vis direct beam solar rad onto srf [W/m2] + forc_soll ,&! atm nir direct beam solar rad onto srf [W/m2] + forc_solsd ,&! atm vis diffuse solar rad onto srf [W/m2] + forc_solld ,&! atm nir diffuse solar rad onto srf [W/m2] + theta ,&! sun zenith angle + par ,&! vegetation PAR + sabv ,&! absorbed shortwave radiation by vegetation [W/m2] + sabroof ,&! absorbed shortwave radiation by roof [W/m2] + sabwsun ,&! absorbed shortwave radiation by sunlit wall [W/m2] + sabwsha ,&! absorbed shortwave radiation by shaded wall [W/m2] + sabgimp ,&! absorbed shortwave radiation by impervious road [W/m2] + sabgper ,&! absorbed shortwave radiation by ground snow [W/m2] + sablake ! absorbed shortwave radiation by lake [W/m2] + + real(r8), intent(in) :: & + froof ,&! roof fractional cover [-] + flake ,&! urban lake fractional cover [-] + hroof ,&! average building height [m] + hlr ,&! average building height to their side length [-] + fgper ,&! impervious road fractional cover [-] + pondmx ,&! maximum ponding for soil [mm] + eroof ,&! emissivity of roof + ewall ,&! emissivity of walls + egimp ,&! emissivity of impervious road + egper ,&! emissivity of soil + + trsmx0 ,&! max transpiration for moist soil+100% veg. [mm/s] + zlnd ,&! roughness length for soil [m] + zsno ,&! roughness length for snow [m] + capr ,&! tuning factor to turn first layer T into surface T + cnfac ,&! Crank Nicholson factor between 0 and 1 + + ! soil physical parameters + vf_quartz (1:nl_soil) ,&! volumetric fraction of quartz within mineral soil + vf_gravels(1:nl_soil) ,&! volumetric fraction of gravels + vf_om (1:nl_soil) ,&! volumetric fraction of organic matter + vf_sand (1:nl_soil) ,&! volumetric fraction of sand + wf_gravels(1:nl_soil) ,&! gravimetric fraction of gravels + wf_sand (1:nl_soil) ,&! gravimetric fraction of sand + csol (1:nl_soil) ,&! heat capacity of soil solids [J/(m3 K)] + porsl (1:nl_soil) ,&! soil porosity [-] + psi0 (1:nl_soil) ,&! soil water suction, negative potential [mm] +#ifdef Campbell_SOIL_MODEL + bsw (1:nl_soil) ,&! clapp and hornberger "b" parameter [-] +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r (1:nl_soil) ,&! residual water content (cm3/cm3) + + alpha_vgm (1:nl_soil) ,&! parameter correspond approximately to inverse of air-entry value + n_vgm (1:nl_soil) ,&! a shape parameter + L_vgm (1:nl_soil) ,&! pore-connectivity parameter + sc_vgm (1:nl_soil) ,&! saturation at air entry value in classical vanGenuchten model [-] + fc_vgm (1:nl_soil) ,&! a scaling factor by using air entry value in the Mualem model [-] +#endif + k_solids (1:nl_soil) ,&! thermal conductivity of minerals soil [W/m-K] + dkdry (1:nl_soil) ,&! thermal conductivity of dry soil [W/m-K] + dksatu (1:nl_soil) ,&! thermal conductivity of saturated unfrozen soil [W/m-K] + dksatf (1:nl_soil) ,&! thermal conductivity of saturated frozen soil [W/m-K] + + BA_alpha (1:nl_soil) ,&! alpha in Balland and Arp(2005) thermal cond. scheme + BA_beta (1:nl_soil) ,&! beta in Balland and Arp(2005) thermal cond. scheme + cv_roof (1:nl_roof) ,&! heat capacity of roof [J/(m2 K)] + cv_wall (1:nl_wall) ,&! heat capacity of wall [J/(m2 K)] + cv_gimp (1:nl_soil) ,&! heat capacity of impervious [J/(m2 K)] + tk_roof (1:nl_roof) ,&! thermal conductivity of roof [W/m-K] + tk_wall (1:nl_wall) ,&! thermal conductivity of wall [W/m-K] + tk_gimp (1:nl_soil) ,&! thermal conductivity of impervious [W/m-K] + + dz_roofsno(lbr :nl_roof) ,&! layer thickness [m] + dz_gimpsno(lbi :nl_soil) ,&! layer thickness [m] + dz_gpersno(lbp :nl_soil) ,&! layer thickness [m] + dz_wall ( 1:nl_wall) ,&! layer thickness [m] + z_roofsno (lbr :nl_roof) ,&! node depth [m] + z_gimpsno (lbi :nl_soil) ,&! node depth [m] + z_gpersno (lbp :nl_soil) ,&! node depth [m] + z_wall ( 1:nl_wall) ,&! node depth [m] + zi_roofsno(lbr-1:nl_roof) ,&! interface depth [m] + zi_gimpsno(lbi-1:nl_soil) ,&! interface depth [m] + zi_gpersno(lbp-1:nl_soil) ,&! interface depth [m] + zi_wall ( 0:nl_wall) ,&! interface depth [m] + dz_lake ( 1:nl_lake) ,&! lake layer thickness (m) + lakedepth ,&! lake depth (m) + + z_lakesno (maxsnl+1:nl_soil) ,&! node depth [m] + dz_lakesno(maxsnl+1:nl_soil) ,&! layer thickness [m] + zi_lakesno(maxsnl :nl_soil) ,&! interface depth [m] + + ! vegetation parameters + dewmx ,&! maximum dew + sqrtdi ,&! inverse sqrt of leaf dimension [m**-0.5] + rootfr (1:nl_soil) ,&! root fraction + + effcon ,&! quantum efficiency of RuBP regeneration (mol CO2/mol quanta) + vmax25 ,&! maximum carboxylation rate at 25 C at canopy top + slti ,&! slope of low temperature inhibition function [s3] + hlti ,&! 1/2 point of low temperature inhibition function [s4] + shti ,&! slope of high temperature inhibition function [s1] + hhti ,&! 1/2 point of high temperature inhibition function [s2] + trda ,&! temperature coefficient in gs-a model [s5] + trdm ,&! temperature coefficient in gs-a model [s6] + trop ,&! temperature coefficient in gs-a model + g1 ,&! conductance-photosynthesis slope parameter for medlyn model + g0 ,&! conductance-photosynthesis intercept for medlyn model + gradm ,&! conductance-photosynthesis slope parameter + binter ,&! conductance-photosynthesis intercept + lambda ,&! marginal water cost of carbon gain + extkn ! coefficient of leaf nitrogen allocation + + integer , intent(in) :: & + c3c4 ! 1 for C3, 0 for C4 + + real(r8), intent(in) :: & + fsno_roof ,&! fraction of ground covered by snow + fsno_gimp ,&! fraction of ground covered by snow + fsno_gper ,&! fraction of ground covered by snow + dfwsun ,&! change of fwsun [%] + lai ,&! adjusted leaf area index for seasonal variation [-] + sai ,&! stem area index [-] + htop ,&! canopy crown top height [m] + hbot ,&! canopy crown bottom height [m] + fveg ,&! fraction of veg cover + sigf ,&! fraction of veg cover, excluding snow-covered veg [-] + extkd ! diffuse and scattered diffuse PAR extinction coefficient + + real(r8), intent(in) :: hpbl ! atmospheric boundary layer height [m] + + real(r8), intent(inout) :: & + fwsun ,&! fraction of sunlit wall [-] + lwsun ,&! net longwave radiation of sunlit wall + lwsha ,&! net longwave radiation of shaded wall + lgimp ,&! net longwave radiation of impervious road + lgper ,&! net longwave radiation of pervious road + t_grnd ,&! ground temperature + t_roofsno ( lbr:nl_wall) ,&! temperatures of roof layers + t_wallsun ( nl_wall) ,&! temperatures of roof layers + t_wallsha ( nl_wall) ,&! temperatures of roof layers + t_gimpsno ( lbi:nl_soil) ,&! temperatures of roof layers + t_gpersno ( lbp:nl_soil) ,&! temperatures of roof layers + wliq_roofsno( lbr:nl_roof) ,&! liquid water [kg/m2] + wliq_gimpsno( lbi:nl_soil) ,&! liquid water [kg/m2] + wliq_gpersno( lbp:nl_soil) ,&! liquid water [kg/m2] + wice_roofsno( lbr:nl_roof) ,&! ice lens [kg/m2] + wice_gimpsno( lbi:nl_soil) ,&! ice lens [kg/m2] + wice_gpersno( lbp:nl_soil) ,&! ice lens [kg/m2] + t_lake ( nl_lake) ,&! lake temperature [K] + lake_icefrac( nl_lake) ,&! lake mass fraction of lake layer that is frozen + t_lakesno (maxsnl+1:nl_soil) ,&! temperatures of roof layers + wliq_lakesno(maxsnl+1:nl_soil) ,&! liquid water [kg/m2] + wice_lakesno(maxsnl+1:nl_soil) ,&! ice lens [kg/m2] + savedtke1 ,&! top level eddy conductivity (W/m K) + scv_roof ,&! snow cover, water equivalent [mm, kg/m2] + scv_gimp ,&! snow cover, water equivalent [mm, kg/m2] + scv_gper ,&! snow cover, water equivalent [mm, kg/m2] + scv_lake ,&! snow cover, water equivalent [mm, kg/m2] + snowdp_roof ,&! snow depth [m] + snowdp_gimp ,&! snow depth [m] + snowdp_gper ,&! snow depth [m] + snowdp_lake ,&! snow depth [m] + lveg ,&! net longwave radiation of vegetation [W/m2] + tleaf ,&! leaf temperature [K] + ldew ,&! depth of water on foliage [kg/(m2 s)] + ldew_rain ,&! depth of rain on foliage [kg/(m2 s)] + ldew_snow ,&! depth of rain on foliage [kg/(m2 s)] + fwet_snow ,&! vegetation canopy snow fractional cover [-] + troom ,&! temperature of inner building + troof_inner ,&! temperature of inner roof + twsun_inner ,&! temperature of inner sunlit wall + twsha_inner ,&! temperature of inner shaded wall + troommax ,&! maximum temperature of inner building + troommin ,&! minimum temperature of inner building + tafu ,&! temperature of outer building + Fahe ,&! flux from metabolic and vehicle + Fhah ,&! flux from heating + Fhac ,&! flux from heat or cool AC + Fwst ,&! waste heat from cool or heat + Fach ,&! flux from air exchange + vehc ,&! flux from vehicle + meta ! flux from metabolic + + real(r8), intent(out) :: & + taux ,&! wind stress: E-W [kg/m/s**2] + tauy ,&! wind stress: N-S [kg/m/s**2] + fsena ,&! sensible heat from canopy height to atm [W/m2] + fevpa ,&! evapotranspiration from canopy height to atm [mm/s] + lfevpa ,&! latent heat flux from canopy height to atm [W/m2] + fsenl ,&! sensible heat from leaves [W/m2] + fevpl ,&! evaporation+transpiration from leaves [mm/s] + etr ,&! transpiration rate [mm/s] + fseng ,&! sensible heat flux from ground [W/m2] + fevpg ,&! evaporation heat flux from ground [mm/s] + olrg ,&! outgoing long-wave radiation from ground+canopy + fgrnd ,&! ground heat flux [W/m2] + + fsen_roof ,&! sensible heat from roof [W/m2] + fsen_wsun ,&! sensible heat from sunlit wall [W/m2] + fsen_wsha ,&! sensible heat from shaded wall [W/m2] + fsen_gimp ,&! sensible heat from impervious road [W/m2] + fsen_gper ,&! sensible heat from pervious road [W/m2] + fsen_urbl ,&! sensible heat from urban vegetation [W/m2] + + lfevp_roof ,&! latent heat flux from roof [W/m2] + lfevp_gimp ,&! latent heat flux from impervious road [W/m2] + lfevp_gper ,&! latent heat flux from pervious road [W/m2] + lfevp_urbl ,&! latent heat flux from urban vegetation [W/m2] + + troof ,&! temperature of roof [K] + twall ,&! temperature of wall [K] + + qseva_roof ,&! ground soil surface evaporation rate (mm h2o/s) + qseva_gimp ,&! ground soil surface evaporation rate (mm h2o/s) + qseva_gper ,&! ground soil surface evaporation rate (mm h2o/s) + qseva_lake ,&! ground soil surface evaporation rate (mm h2o/s) + qsdew_roof ,&! ground soil surface dew formation (mm h2o /s) [+] + qsdew_gimp ,&! ground soil surface dew formation (mm h2o /s) [+] + qsdew_gper ,&! ground soil surface dew formation (mm h2o /s) [+] + qsdew_lake ,&! ground soil surface dew formation (mm h2o /s) [+] + qsubl_roof ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qsubl_gimp ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qsubl_gper ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qsubl_lake ,&! sublimation rate from soil ice pack (mm h2o /s) [+] + qfros_roof ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gimp ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_gper ,&! surface dew added to snow pack (mm h2o /s) [+] + qfros_lake ! surface dew added to snow pack (mm h2o /s) [+] + + integer, intent(out) :: & + imelt_roof(lbr:nl_roof) ,&! flag for melting or freezing [-] + imelt_gimp(lbi:nl_soil) ,&! flag for melting or freezing [-] + imelt_gper(lbp:nl_soil) ,&! flag for melting or freezing [-] + imelt_lake(maxsnl+1:nl_soil) ! flag for melting or freezing [-] + + real(r8), intent(out) :: & + sm_roof ,&! rate of snowmelt [kg/(m2 s)] + sm_gimp ,&! rate of snowmelt [kg/(m2 s)] + sm_gper ,&! rate of snowmelt [kg/(m2 s)] + sm_lake ,&! rate of snowmelt [kg/(m2 s)] + sabg ,&! overall ground solar radiation absorption (+wall) + rstfac ,&! factor of soil water stress + rootr(1:nl_soil) ,&! root resistance of a layer, all layers add to 1 + etr_deficit ,&! urban irrigation [mm/s] + tref ,&! 2 m height air temperature [kelvin] + qref ,&! 2 m height air specific humidity + trad ,&! radiative temperature [K] + rst ,&! stomatal resistance (s m-1) + assim ,&! assimilation + respc ,&! respiration + errore ,&! energy balance error [w/m2] + + ! additional variables required by coupling with WRF or RSM model + emis ,&! averaged bulk surface emissivity + z0m ,&! effective roughness [m] + zol ,&! dimensionless height (z/L) used in Monin-Obukhov theory + rib ,&! bulk Richardson number in surface layer + ustar ,&! u* in similarity theory [m/s] + qstar ,&! q* in similarity theory [kg/kg] + tstar ,&! t* in similarity theory [K] + fm ,&! integral of profile function for momentum + fh ,&! integral of profile function for heat + fq ! integral of profile function for moisture + +! SNICAR model variables + real(r8), intent(in) :: sabg_lyr(lbp:1) !snow layer absorption + real(r8), intent(out) :: snofrz (lbp:0) !snow freezing rate (col,lyr) [kg m-2 s-1] +! END SNICAR model variables + +!-------------------------- Local Variables ---------------------------- + + integer :: nurb ! number of aboveground urban components [-] + + logical :: doveg ! run model with vegetation + + real(r8) :: & + fg ,&! ground fraction ( impervious + soil + snow ) + fsenroof ,&! sensible heat flux from roof [W/m2] + fsenwsun ,&! sensible heat flux from sunlit wall [W/m2] + fsenwsha ,&! sensible heat flux from shaded wall [W/m2] + fsengimp ,&! sensible heat flux from impervious road [W/m2] + fsengper ,&! sensible heat flux from ground soil [W/m2] + fevproof ,&! evaporation heat flux from roof [mm/s] + fevpgimp ,&! evaporation heat flux from impervious road [mm/s] + fevpgper ,&! evaporation heat flux from ground soil [mm/s] + + croofs ,&! deriv of roof sensible heat flux wrt soil temp [w/m**2/k] + cwsuns ,&! deriv of sunlit wall sensible heat flux wrt soil temp [w/m**2/k] + cwshas ,&! deriv of shaded wall sensible heat flux wrt soil temp [w/m**2/k] + cgrnds ,&! deriv of ground latent heat flux wrt soil temp [w/m**2/k] + croofl ,&! deriv of roof latent heat flux wrt soil temp [w/m**2/k] + cgimpl ,&! deriv of impervious latent heat flux wrt soil temp [w/m**2/k] + cgperl ,&! deriv of pervious latent heat flux wrt soil temp [w/m**2/k] + croof ,&! deriv of roof total flux wrt soil temp [w/m**2/k] + cgimp ,&! deriv of impervious total heat flux wrt soil temp [w/m**2/k] + cgper ,&! deriv of pervious total heat flux wrt soil temp [w/m**2/k] + + dqroofdT ,&! d(qroof)/dT + dqgimpdT ,&! d(qgimp)/dT + dqgperdT ,&! d(qgper)/dT + + degdT ,&! d(eg)/dT + eg ,&! water vapor pressure at temperature T [pa] + egsmax ,&! max. evaporation which soil can provide at one time step + egidif ,&! the excess of evaporation over "egsmax" + emg ,&! ground emissivity (0.97 for snow, + ! glaciers and water surface; 0.96 for soil and wetland) + etrc ,&! maximum possible transpiration rate [mm/s] + fac ,&! soil wetness of surface layer + factr(lbr:nl_roof) ,&! used in computing tridiagonal matrix + facti(lbi:nl_soil) ,&! used in computing tridiagonal matrix + factp(lbp:nl_soil) ,&! used in computing tridiagonal matrix + hr ,&! relative humidity + htvp_roof ,&! latent heat of vapor of water (or sublimation) [J/Kg] + htvp_gimp ,&! latent heat of vapor of water (or sublimation) [J/Kg] + htvp_gper ,&! latent heat of vapor of water (or sublimation) [J/Kg] + olru ,&! olrg excluding downwelling reflection [W/m2] + olrb ,&! olrg assuming black body emission [W/m2] + psit ,&! negative potential of soil + + rss ,&! soil resistance + qroof ,&! roof specific humidity [kg/kg] + qgimp ,&! ground impervious road specific humidity [kg/kg] + qgper ,&! ground pervious specific humidity [kg/kg] + qsatg ,&! saturated humidity [kg/kg] + qsatgdT ,&! d(qsatg)/dT + qred ,&! soil surface relative humidity + thm ,&! intermediate variable (forc_t+0.0098*forc_hgt_t) + th ,&! potential temperature (kelvin) + thv ,&! virtual potential temperature (kelvin) + + twsun ,&! temperature of sunlit wall + twsha ,&! temperature of shaded wall + tgimp ,&! temperature of impervious road + tgper ,&! ground soil temperature + tlake ,&! lake surface temperature + troof_bef ,&! temperature of roof + twsun_bef ,&! temperature of sunlit wall + twsha_bef ,&! temperature of shaded wall + tgimp_bef ,&! temperature of impervious road + tgper_bef ,&! ground soil temperature + troof_nl_bef ,&! temperature of roof + twsun_nl_bef ,&! temperature of sunlit wall + twsha_nl_bef ,&! temperature of shaded wall + tkdz_roof ,&! heat flux from room to roof + tkdz_wsun ,&! heat flux from room to sunlit wall + tkdz_wsha ,&! heat flux from room to shaded wall + tinc ,&! temperature difference of two time step + ev ,&! emissivity of vegetation [-] + lroof ,&! net longwave radiation of roof + rout ,&! out-going longwave radiation from roof + lout ,&! out-going longwave radiation + lnet ,&! overall net longwave radiation + dlw ,&! change of net longwave radiation + dlwbef ,&! change of net longwave radiation + dlwsun ,&! change of net longwave radiation of sunlit wall + dlwsha ,&! change of net longwave radiation of shaded wall + dlgimp ,&! change of net longwave radiation of impervious road + dlgper ,&! change of net longwave radiation of pervious road + dlveg ,&! change of net longwave radiation of vegetation [W/m2] + dlout ,&! change of out-going radiation due to temp change + clroof ,&! deriv of lroof wrt roof temp [w/m**2/k] + clwsun ,&! deriv of lwsun wrt wsun temp [w/m**2/k] + clwsha ,&! deriv of lwsha wrt wsha temp [w/m**2/k] + clgimp ,&! deriv of lgimp wrt gimp temp [w/m**2/k] + clgper ,&! deriv of lgper wrt soil temp [w/m**2/k] + fwsha ,&! fraction of shaded wall [-] + ur ,&! wind speed at reference height [m/s] + wx ,&! partial volume of ice and water of surface layer + xmf ! total latent heat of phase change of ground water + + real(r8) :: & + taux_lake ,&! wind stress: E-W [kg/m/s**2] + tauy_lake ,&! wind stress: N-S [kg/m/s**2] + fsena_lake ,&! sensible heat from canopy height to atmosphere [W/m2] + fevpa_lake ,&! evapotranspiration from canopy height to atmosphere [mm/s] + lfevpa_lake ,&! latent heat flux from canopy height to atmosphere [W/m2] + fseng_lake ,&! sensible heat flux from ground [W/m2] + fevpg_lake ,&! evaporation heat flux from ground [mm/s] + olrg_lake ,&! outgoing long-wave radiation from ground+canopy + fgrnd_lake ,&! ground heat flux [W/m2] + tref_lake ,&! 2 m height air temperature [kelvin] + qref_lake ,&! 2 m height air specific humidity + trad_lake ,&! radiative temperature [K] + lnet_lake ,&! net longwave radiation + emis_lake ,&! averaged bulk surface emissivity + z0m_lake ,&! effective roughness [m] + zol_lake ,&! dimensionless height (z/L) used in Monin-Obukhov theory + rib_lake ,&! bulk Richardson number in surface layer + ustar_lake ,&! u* in similarity theory [m/s] + qstar_lake ,&! q* in similarity theory [kg/kg] + tstar_lake ,&! t* in similarity theory [K] + fm_lake ,&! integral of profile function for momentum + fh_lake ,&! integral of profile function for heat + fq_lake ,&! integral of profile function for moisture + dheatl ! vegetation heat change [W/m2] + + real(r8) :: z0m_g,z0h_g,zol_g,obu_g,ustar_g,qstar_g,tstar_g + real(r8) :: fm10m,fm_g,fh_g,fq_g,fh2m,fq2m,um,obu,eb + + ! definition for urban related + real(r8), allocatable :: Ainv(:,:) ! Inverse of Radiation transfer matrix + real(r8), allocatable :: X(:) ! solution + real(r8), allocatable :: dX(:) ! solution + real(r8), allocatable :: B(:) ! Vectors of incident radiation on each surface + real(r8), allocatable :: B1(:) ! Vectors of incident radiation on each surface + real(r8), allocatable :: dBdT(:) ! Vectors of incident radiation on each surface + real(r8), allocatable :: dT(:) ! Vectors of incident radiation on each surface + real(r8), allocatable :: SkyVF(:) ! View factor to sky + real(r8), allocatable :: VegVF(:) ! View factor to vegetation + real(r8), allocatable :: fcover(:) ! fractional cover of roof, wall, ground and veg + + +!======================================================================= +! [1] Initial set and propositional variables +!======================================================================= + + ! fluxes + fsenl = 0.; fevpl = 0. + etr = 0.; rst = 2.0e4 + assim = 0.; respc = 0. + + emis = 0.; z0m = 0. + zol = 0.; rib = 0. + ustar = 0.; qstar = 0. + tstar = 0.; rootr = 0. + + dheatl = 0. + + ! latent heat, assumed that the sublimation occurred only as wliq_gpersno=0 + htvp_roof = hvap + htvp_gimp = hvap + htvp_gper = hvap + IF (wliq_roofsno(lbr)<=0. .and. wice_roofsno(lbr)>0.) htvp_roof = hsub + IF (wliq_gimpsno(lbi)<=0. .and. wice_gimpsno(lbi)>0.) htvp_gimp = hsub + IF (wliq_gpersno(lbp)<=0. .and. wice_gpersno(lbp)>0.) htvp_gper = hsub + + ! potential temperature at the reference height + thm = forc_t + 0.0098*forc_hgt_t !intermediate variable equivalent to + !forc_t*(pgcm/forc_psrf)**(rgas/cpair) + th = forc_t*(100000./forc_psrf)**(rgas/cpair) !potential T + thv = th*(1.+0.61*forc_q) !virtual potential T + ur = max(0.1,sqrt(forc_us*forc_us+forc_vs*forc_vs)) !limit set to 0.1 + + ! Adjust wall temperature, weighted average according to fwsun, dfwsun + !------------------------------------------- + fwsha = 1. - fwsun + + IF (dfwsun > 0) THEN + t_wallsun = (fwsun*t_wallsun + dfwsun*t_wallsha) / (fwsun+dfwsun) + twsun_inner = (fwsun*twsun_inner + dfwsun*twsun_inner) / (fwsun+dfwsun) + lwsun = (fwsun*lwsun + dfwsun*lwsha ) / (fwsun+dfwsun) + ENDIF + + IF (dfwsun < 0) THEN + t_wallsha = (fwsha*t_wallsha - dfwsun*t_wallsun) / (fwsha-dfwsun) + twsha_inner = (fwsha*twsha_inner - dfwsun*twsun_inner) / (fwsha-dfwsun) + lwsha = (fwsha*lwsha - dfwsun*lwsun ) / (fwsha-dfwsun) + ENDIF + + ! update fwsun + fwsun = fwsun + dfwsun + + ! temperature and water mass from previous time step + twsun = t_wallsun( 1 ) + twsha = t_wallsha( 1 ) + troof = t_roofsno(lbr) + tgimp = t_gimpsno(lbi) + tgper = t_gpersno(lbp) + + troof_nl_bef = t_roofsno(nl_roof) + twsun_nl_bef = t_wallsun(nl_wall) + twsha_nl_bef = t_wallsha(nl_wall) + + !TODO: ???how to calculate tlake + IF (lbl < 1) THEN + tlake = t_lakesno(lbl) + ELSE + tlake = t_lake(1) + ENDIF + + ! SAVE temperature + troof_bef = troof + twsun_bef = twsun + twsha_bef = twsha + tgimp_bef = tgimp + tgper_bef = tgper + + ! SAVE longwave for the last time + dlwsun = lwsun + dlwsha = lwsha + dlgimp = lgimp + dlgper = lgper + dlveg = lveg + + fg = 1. - froof + + IF (lai+sai>1.e-6 .and. fveg>0.) THEN + doveg = .true. + ELSE + doveg = .false. + ENDIF + + ! convert AHE to urban area, i.e. (1-flake) + IF ( 1-flake > 0. ) THEN + Fhac = Fhac / (1-flake) + Fwst = Fwst / (1-flake) + Fach = Fach / (1-flake) + vehc = vehc / (1-flake) + meta = meta / (1-flake) + ENDIF + + +!======================================================================= +! [2] specific humidity and its derivative at ground surface +!======================================================================= + + qred = 1. + CALL qsadv(tgper,forc_psrf,eg,degdT,qsatg,qsatgdT) + + ! initialization for rss + rss = 0. + + IF (patchtype <=1 ) THEN !soil ground + wx = (wliq_gpersno(1)/denh2o + wice_gpersno(1)/denice)/dz_gpersno(1) + IF (porsl(1) < 1.e-6) THEN !bed rock + fac = 0.001 + ELSE + fac = min(1.,wx/porsl(1)) + fac = max( fac, 0.001 ) + ENDIF + +#ifdef Campbell_SOIL_MODEL + psit = psi0(1) * fac ** (- bsw(1) ) !psit = max(smpmin, psit) +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + psit = soil_psi_from_vliq ( fac*(porsl(1)-theta_r(1)) + theta_r(1), & + porsl(1), theta_r(1), psi0(1), & + 5, (/alpha_vgm(1), n_vgm(1), L_vgm(1), sc_vgm(1), fc_vgm(1)/)) +#endif + psit = max( -1.e8, psit ) + hr = exp(psit/roverg/tgper) + qred = (1.-fsno_gper)*hr + fsno_gper + + IF (lbp == 1) THEN !no snow layer exist + + ! calculate soil resistance for evaporation + wx = (sum(wliq_gpersno(1:2))/denh2o+sum(wice_gpersno(1:2))/denice)/sum(dz_gpersno(1:2)) + IF (sum(porsl(1:2)) < 1.e-6) THEN !bed rock + fac = 0.001 + ELSE + fac = min(1.,sum(dz_gpersno(1:2))*wx/(dz_gpersno(1)*porsl(1)+dz_gpersno(2)*porsl(2))) + fac = max( fac, 0.001 ) + ENDIF + + ! Sellers et al., 1992 + rss = (1-fsno_gper)*exp(8.206-4.255*fac) + ENDIF + ENDIF + + qgper = qred*qsatg + dqgperdT = qred*qsatgdT + + IF (qsatg>forc_q .and. forc_q>qred*qsatg) THEN + qgper = forc_q; dqgperdT = 0. + ENDIF + + CALL qsadv(tgimp,forc_psrf,eg,degdT,qsatg,qsatgdT) + qgimp = qsatg + dqgimpdT = qsatgdT + + CALL qsadv(troof,forc_psrf,eg,degdT,qsatg,qsatgdT) + qroof = qsatg + dqroofdT = qsatgdT + + +!======================================================================= +! [3] calculate longwave radiation +!======================================================================= + + IF ( doveg ) THEN + + allocate ( Ainv(5,5) ) + allocate ( X(5) ) + allocate ( dX(5) ) + allocate ( B(5) ) + allocate ( B1(5) ) + allocate ( dBdT(5) ) + allocate ( SkyVF(5) ) + allocate ( VegVF(5) ) + allocate ( fcover(0:5) ) + allocate ( dT(0:5) ) + + ! call longwave function (vegetation) + CALL UrbanVegLongwave ( & + theta, hlr, froof, fgper, hroof, forc_frl, & + twsun, twsha, tgimp, tgper, ewall, egimp, & + egper, lai, sai, fveg, (htop+hbot)/2., & + ev, Ainv, B, B1, dBdT, SkyVF, VegVF, fcover) + ELSE + + allocate ( Ainv(4,4) ) + allocate ( X(4) ) + allocate ( dX(4) ) + allocate ( B(4) ) + allocate ( B1(4) ) + allocate ( dBdT(4) ) + allocate ( SkyVF(4) ) + allocate ( fcover(0:4) ) + allocate ( dT(0:4) ) + + ! call longwave function, calculate Ainv, B, B1, dBdT + CALL UrbanOnlyLongwave ( & + theta, hlr, froof, fgper, hroof, forc_frl, & + twsun, twsha, tgimp, tgper, ewall, egimp, egper, & + Ainv, B, B1, dBdT, SkyVF, fcover) + + ! calculate longwave radiation abs, for UrbanOnlyLongwave + !------------------------------------------- + X = matmul(Ainv, B) + + ! using the longwave radiation transfer matrix to calculate + ! LW radiation absorption by each surface and total absorption. + lwsun = ( ewall*X(1) - B1(1) ) / (1-ewall) + lwsha = ( ewall*X(2) - B1(2) ) / (1-ewall) + lgimp = ( egimp*X(3) - B1(3) ) / (1-egimp) + lgper = ( egper*X(4) - B1(4) ) / (1-egper) + + ! Out-going LW of urban canopy + lout = sum( X * SkyVF ) + + ! Energy balance check + eb = lwsun + lwsha + lgimp + lgper + lout + + IF (abs(eb-forc_frl) > 1e-6) THEN + print *, "Urban Only Longwave - Energy Balance Check error!", eb-forc_frl + ENDIF + + ! fur per unit surface + IF (fcover(1) >0.) lwsun = lwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) + IF (fcover(2) >0.) lwsha = lwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) + IF (fcover(3) >0.) lgimp = lgimp / fcover(3) * fg !/ fgimp + IF (fcover(4) >0.) lgper = lgper / fcover(4) * fg !/ fsoil + + ! added last time value + lwsun = lwsun + dlwsun + lwsha = lwsha + dlwsha + lgimp = lgimp + dlgimp + lgper = lgper + dlgper + ENDIF + + dlwbef = dlwsun*fcover(1) + dlwsha*fcover(2) + dlgimp*fcover(3) + dlgper*fcover(4) + IF ( doveg ) dlwbef = dlwbef + dlveg*fcover(5) + dlwbef = dlwbef*(1-flake) + + ! roof net longwave + lroof = eroof*forc_frl - eroof*stefnc*troof**4 + + +!======================================================================= +! [4] Compute sensible and latent fluxes and their derivatives with respect +! to ground temperature using ground temperatures from previous time step. +!======================================================================= + + ! bare ground case + CALL UrbanGroundFlux (forc_hgt_u,forc_hgt_t,forc_hgt_q,forc_us, & + forc_vs,forc_t,forc_q,forc_rhoair,forc_psrf, & + ur,thm,th,thv,zlnd,zsno,fsno_gimp, & + lbi,wliq_gimpsno(1),wice_gimpsno(1), & + fcover,tgimp,tgper,qgimp,qgper,tref,qref, & + z0m_g,z0h_g,zol_g,ustar_g,qstar_g,tstar_g,fm_g,fh_g,fq_g) + + ! SAVE variables for bare ground case + obu_g = forc_hgt_u / zol_g + + +!======================================================================= +! [5] Canopy temperature, fluxes from roof/wall/ground +!======================================================================= + + IF ( doveg ) THEN + + ! soil water stress factor on stomatal resistance + CALL eroot (nl_soil,trsmx0,porsl,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r, alpha_vgm, n_vgm, L_vgm, sc_vgm, fc_vgm, & +#endif + psi0,rootfr,dz_gpersno,t_gpersno,wliq_gpersno,rootr,etrc,rstfac) + + nurb = 3 + + CALL UrbanVegFlux ( & + + ! model running information + ipatch ,deltim ,lbr ,lbi ,& + ! forcing + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,& + forc_q ,forc_psrf ,forc_rhoair ,forc_frl ,& + forc_po2m ,forc_pco2m ,par ,sabv ,& + rstfac ,Fhac ,Fwst ,Fach ,& + vehc ,meta ,& + ! urban and vegetation parameters + hroof ,hlr ,nurb ,fcover ,& + ewall ,egimp ,egper ,ev ,& + htop ,hbot ,lai ,sai ,& + sqrtdi ,effcon ,vmax25 ,c3c4 ,slti,& + hlti ,shti ,hhti ,trda ,& + trdm ,trop ,g1 ,g0 ,& + gradm ,binter ,extkn ,extkd ,& + dewmx ,etrc ,trsmx0 ,lambda ,& + ! surface status + z0h_g ,obu_g ,ustar_g ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno(1),wliq_gimpsno(1),wice_roofsno(1),wice_gimpsno(1),& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,sigf ,tleaf ,& + ldew ,ldew_rain ,ldew_snow ,fwet_snow ,& + dheatl ,rss ,etr_deficit ,& + ! longwave related + Ainv ,B ,B1 ,dBdT ,& + SkyVF ,VegVF ,& + ! output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwsuns ,& + cwshas ,cgrnds ,croofl ,cgimpl ,& + cgperl ,croof ,cgimp ,cgper ,& + fsenl ,fevpl ,etr ,rst ,& + assim ,respc ,lwsun ,lwsha ,& + lgimp ,lgper ,lveg ,lout ,& + tref ,qref ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,tafu ) + ELSE + + nurb = 2 + + ! CALL urban flux + CALL UrbanOnlyFlux ( & + ! model running information + ipatch ,deltim ,lbr ,lbi ,& + ! forcing + forc_hgt_u ,forc_hgt_t ,forc_hgt_q ,forc_us ,& + forc_vs ,thm ,th ,thv ,& + forc_q ,forc_psrf ,forc_rhoair ,Fhac ,& + Fwst ,Fach ,vehc ,meta ,& + ! surface parameters + hroof ,hlr ,nurb ,fcover ,& + ! surface status + z0h_g ,obu_g ,ustar_g ,zlnd ,& + zsno ,fsno_roof ,fsno_gimp ,fsno_gper ,& + wliq_roofsno(1),wliq_gimpsno(1),wice_roofsno(1),wice_gimpsno(1),& + htvp_roof ,htvp_gimp ,htvp_gper ,troof ,& + twsun ,twsha ,tgimp ,tgper ,& + qroof ,qgimp ,qgper ,dqroofdT ,& + dqgimpdT ,dqgperdT ,rss ,& + ! output + taux ,tauy ,fsenroof ,fsenwsun ,& + fsenwsha ,fsengimp ,fsengper ,fevproof ,& + fevpgimp ,fevpgper ,croofs ,cwsuns ,& + cwshas ,cgrnds ,croofl ,cgimpl ,& + cgperl ,croof ,cgimp ,cgper ,& + tref ,qref ,z0m ,zol ,& + rib ,ustar ,qstar ,tstar ,& + fm ,fh ,fq ,tafu ) + + !TODO: check + tleaf = forc_t + ldew = 0. + ldew_rain = 0. + ldew_snow = 0. + fwet_snow = 0. + rstfac = 0. + fsenl = 0.0 + fevpl = 0.0 + etr = 0.0 + assim = 0.0 + respc = 0.0 + + ENDIF + +!======================================================================= +! [6] roof/wall/ground temperature +!======================================================================= + + ! Calculate the change rate of long-wave radiation + ! caused by temperature change + clroof = - 4.*eroof*stefnc*troof**3 + clwsun = ( ewall*Ainv(1,1) - 1. ) / (1-ewall) * dBdT(1) + clwsha = ( ewall*Ainv(2,2) - 1. ) / (1-ewall) * dBdT(2) + clgimp = ( egimp*Ainv(3,3) - 1. ) / (1-egimp) * dBdT(3) + clgper = ( egper*Ainv(4,4) - 1. ) / (1-egper) * dBdT(4) + + IF (fcover(1) >0. ) clwsun = clwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) + IF (fcover(2) >0. ) clwsha = clwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) + IF (fcover(3) >0. ) clgimp = clgimp / fcover(3) * fg !/ fgimp + IF (fcover(4) >0. ) clgper = clgper / fcover(4) * fg !/ fsoil + + ! Calculate the temperature of each component: roof, wall, floor + CALL UrbanRoofTem (lbr,deltim,capr,cnfac,& + cv_roof,tk_roof,dz_roofsno,z_roofsno,zi_roofsno,& + t_roofsno,wice_roofsno,wliq_roofsno,scv_roof,snowdp_roof,& + troof_inner,lroof,clroof,sabroof,fsenroof,fevproof,croof,htvp_roof,& + imelt_roof,sm_roof,xmf,factr,tkdz_roof) + + CALL UrbanWallTem (deltim,capr,cnfac,& + cv_wall,tk_wall,t_wallsun,dz_wall,z_wall,zi_wall,& + twsun_inner,lwsun,clwsun,sabwsun,fsenwsun,cwsuns,tkdz_wsun) + + CALL UrbanWallTem (deltim,capr,cnfac,& + cv_wall,tk_wall,t_wallsha,dz_wall,z_wall,zi_wall,& + twsha_inner,lwsha,clwsha,sabwsha,fsenwsha,cwshas,tkdz_wsha) + + CALL UrbanImperviousTem (patchtype,lbi,deltim,& + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& + cv_gimp,tk_gimp,dz_gimpsno,z_gimpsno,zi_gimpsno,& + t_gimpsno,wice_gimpsno,wliq_gimpsno,scv_gimp,snowdp_gimp,& + lgimp,clgimp,sabgimp,fsengimp,fevpgimp,cgimp,htvp_gimp,& + imelt_gimp,sm_gimp,xmf,facti) + + CALL UrbanPerviousTem (patchtype,lbp,deltim,& + capr,cnfac,csol,k_solids,porsl,psi0,dkdry,dksatu,dksatf,& + vf_quartz,vf_gravels,vf_om,vf_sand,wf_gravels,wf_sand,& + BA_alpha, BA_beta,& +#ifdef Campbell_SOIL_MODEL + bsw,& +#endif +#ifdef vanGenuchten_Mualem_SOIL_MODEL + theta_r,alpha_vgm,n_vgm,L_vgm,& + sc_vgm,fc_vgm,& +#endif + dz_gpersno,z_gpersno,zi_gpersno,& + t_gpersno,wice_gpersno,wliq_gpersno,scv_gper,snowdp_gper,& + lgper,clgper,sabgper,fsengper,fevpgper,cgper,htvp_gper,& + imelt_gper,sm_gper,xmf,factp) + + ! update temperature + twsun = t_wallsun( 1 ) + twsha = t_wallsha( 1 ) + troof = t_roofsno(lbr) + tgimp = t_gimpsno(lbi) + tgper = t_gpersno(lbp) + twall = (twsun*fwsun + twsha*fwsha)/(fwsun + fwsha) + + ! calculate lake temperature and sensible/latent heat fluxes + CALL laketem ( & + ! "in" laketem arguments + ! --------------------------- + patchtype ,maxsnl ,nl_soil ,nl_lake ,& + patchlatr ,deltim ,forc_hgt_u ,forc_hgt_t ,& + forc_hgt_q ,forc_us ,forc_vs ,forc_t ,& + forc_q ,forc_rhoair ,forc_psrf ,forc_sols ,& + forc_soll ,forc_solsd ,forc_solld ,sablake ,& + forc_frl ,dz_lakesno ,z_lakesno ,zi_lakesno ,& + dz_lake ,lakedepth ,vf_quartz ,vf_gravels ,& + vf_om ,vf_sand ,wf_gravels ,wf_sand ,& + porsl ,csol ,k_solids ,& + dksatu ,dksatf ,dkdry ,& + BA_alpha ,BA_beta ,hpbl ,& + + ! "inout" laketem arguments + ! --------------------------- + tlake ,scv_lake ,snowdp_lake ,t_lakesno ,& + wliq_lakesno ,wice_lakesno ,imelt_lake ,t_lake ,& + lake_icefrac ,savedtke1 ,& + +! SNICAR model variables + snofrz ,sabg_lyr ,& +! END SNICAR model variables + + ! "out" laketem arguments + ! --------------------------- + taux_lake ,tauy_lake ,fsena_lake ,& + fevpa_lake ,lfevpa_lake ,fseng_lake ,fevpg_lake ,& + qseva_lake ,qsubl_lake ,qsdew_lake ,qfros_lake ,& + olrg_lake ,fgrnd_lake ,tref_lake ,qref_lake ,& + trad_lake ,emis_lake ,z0m_lake ,zol_lake ,& + rib_lake ,ustar_lake ,qstar_lake ,tstar_lake ,& + fm_lake ,fh_lake ,fq_lake ,sm_lake ,& + urban_call=.true. ) + + lnet_lake = forc_frl - olrg_lake + +!======================================================================= +! [7] Correct fluxes for temperature change +!======================================================================= + + ! calculate temperature change + dT(0) = troof - troof_bef + dT(1) = twsun - twsun_bef + dT(2) = twsha - twsha_bef + dT(3) = tgimp - tgimp_bef + dT(4) = tgper - tgper_bef + IF ( doveg ) dT(5) = 0. + + ! flux change due to temperature change + fsenroof = fsenroof + dT(0)*croofs + fsenwsun = fsenwsun + dT(1)*cwsuns + fsenwsha = fsenwsha + dT(2)*cwshas + fsengimp = fsengimp + dT(3)*cgrnds + fsengper = fsengper + dT(4)*cgrnds + + fevproof = fevproof + dT(0)*croofl + fevpgimp = fevpgimp + dT(3)*cgimpl + fevpgper = fevpgper + dT(4)*cgperl + +! calculation of evaporative potential; flux in kg m-2 s-1. +! egidif holds the excess energy IF all water is evaporated +! during the timestep. this energy is later added to the sensible heat flux. + + ! --- for pervious ground --- + egsmax = (wice_gpersno(lbp)+wliq_gpersno(lbp)) / deltim + egidif = max( 0., fevpgper - egsmax ) + fevpgper = min ( fevpgper, egsmax ) + fsengper = fsengper + htvp_gper*egidif + + ! --- for impervious ground --- + egsmax = (wice_gimpsno(lbi)+wliq_gimpsno(lbi)) / deltim + egidif = max( 0., fevpgimp - egsmax ) + fevpgimp = min ( fevpgimp, egsmax ) + fsengimp = fsengimp + htvp_gimp*egidif + + ! --- for roof --- + egsmax = (wice_roofsno(lbr)+wliq_roofsno(lbr)) / deltim + egidif = max( 0., fevproof - egsmax ) + fevproof = min ( fevproof, egsmax ) + fsenroof = fsenroof + htvp_roof*egidif + +!======================================================================= +! [8] total fluxes to atmosphere +!======================================================================= + + lnet = lroof *fcover(0) + lwsun *fcover(1) + lwsha *fcover(2) + & + lgimp *fcover(3) + lgper *fcover(4) + + ! 03/30/2022, Wenzong Dong: bug find, sabgwsha->sabgwsun + sabg = sabroof *fcover(0) + sabwsun *fcover(1) + sabwsha *fcover(2) + & + sabgimp *fcover(3) + sabgper *fcover(4) + + ! 03/30/2022, Wenzong Dong: bug find, fsenwsha->fsenwsun + fseng = fsenroof*fcover(0) + fsenwsun*fcover(1) + fsenwsha*fcover(2) + & + fsengimp*fcover(3) + fsengper*fcover(4) + + fsen_roof = fsenroof*fcover(0) + fsen_wsun = fsenwsun*fcover(1) + fsen_wsha = fsenwsha*fcover(2) + fsen_gimp = fsengimp*fcover(3) + fsen_gper = fsengper*fcover(4) + + fevpg = fevproof*fcover(0) + fevpgimp*fcover(3) + fevpgper*fcover(4) + + lfevpa = htvp_roof*fevproof*fcover(0) + & + htvp_gimp*fevpgimp*fcover(3) + & + htvp_gper*fevpgper*fcover(4) + + lfevp_roof = htvp_roof*fevproof*fcover(0) + lfevp_gimp = htvp_gimp*fevpgimp*fcover(3) + lfevp_gper = htvp_gper*fevpgper*fcover(4) + + IF ( doveg ) THEN + assim = assim * fveg + respc = respc * fveg + fsenl = fsenl * fveg + fevpl = fevpl * fveg + etr = etr * fveg + fsena = fsenl + fseng + fevpa = fevpl + fevpg + lfevpa = lfevpa + hvap*fevpl + + fsen_urbl = fsenl + lfevp_urbl = hvap*fevpl + etr_deficit = etr_deficit*fveg + ELSE + fsena = fseng + fevpa = fevpg + ENDIF + + fsena = fsena + (Fhac + Fwst + vehc)*fsh + Fach + meta + lfevpa = lfevpa + (Fhac + Fwst + vehc)*flh + + ! flux/variable average weighted by fractional cover + taux = taux *(1-flake) + taux_lake *flake + tauy = tauy *(1-flake) + tauy_lake *flake + sabg = sabg *(1-flake) + sablake *flake + lnet = lnet *(1-flake) + lnet_lake *flake + fseng = fseng *(1-flake) + fseng_lake *flake + fsena = fsena *(1-flake) + fsena_lake *flake + fevpg = fevpg *(1-flake) + fevpg_lake *flake + lfevpa = lfevpa *(1-flake) + lfevpa_lake *flake + tref = tref *(1-flake) + tref_lake *flake + qref = qref *(1-flake) + qref_lake *flake + z0m = z0m *(1-flake) + z0m_lake *flake + zol = zol *(1-flake) + zol_lake *flake + rib = rib *(1-flake) + rib_lake *flake + ustar = ustar *(1-flake) + ustar_lake *flake + qstar = qstar *(1-flake) + qstar_lake *flake + tstar = tstar *(1-flake) + tstar_lake *flake + fm = fm *(1-flake) + fm_lake *flake + fh = fh *(1-flake) + fh_lake *flake + fq = fq *(1-flake) + fq_lake *flake + + ! 10/01/2021, yuan: exclude lake fevpa. + ! because we don't consider water balance for lake currently. + !fevpa = fevpa *(1-flake) + fevpa_lake *flake + + ! 07/11/2023, yuan: don't not consider lake fraction cover + !fsenl = fsenl *(1-flake) + !fevpl = fevpl *(1-flake) + !etr = etr *(1-flake) + !assim = assim *(1-flake) + !respc = respc *(1-flake) + + ! effective ground temperature, simple average + ! 12/01/2021, yuan: !TODO Bugs. temperature cannot be weighted like below. + !t_grnd = troof*fcover(0) + twsun*fcover(1) + twsha*fcover(2) + & + t_grnd = tgper*fgper + tgimp*(1-fgper) + + !============================================== + qseva_roof = 0. + qsubl_roof = 0. + qfros_roof = 0. + qsdew_roof = 0. + + IF (fevproof >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_roof = min(wliq_roofsno(lbr)/deltim, fevproof) + qsubl_roof = fevproof - qseva_roof + ELSE + IF (troof < tfrz)THEN + qfros_roof = abs(fevproof) + ELSE + qsdew_roof = abs(fevproof) + ENDIF + ENDIF + + !============================================== + qseva_gimp = 0. + qsubl_gimp = 0. + qfros_gimp = 0. + qsdew_gimp = 0. + + IF (fevpgimp >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_gimp = min(wliq_gimpsno(lbi)/deltim, fevpgimp) + qsubl_gimp = fevpgimp - qseva_gimp + ELSE + IF (tgimp < tfrz)THEN + qfros_gimp = abs(fevpgimp) + ELSE + qsdew_gimp = abs(fevpgimp) + ENDIF + ENDIF + + !============================================== + qseva_gper = 0. + qsubl_gper = 0. + qfros_gper = 0. + qsdew_gper = 0. + + IF (fevpgper >= 0.)THEN +! not allow for sublimation in melting (melting ==> evap. ==> sublimation) + qseva_gper = min(wliq_gpersno(lbp)/deltim, fevpgper) + qsubl_gper = fevpgper - qseva_gper + ELSE + IF (tgper < tfrz)THEN + qfros_gper = abs(fevpgper) + ELSE + qsdew_gper = abs(fevpgper) + ENDIF + ENDIF + +!======================================================================= +! [9] Calculate the change of long-wave radiation caused by temperature change +!======================================================================= + + dX = matmul(Ainv, dBdT*dT(1:)) + dlwsun = ( ewall*dX(1) - dBdT(1)*dT(1) ) / (1-ewall) + dlwsha = ( ewall*dX(2) - dBdT(2)*dT(2) ) / (1-ewall) + dlgimp = ( egimp*dX(3) - dBdT(3)*dT(3) ) / (1-egimp) + dlgper = ( egper*dX(4) - dBdT(4)*dT(4) ) / (1-egper) + + IF ( doveg ) THEN + dlveg = ( sum(dX(1:5)*VegVF(1:5))*ev ) + ELSE + dlveg = 0. + ENDIF + + dlout = sum( dX * SkyVF ) + + ! Energy balance check + eb = dlwsun + dlwsha + dlgimp + dlgper + dlveg + dlout + + IF (abs(eb) > 1e-6) THEN + print *, "Urban Vegetation Longwave - Energy Balance Check error!", eb + ENDIF + + ! for per unit surface + IF (fcover(1) > 0.) dlwsun = dlwsun / fcover(1) * fg !/ (4*fwsun*HL*fb/fg) + IF (fcover(2) > 0.) dlwsha = dlwsha / fcover(2) * fg !/ (4*fwsha*HL*fb/fg) + IF (fcover(3) > 0.) dlgimp = dlgimp / fcover(3) * fg !/ fgimp + IF (fcover(4) > 0.) dlgper = dlgper / fcover(4) * fg !/ fgper + IF ( doveg ) dlveg = dlveg / fcover(5) * fg !/ fv/fg + + dlw = dlwsun*fcover(1) + dlwsha*fcover(2) + dlgimp*fcover(3) + dlgper*fcover(4) + IF ( doveg) dlw = dlw + dlveg*fcover(5) + dlw = dlw*(1-flake) + + ! calculate out going longwave by added the before value + ! of lout and considered troof change + lout = lout + dlout + rout = (1-eroof)*forc_frl + eroof*stefnc*troof_bef**4 & + + 4.*eroof*stefnc*troof_bef**3*dT(0) + + olrg = lout*fg + rout*froof + olrg = olrg*(1-flake) + olrg_lake*flake + + IF (olrg < 0) THEN + write(6,*) 'Urban_THERMAL.F90: Urban out-going longwave radiation < 0!' + write(6,*) ipatch,olrg,lout,dlout,rout,olrg_lake,fg,froof,flake + CALL CoLM_stop() + ENDIF + + ! radiative temperature + trad = (olrg/stefnc)**0.25 + +! averaged bulk surface emissivity +!TODO: how to calculate for urban case? +! 03/10/2020, yuan: removed below. + !olrb = stefnc*t_soisno_bef(lb)**3*(4.*tinc) + !olrb = stefnc*t_grnd_bef**3*(4.*tinc) + !olru = ulrad + emg*olrb + !olrb = ulrad + olrb + !emis = olru / olrb + + +!======================================================================= +! [10] ground heat flux and energy balance error +!======================================================================= + + ! ground heat flux + fgrnd = sabg + lnet - dlwbef - dlout*fg*(1-flake) & + - 4.*eroof*stefnc*troof_bef**3*dT(0)*froof*(1-flake)& + - fseng - (lfevp_roof + lfevp_gimp + lfevp_gper)*(1-flake) & + - lfevpa_lake*flake + + ! energy balance check + errore = sabg + sabv*fveg*(1-flake) & + + forc_frl - olrg & + + (Fhac + Fwst + Fach + vehc + meta)*(1-flake) & + - fsena - lfevpa - fgrnd & + - dheatl*fveg*(1-flake) + + fgrnd = fgrnd - (Fhac + Fwst + Fach + vehc + meta)*(1-flake) + +#if (defined CoLMDEBUG) + IF (abs(errore)>.5) THEN + write(6,*) 'Urban_THERMAL.F90: Urban energy balance violation' + write(6,*) ipatch,errore,sabg,sabv*fveg*(1-flake) + write(6,*) forc_frl,dlwbef,dlw,olrg + write(6,*) Fhac,Fwst,Fach,vehc,meta,(1-flake) + write(6,*) fsena,lfevpa,fgrnd + write(6,*) dheatl*fveg*(1-flake) + CALL CoLM_stop() + ENDIF +100 format(10(f15.3)) +#endif + + ! diagnostic sabg only for pervious and impervious ground + !sabg = sabgper*fgper + sabgimp*(1-fgper) + + ! SAVE for next time run + lwsun = dlwsun + lwsha = dlwsha + lgimp = dlgimp + lgper = dlgper + lveg = dlveg + + ! deallocate memory + deallocate ( Ainv ) + deallocate ( X ) + deallocate ( dX ) + deallocate ( B ) + deallocate ( B1 ) + deallocate ( dBdT ) + deallocate ( SkyVF ) + deallocate ( dT ) + + IF ( doveg ) THEN + deallocate ( VegVF ) + ENDIF + + +!======================================================================= +! [11] Anthropogenic heat +!======================================================================= + + ! A simple Building energy model + CALL SimpleBEM ( deltim, forc_rhoair, fcover(0:2), hroof, troommax, troommin, & + troof_nl_bef, twsun_nl_bef, twsha_nl_bef, & + t_roofsno(nl_roof), t_wallsun(nl_wall), t_wallsha(nl_wall), & + tkdz_roof, tkdz_wsun, tkdz_wsha, tafu, troom, & + troof_inner, twsun_inner, twsha_inner, & + Fhac, Fwst, Fach, Fhah ) + + ! Anthropogenic heat flux for the rest (vehicle heat flux and metabolic heat flux) + CALL LUCY ( idate , deltim , patchlonr, fix_holiday, & + week_holiday, hum_prof, wdh_prof , weh_prof ,pop_den, & + vehicle , Fahe , vehc , meta ) + + fgrnd = fgrnd + (Fhac + Fwst + Fach)*(1-flake) + vehc + meta + + + ! convert BEM AHE to grid area values + ! NOTE: BEM AHE are assumed only affecting the urban area, + ! but vehc and meta area for the whole grid. + Fhac = Fhac * (1-flake) + Fwst = Fwst * (1-flake) + Fach = Fach * (1-flake) + Fhah = Fhah * (1-flake) + + + deallocate ( fcover ) + + END SUBROUTINE UrbanTHERMAL + +END MODULE MOD_Urban_Thermal +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 new file mode 100644 index 0000000000..530c064fe4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_1DFluxes.F90 @@ -0,0 +1,155 @@ +#include + +#if (defined URBAN_MODEL) +MODULE MOD_Urban_Vars_1DFluxes + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Define urban model 1D flux variables. +! +! Created by Hua Yuan, 12/2020 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + +!----------------------------------------------------------------------- +! Fluxes +!----------------------------------------------------------------------- + !real(r8), allocatable :: sabroof (:) !solar absorption of roof [W/m2] + !real(r8), allocatable :: sabwsun (:) !solar absorption of sunlit wall [W/m2] + !real(r8), allocatable :: sabwsha (:) !solar absorption of shaded wall [W/m2] + !real(r8), allocatable :: sabgimp (:) !solar absorption of impervious [W/m2] + !real(r8), allocatable :: sabgper (:) !solar absorption of pervious [W/m2] + + real(r8), allocatable :: fsen_roof (:) !sensible heat flux from roof [W/m2] + real(r8), allocatable :: fsen_wsun (:) !sensible heat flux from sunlit wall [W/m2] + real(r8), allocatable :: fsen_wsha (:) !sensible heat flux from shaded wall [W/m2] + real(r8), allocatable :: fsen_gimp (:) !sensible heat flux from impervious road [W/m2] + real(r8), allocatable :: fsen_gper (:) !sensible heat flux from pervious road [W/m2] + real(r8), allocatable :: fsen_urbl (:) !sensible heat flux from urban vegetation [W/m2] + + real(r8), allocatable :: lfevp_roof (:) !latent heat flux from roof [W/m2] + real(r8), allocatable :: lfevp_gimp (:) !latent heat flux from impervious road [W/m2] + real(r8), allocatable :: lfevp_gper (:) !latent heat flux from pervious road [W/m2] + real(r8), allocatable :: lfevp_urbl (:) !latent heat flux from urban vegetation [W/m2] + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_1D_UrbanFluxes + PUBLIC :: deallocate_1D_UrbanFluxes + PUBLIC :: set_1D_UrbanFluxes + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_1D_UrbanFluxes + ! -------------------------------------------------------------------- + ! Allocates memory for CLM 1d [numurban] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandUrban + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + IF (.true.) THEN + IF (numurban > 0) THEN + !allocate (sabroof (numurban)) + !allocate (sabwsun (numurban)) + !allocate (sabwsha (numurban)) + !allocate (sabgimp (numurban)) + !allocate (sabgper (numurban)) + allocate (fsen_roof (numurban)) ; fsen_roof (:) = spval + allocate (fsen_wsun (numurban)) ; fsen_wsun (:) = spval + allocate (fsen_wsha (numurban)) ; fsen_wsha (:) = spval + allocate (fsen_gimp (numurban)) ; fsen_gimp (:) = spval + allocate (fsen_gper (numurban)) ; fsen_gper (:) = spval + allocate (fsen_urbl (numurban)) ; fsen_urbl (:) = spval + + allocate (lfevp_roof (numurban)) ; lfevp_roof (:) = spval + allocate (lfevp_gimp (numurban)) ; lfevp_gimp (:) = spval + allocate (lfevp_gper (numurban)) ; lfevp_gper (:) = spval + allocate (lfevp_urbl (numurban)) ; lfevp_urbl (:) = spval + ENDIF + ENDIF + + END SUBROUTINE allocate_1D_UrbanFluxes + + SUBROUTINE deallocate_1D_UrbanFluxes + ! -------------------------------------------------------------------- + ! deallocates memory for CLM 1d [numurban] variables + ! -------------------------------------------------------------------- + USE MOD_MPAS_MPI + USE MOD_LandUrban + + IF (.true.) THEN + IF (numurban > 0) THEN + + !deallocate (sabroof ) + !deallocate (sabwsun ) + !deallocate (sabwsha ) + !deallocate (sabgimp ) + !deallocate (sabgper ) + deallocate (fsen_roof ) + deallocate (fsen_wsun ) + deallocate (fsen_wsha ) + deallocate (fsen_gimp ) + deallocate (fsen_gper ) + deallocate (fsen_urbl ) + + deallocate (lfevp_roof ) + deallocate (lfevp_gimp ) + deallocate (lfevp_gper ) + deallocate (lfevp_urbl ) + + ENDIF + ENDIF + + END SUBROUTINE deallocate_1D_UrbanFluxes + + SUBROUTINE set_1D_UrbanFluxes(Values, Nan) + ! -------------------------------------------------------------------- + ! Allocates memory for CLM 1d [numurban] variables + ! -------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandUrban + IMPLICIT NONE + real(r8),intent(in) :: Values + real(r8),intent(in) :: Nan + + IF (.true.) THEN + IF (numurban > 0) THEN + !sabroof (:) = Values + !sabwsun (:) = Values + !sabwsha (:) = Values + !sabgimp (:) = Values + !sabgper (:) = Values + fsen_roof (:) = Values + fsen_wsun (:) = Values + fsen_wsha (:) = Values + fsen_gimp (:) = Values + fsen_gper (:) = Values + fsen_urbl (:) = Values + + lfevp_roof (:) = Values + lfevp_gimp (:) = Values + lfevp_gper (:) = Values + lfevp_urbl (:) = Values + ENDIF + ENDIF + + END SUBROUTINE set_1D_UrbanFluxes + +END MODULE MOD_Urban_Vars_1DFluxes +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 new file mode 100644 index 0000000000..5a12ab339c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeInvariants.F90 @@ -0,0 +1,340 @@ +#include + +#ifdef URBAN_MODEL +MODULE MOD_Urban_Vars_TimeInvariants + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Define urban model time invariant variables. +! +! Created by Hua Yuan, 12/2020 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE + + !integer , allocatable :: urbclass (:) !urban type + !integer , allocatable :: patch2urb (:) !projection from patch to Urban + !integer , allocatable :: urb2patch (:) !projection from Urban to patch + + real(r8), allocatable :: pop_den (:) !pop density + real(r8), allocatable :: vehicle (:,:) !vehicle numbers per thousand people + real(r8), allocatable :: week_holiday(:,:) !week holidays + real(r8), allocatable :: weh_prof (:,:) !Diurnal traffic flow profile of weekend + real(r8), allocatable :: wdh_prof (:,:) !Diurnal traffic flow profile of weekday + real(r8), allocatable :: hum_prof (:,:) !Diurnal metabolic heat profile + real(r8), allocatable :: fix_holiday (:,:) !Fixed public holidays, holiday (0) or workday(1) + + ! Vegetations + real(r8), allocatable :: fveg_urb (:) !tree coverage of urban patch [-] + real(r8), allocatable :: htop_urb (:) !tree crown top height of urban patch [m] + real(r8), allocatable :: hbot_urb (:) !tree crown bottom height of urban patch [m] + + ! Urban morphology + real(r8), allocatable :: froof (:) !roof fractional cover [-] + real(r8), allocatable :: fgper (:) !impervious fraction to ground area [-] + real(r8), allocatable :: flake (:) !lake fraction to ground area [-] + real(r8), allocatable :: hroof (:) !average building height [m] + real(r8), allocatable :: hlr (:) !average building height to their side length [-] + + real(r8), allocatable :: z_roof (:,:) !depth of each roof layer [m] + real(r8), allocatable :: z_wall (:,:) !depth of each wall layer [m] + real(r8), allocatable :: dz_roof (:,:) !thickness of each roof layer [m] + real(r8), allocatable :: dz_wall (:,:) !thickness of each wall layer [m] + + ! albedo + real(r8), allocatable :: alb_roof (:,:,:) !albedo of roof [-] + real(r8), allocatable :: alb_wall (:,:,:) !albedo of walls [-] + real(r8), allocatable :: alb_gimp (:,:,:) !albedo of impervious [-] + real(r8), allocatable :: alb_gper (:,:,:) !albedo of pervious [-] + + ! emissivity + real(r8), allocatable :: em_roof (:) !emissivity of roof [-] + real(r8), allocatable :: em_wall (:) !emissivity of walls [-] + real(r8), allocatable :: em_gimp (:) !emissivity of impervious [-] + real(r8), allocatable :: em_gper (:) !emissivity of pervious [-] + + ! thermal pars of roof, wall, impervious + real(r8), allocatable :: cv_roof (:,:) !heat capacity of roof [J/(m2 K)] + real(r8), allocatable :: cv_wall (:,:) !heat capacity of wall [J/(m2 K)] + real(r8), allocatable :: cv_gimp (:,:) !heat capacity of impervious [J/(m2 K)] + + real(r8), allocatable :: tk_roof (:,:) !thermal conductivity of roof [W/m-K] + real(r8), allocatable :: tk_wall (:,:) !thermal conductivity of wall [W/m-K] + real(r8), allocatable :: tk_gimp (:,:) !thermal conductivity of impervious [W/m-K] + + ! room maximum and minimum temperature + real(r8), allocatable :: t_roommax (:) !maximum temperature of inner room [K] + real(r8), allocatable :: t_roommin (:) !minimum temperature of inner room [K] + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_UrbanTimeInvariants + PUBLIC :: deallocate_UrbanTimeInvariants + PUBLIC :: READ_UrbanTimeInvariants + PUBLIC :: WRITE_UrbanTimeInvariants + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_UrbanTimeInvariants () +! ------------------------------------------------------ +! Allocates memory for CLM 1d [numurban] variants +! ------------------------------------------------------ + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandUrban + USE MOD_Vars_Global + IMPLICIT NONE + + IF (.true.) THEN + IF (numurban > 0) THEN + allocate (fveg_urb (numurban)) + allocate (htop_urb (numurban)) + allocate (hbot_urb (numurban)) + allocate (froof (numurban)) + allocate (fgper (numurban)) + allocate (flake (numurban)) + allocate (hroof (numurban)) + allocate (hlr (numurban)) + + allocate (alb_roof (2,2,numurban)) + allocate (alb_wall (2,2,numurban)) + allocate (alb_gimp (2,2,numurban)) + allocate (alb_gper (2,2,numurban)) + + allocate (em_roof (numurban)) + allocate (em_wall (numurban)) + allocate (em_gimp (numurban)) + allocate (em_gper (numurban)) + + allocate (z_roof (1:nl_roof,numurban)) + allocate (z_wall (1:nl_wall,numurban)) + allocate (dz_roof (1:nl_roof,numurban)) + allocate (dz_wall (1:nl_wall,numurban)) + + allocate (cv_roof (1:nl_roof,numurban)) + allocate (cv_wall (1:nl_wall,numurban)) + allocate (cv_gimp (1:nl_soil,numurban)) + allocate (tk_roof (1:nl_roof,numurban)) + allocate (tk_wall (1:nl_wall,numurban)) + allocate (tk_gimp (1:nl_soil,numurban)) + + allocate (t_roommax (numurban)) + allocate (t_roommin (numurban)) + allocate (pop_den (numurban)) + + allocate (vehicle (3 ,numurban)) + allocate (week_holiday (7 ,numurban)) + allocate (weh_prof (24 ,numurban)) + allocate (wdh_prof (24 ,numurban)) + allocate (hum_prof (24 ,numurban)) + allocate (fix_holiday (365,numurban)) + ENDIF + ENDIF + + END SUBROUTINE allocate_UrbanTimeInvariants + + SUBROUTINE READ_UrbanTimeInvariants (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandUrban + + IMPLICIT NONE + + integer, parameter :: ns = 2 + integer, parameter :: nr = 2 + integer, parameter :: ulev = 10 + character(len=*), intent(in) :: file_restart + + ! vegetation + CALL ncio_read_vector (file_restart, 'PCT_Tree' , landurban, fveg_urb ) + CALL ncio_read_vector (file_restart, 'URBAN_TREE_TOP', landurban, htop_urb ) + CALL ncio_read_vector (file_restart, 'URBAN_TREE_BOT', landurban, hbot_urb ) + CALL ncio_read_vector (file_restart, 'PCT_Water' , landurban, flake ) + + ! LUCY paras !TODO: variable name can be optimized + CALL ncio_read_vector (file_restart, 'POP_DEN' , landurban, pop_den ) + CALL ncio_read_vector (file_restart, 'VEHC_NUM' , 3 , landurban, vehicle ) + CALL ncio_read_vector (file_restart, 'week_holiday', 7 , landurban, week_holiday ) + CALL ncio_read_vector (file_restart, 'weekendhour' , 24 , landurban, weh_prof ) + CALL ncio_read_vector (file_restart, 'weekdayhour' , 24 , landurban, wdh_prof ) + CALL ncio_read_vector (file_restart, 'metabolism' , 24 , landurban, hum_prof ) + CALL ncio_read_vector (file_restart, 'holiday' , 365, landurban, fix_holiday ) + + ! morphological paras + CALL ncio_read_vector (file_restart, 'WT_ROOF' , landurban, froof ) + CALL ncio_read_vector (file_restart, 'HT_ROOF' , landurban, hroof ) + CALL ncio_read_vector (file_restart, 'BUILDING_HLR' , landurban, hlr ) + CALL ncio_read_vector (file_restart, 'WTROAD_PERV' , landurban, fgper ) + CALL ncio_read_vector (file_restart, 'EM_ROOF' , landurban, em_roof ) + CALL ncio_read_vector (file_restart, 'EM_WALL' , landurban, em_wall ) + CALL ncio_read_vector (file_restart, 'EM_IMPROAD' , landurban, em_gimp ) + CALL ncio_read_vector (file_restart, 'EM_PERROAD' , landurban, em_gper ) + CALL ncio_read_vector (file_restart, 'T_BUILDING_MIN', landurban, t_roommin ) + CALL ncio_read_vector (file_restart, 'T_BUILDING_MAX', landurban, t_roommax ) + + CALL ncio_read_vector (file_restart, 'ROOF_DEPTH_L' , ulev, landurban, z_roof ) + CALL ncio_read_vector (file_restart, 'ROOF_THICK_L' , ulev, landurban, dz_roof ) + CALL ncio_read_vector (file_restart, 'WALL_DEPTH_L' , ulev, landurban, z_wall ) + CALL ncio_read_vector (file_restart, 'WALL_THICK_L' , ulev, landurban, dz_wall ) + + ! thermal paras + CALL ncio_read_vector (file_restart, 'CV_ROOF' , ulev, landurban, cv_roof ) + CALL ncio_read_vector (file_restart, 'CV_WALL' , ulev, landurban, cv_wall ) + CALL ncio_read_vector (file_restart, 'TK_ROOF' , ulev, landurban, tk_roof ) + CALL ncio_read_vector (file_restart, 'TK_WALL' , ulev, landurban, tk_wall ) + CALL ncio_read_vector (file_restart, 'TK_IMPROAD', ulev, landurban, tk_gimp ) + CALL ncio_read_vector (file_restart, 'CV_IMPROAD', ulev, landurban, cv_gimp ) + + CALL ncio_read_vector (file_restart, 'ALB_ROOF' , ns, nr, landurban, alb_roof ) + CALL ncio_read_vector (file_restart, 'ALB_WALL' , ns, nr, landurban, alb_wall ) + CALL ncio_read_vector (file_restart, 'ALB_IMPROAD', ns, nr, landurban, alb_gimp ) + CALL ncio_read_vector (file_restart, 'ALB_PERROAD', ns, nr, landurban, alb_gper ) + + END SUBROUTINE READ_UrbanTimeInvariants + + SUBROUTINE WRITE_UrbanTimeInvariants (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandUrban + USE MOD_Namelist + USE MOD_Vars_Global + + IMPLICIT NONE + + integer, parameter :: ns = 2 + integer, parameter :: nr = 2 + integer, parameter :: ulev = 10 + integer, parameter :: ityp = 3 + integer, parameter :: ihour = 24 + integer, parameter :: iweek = 7 + integer, parameter :: iday = 365 + ! Local variables + character(len=*), intent(in) :: file_restart + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landurban) + CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') + + CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') + CALL ncio_define_dimension_vector (file_restart, landurban, 'numsolar', nr ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'numrad' , ns ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'ulev' , ulev) + CALL ncio_define_dimension_vector (file_restart, landurban, 'ityp' , 3 ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'iweek' , 7 ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'ihour' , 24 ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'iday' , 365 ) + + ! vegetation + CALL ncio_write_vector (file_restart, 'PCT_Tree' , 'urban', landurban, fveg_urb, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'URBAN_TREE_TOP', 'urban', landurban, htop_urb, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'URBAN_TREE_BOT', 'urban', landurban, hbot_urb, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'PCT_Water' , 'urban', landurban, flake , DEF_REST_CompressLevel) + + ! LUCY paras + CALL ncio_write_vector (file_restart, 'POP_DEN' , 'urban', landurban, pop_den , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'VEHC_NUM' , 'ityp' , ityp , 'urban', landurban, vehicle , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'week_holiday', 'iweek', iweek, 'urban', landurban, week_holiday, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'weekendhour' , 'ihour', ihour, 'urban', landurban, weh_prof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'weekdayhour' , 'ihour', ihour, 'urban', landurban, wdh_prof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'metabolism' , 'ihour', ihour, 'urban', landurban, hum_prof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'holiday' , 'iday' , iday , 'urban', landurban, fix_holiday , DEF_REST_CompressLevel) + + ! morphological paras + CALL ncio_write_vector (file_restart, 'WT_ROOF' , 'urban', landurban, froof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'HT_ROOF' , 'urban', landurban, hroof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'BUILDING_HLR' , 'urban', landurban, hlr , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'WTROAD_PERV' , 'urban', landurban, fgper , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'EM_ROOF' , 'urban', landurban, em_roof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'EM_WALL' , 'urban', landurban, em_wall , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'EM_IMPROAD' , 'urban', landurban, em_gimp , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'EM_PERROAD' , 'urban', landurban, em_gper , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'T_BUILDING_MIN', 'urban', landurban, t_roommin, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'T_BUILDING_MAX', 'urban', landurban, t_roommax, DEF_REST_CompressLevel) + + CALL ncio_write_vector (file_restart, 'ROOF_DEPTH_L', 'ulev', ulev, 'urban', landurban, z_roof , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'ROOF_THICK_L', 'ulev', ulev, 'urban', landurban, dz_roof, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'WALL_DEPTH_L', 'ulev', ulev, 'urban', landurban, z_wall , DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'WALL_THICK_L', 'ulev', ulev, 'urban', landurban, dz_wall, DEF_REST_CompressLevel) + + ! thermal paras + CALL ncio_write_vector (file_restart, 'CV_ROOF' , 'ulev', ulev, 'urban', landurban, cv_roof, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'CV_WALL' , 'ulev', ulev, 'urban', landurban, cv_wall, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'TK_ROOF' , 'ulev', ulev, 'urban', landurban, tk_roof, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'TK_WALL' , 'ulev', ulev, 'urban', landurban, tk_wall, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'TK_IMPROAD', 'ulev', ulev, 'urban', landurban, tk_gimp, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'CV_IMPROAD', 'ulev', ulev, 'urban', landurban, cv_gimp, DEF_REST_CompressLevel) + + CALL ncio_write_vector (file_restart, 'ALB_ROOF' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_roof, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'ALB_WALL' , 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_wall, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'ALB_IMPROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gimp, DEF_REST_CompressLevel) + CALL ncio_write_vector (file_restart, 'ALB_PERROAD', 'numsolar', ns, 'numrad', nr, 'urban', landurban, alb_gper, DEF_REST_CompressLevel) + + END SUBROUTINE WRITE_UrbanTimeInvariants + + SUBROUTINE deallocate_UrbanTimeInvariants + + USE MOD_MPAS_MPI + USE MOD_LandUrban + + ! deallocate (urbclass ) + + IF (.true.) THEN + IF (numurban > 0) THEN + deallocate (fveg_urb ) + deallocate (htop_urb ) + deallocate (hbot_urb ) + deallocate (froof ) + deallocate (fgper ) + deallocate (flake ) + deallocate (hroof ) + deallocate (hlr ) + + deallocate (alb_roof ) + deallocate (alb_wall ) + deallocate (alb_gimp ) + deallocate (alb_gper ) + + deallocate (em_roof ) + deallocate (em_wall ) + deallocate (em_gimp ) + deallocate (em_gper ) + + deallocate (z_roof ) + deallocate (z_wall ) + deallocate (dz_roof ) + deallocate (dz_wall ) + + deallocate (cv_roof ) + deallocate (cv_wall ) + deallocate (cv_gimp ) + deallocate (tk_roof ) + deallocate (tk_wall ) + deallocate (tk_gimp ) + + deallocate (t_roommax ) + deallocate (t_roommin ) + + deallocate (pop_den ) + deallocate (vehicle ) + deallocate (week_holiday ) + deallocate (weh_prof ) + deallocate (wdh_prof ) + deallocate (hum_prof ) + deallocate (fix_holiday ) + ENDIF + ENDIF + END SUBROUTINE deallocate_UrbanTimeInvariants + +END MODULE MOD_Urban_Vars_TimeInvariants +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 new file mode 100644 index 0000000000..29a433f9e2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_Vars_TimeVariables.F90 @@ -0,0 +1,506 @@ +#include + +#if (defined URBAN_MODEL) +MODULE MOD_Urban_Vars_TimeVariables + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Define urban model time variant variables. +! +! Created by Hua Yuan, 12/2020 +!----------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + SAVE +! ----------------------------------------------------------------- +! Time-varying state variables which required by restart run + + real(r8), allocatable :: fwsun (:) !sunlit fraction of walls [-] + real(r8), allocatable :: dfwsun (:) !change of sunlit fraction of walls [-] + + ! shortwave absorption + real(r8), allocatable :: sroof (:,:,:) !roof absorption [-] + real(r8), allocatable :: swsun (:,:,:) !sunlit wall absorption [-] + real(r8), allocatable :: swsha (:,:,:) !shaded wall absorption [-] + real(r8), allocatable :: sgimp (:,:,:) !impervious absorption [-] + real(r8), allocatable :: sgper (:,:,:) !pervious absorption [-] + real(r8), allocatable :: slake (:,:,:) !urban lake absorption [-] + + ! net longwave radiation for last time temperature change + real(r8), allocatable :: lwsun (:) !net longwave of sunlit wall [W/m2] + real(r8), allocatable :: lwsha (:) !net longwave of shaded wall [W/m2] + real(r8), allocatable :: lgimp (:) !net longwave of impervious [W/m2] + real(r8), allocatable :: lgper (:) !net longwave of pervious [W/m2] + real(r8), allocatable :: lveg (:) !net longwave of vegetation [W/m2] + + real(r8), allocatable :: z_sno_roof (:,:) !node depth of roof [m] + real(r8), allocatable :: z_sno_gimp (:,:) !node depth of impervious [m] + real(r8), allocatable :: z_sno_gper (:,:) !node depth pervious [m] + real(r8), allocatable :: z_sno_lake (:,:) !node depth lake [m] + + real(r8), allocatable :: dz_sno_roof (:,:) !interface depth of roof [m] + real(r8), allocatable :: dz_sno_gimp (:,:) !interface depth of impervious [m] + real(r8), allocatable :: dz_sno_gper (:,:) !interface depth pervious [m] + real(r8), allocatable :: dz_sno_lake (:,:) !interface depth lake [m] + + real(r8), allocatable :: troof_inner (:) !temperature of roof [K] + real(r8), allocatable :: twsun_inner (:) !temperature of sunlit wall [K] + real(r8), allocatable :: twsha_inner (:) !temperature of shaded wall [K] + + real(r8), allocatable :: t_roofsno (:,:) !temperature of roof [K] + real(r8), allocatable :: t_wallsun (:,:) !temperature of sunlit wall [K] + real(r8), allocatable :: t_wallsha (:,:) !temperature of shaded wall [K] + real(r8), allocatable :: t_gimpsno (:,:) !temperature of impervious [K] + real(r8), allocatable :: t_gpersno (:,:) !temperature of pervious [K] + real(r8), allocatable :: t_lakesno (:,:) !temperature of pervious [K] + + real(r8), allocatable :: wliq_roofsno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gimpsno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_gpersno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wliq_lakesno (:,:) !liquid water in layers [kg/m2] + real(r8), allocatable :: wice_roofsno (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gimpsno (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_gpersno (:,:) !ice lens in layers [kg/m2] + real(r8), allocatable :: wice_lakesno (:,:) !ice lens in layers [kg/m2] + + real(r8), allocatable :: sag_roof (:) !roof snow age [-] + real(r8), allocatable :: sag_gimp (:) !impervious ground snow age [-] + real(r8), allocatable :: sag_gper (:) !pervious ground snow age [-] + real(r8), allocatable :: sag_lake (:) !urban lake snow age [-] + + real(r8), allocatable :: scv_roof (:) !roof snow mass [kg/m2] + real(r8), allocatable :: scv_gimp (:) !impervious ground snow mass [kg/m2] + real(r8), allocatable :: scv_gper (:) !pervious ground snow mass [kg/m2] + real(r8), allocatable :: scv_lake (:) !urban lake snow mass [kg/m2] + + real(r8), allocatable :: fsno_roof (:) !roof snow fraction [-] + real(r8), allocatable :: fsno_gimp (:) !impervious ground snow fraction [-] + real(r8), allocatable :: fsno_gper (:) !pervious ground snow fraction [-] + real(r8), allocatable :: fsno_lake (:) !urban lake snow fraction [-] + + real(r8), allocatable :: snowdp_roof (:) !roof snow depth [m] + real(r8), allocatable :: snowdp_gimp (:) !impervious ground snow depth [m] + real(r8), allocatable :: snowdp_gper (:) !pervious ground snow depth [m] + real(r8), allocatable :: snowdp_lake (:) !urban lake snow depth [m] + + !TODO: rename the below variables + real(r8), allocatable :: Fhac (:) !sensible flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fwst (:) !waste heat flux from heat or cool AC [W/m2] + real(r8), allocatable :: Fach (:) !flux from inner and outer air exchange [W/m2] + real(r8), allocatable :: Fahe (:) !flux from metabolism and vehicle [W/m2] + real(r8), allocatable :: Fhah (:) !sensible heat flux from heating [W/m2] + real(r8), allocatable :: vehc (:) !flux from vehicle [W/m2] + real(r8), allocatable :: meta (:) !flux from metabolism [W/m2] + + real(r8), allocatable :: t_room (:) !temperature of inner building [K] + real(r8), allocatable :: t_roof (:) !temperature of roof [K] + real(r8), allocatable :: t_wall (:) !temperature of wall [K] + real(r8), allocatable :: tafu (:) !temperature of outer building [K] + + real(r8), allocatable :: urb_green (:) !fractional of green leaf in urban patch [-] + real(r8), allocatable :: urb_lai (:) !urban tree LAI [m2/m2] + real(r8), allocatable :: urb_sai (:) !urban tree SAI [m2/m2] + + +! PUBLIC MEMBER FUNCTIONS: + PUBLIC :: allocate_UrbanTimeVariables + PUBLIC :: deallocate_UrbanTimeVariables + PUBLIC :: READ_UrbanTimeVariables + PUBLIC :: WRITE_UrbanTimeVariables + +! PRIVATE MEMBER FUNCTIONS: + +!----------------------------------------------------------------------- + +CONTAINS + +!----------------------------------------------------------------------- + + SUBROUTINE allocate_UrbanTimeVariables () +! ------------------------------------------------------ +! Allocates memory for CLM 1d [numurban] variables +! ------------------------------------------------------ + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_LandUrban + USE MOD_Vars_Global + IMPLICIT NONE + + IF (.true.) THEN + IF (numurban > 0) THEN + allocate (fwsun (numurban)) + allocate (dfwsun (numurban)) + + allocate (sroof (2,2,numurban)) + allocate (swsun (2,2,numurban)) + allocate (swsha (2,2,numurban)) + allocate (sgimp (2,2,numurban)) + allocate (sgper (2,2,numurban)) + allocate (slake (2,2,numurban)) + + allocate (lwsun (numurban)) + allocate (lwsha (numurban)) + allocate (lgimp (numurban)) + allocate (lgper (numurban)) + allocate (lveg (numurban)) + + allocate (z_sno_roof (maxsnl+1:0,numurban)) + allocate (z_sno_gimp (maxsnl+1:0,numurban)) + allocate (z_sno_gper (maxsnl+1:0,numurban)) + allocate (z_sno_lake (maxsnl+1:0,numurban)) + + allocate (dz_sno_roof (maxsnl+1:0,numurban)) + allocate (dz_sno_gimp (maxsnl+1:0,numurban)) + allocate (dz_sno_gper (maxsnl+1:0,numurban)) + allocate (dz_sno_lake (maxsnl+1:0,numurban)) + + allocate (troof_inner (numurban)) + allocate (twsun_inner (numurban)) + allocate (twsha_inner (numurban)) + + allocate (t_roofsno (maxsnl+1:nl_roof,numurban)) + allocate (t_wallsun (maxsnl+1:nl_wall,numurban)) + allocate (t_wallsha (maxsnl+1:nl_wall,numurban)) + allocate (t_gimpsno (maxsnl+1:nl_soil,numurban)) + allocate (t_gpersno (maxsnl+1:nl_soil,numurban)) + allocate (t_lakesno (maxsnl+1:nl_soil,numurban)) + + allocate (wliq_roofsno (maxsnl+1:nl_roof,numurban)) + allocate (wice_roofsno (maxsnl+1:nl_roof,numurban)) + allocate (wliq_gimpsno (maxsnl+1:nl_soil,numurban)) + allocate (wice_gimpsno (maxsnl+1:nl_soil,numurban)) + allocate (wliq_gpersno (maxsnl+1:nl_soil,numurban)) + allocate (wice_gpersno (maxsnl+1:nl_soil,numurban)) + allocate (wliq_lakesno (maxsnl+1:nl_soil,numurban)) + allocate (wice_lakesno (maxsnl+1:nl_soil,numurban)) + + allocate (sag_roof (numurban)) + allocate (sag_gimp (numurban)) + allocate (sag_gper (numurban)) + allocate (sag_lake (numurban)) + allocate (scv_roof (numurban)) + allocate (scv_gimp (numurban)) + allocate (scv_gper (numurban)) + allocate (scv_lake (numurban)) + allocate (fsno_roof (numurban)) + allocate (fsno_gimp (numurban)) + allocate (fsno_gper (numurban)) + allocate (fsno_lake (numurban)) + allocate (snowdp_roof (numurban)) + allocate (snowdp_gimp (numurban)) + allocate (snowdp_gper (numurban)) + allocate (snowdp_lake (numurban)) + + allocate (Fhac (numurban)) + allocate (Fwst (numurban)) + allocate (Fach (numurban)) + allocate (Fahe (numurban)) + allocate (Fhah (numurban)) + allocate (vehc (numurban)) + allocate (meta (numurban)) + + allocate (t_room (numurban)) + allocate (t_roof (numurban)) + allocate (t_wall (numurban)) + allocate (tafu (numurban)) + + allocate (urb_green (numurban)) + allocate (urb_lai (numurban)) + allocate (urb_sai (numurban)) + ENDIF + ENDIF + END SUBROUTINE allocate_UrbanTimeVariables + + SUBROUTINE READ_UrbanTimeVariables (file_restart) + + USE MOD_NetCDFVector + USE MOD_LandUrban + USE MOD_Vars_Global + + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + CALL ncio_read_vector (file_restart, 'fwsun' , landurban, fwsun ) + CALL ncio_read_vector (file_restart, 'dfwsun', landurban, dfwsun) + + CALL ncio_read_vector (file_restart, 'sroof', 2, 2, landurban, sroof) + CALL ncio_read_vector (file_restart, 'swsun', 2, 2, landurban, swsun) + CALL ncio_read_vector (file_restart, 'swsha', 2, 2, landurban, swsha) + CALL ncio_read_vector (file_restart, 'sgimp', 2, 2, landurban, sgimp) + CALL ncio_read_vector (file_restart, 'sgper', 2, 2, landurban, sgper) + CALL ncio_read_vector (file_restart, 'slake', 2, 2, landurban, slake) + + CALL ncio_read_vector (file_restart, 'lwsun', landurban, lwsun) + CALL ncio_read_vector (file_restart, 'lwsha', landurban, lwsha) + CALL ncio_read_vector (file_restart, 'lgimp', landurban, lgimp) + CALL ncio_read_vector (file_restart, 'lgper', landurban, lgper) + CALL ncio_read_vector (file_restart, 'lveg' , landurban, lveg ) + + CALL ncio_read_vector (file_restart, 'z_sno_roof' , -maxsnl, landurban, z_sno_roof ) + CALL ncio_read_vector (file_restart, 'z_sno_gimp' , -maxsnl, landurban, z_sno_gimp ) + CALL ncio_read_vector (file_restart, 'z_sno_gper' , -maxsnl, landurban, z_sno_gper ) + CALL ncio_read_vector (file_restart, 'z_sno_lake' , -maxsnl, landurban, z_sno_lake ) + + CALL ncio_read_vector (file_restart, 'dz_sno_roof', -maxsnl, landurban, dz_sno_roof) + CALL ncio_read_vector (file_restart, 'dz_sno_gimp', -maxsnl, landurban, dz_sno_gimp) + CALL ncio_read_vector (file_restart, 'dz_sno_gper', -maxsnl, landurban, dz_sno_gper) + CALL ncio_read_vector (file_restart, 'dz_sno_lake', -maxsnl, landurban, dz_sno_lake) + + CALL ncio_read_vector (file_restart, 'troof_inner', landurban, troof_inner) + CALL ncio_read_vector (file_restart, 'twsun_inner', landurban, twsun_inner) + CALL ncio_read_vector (file_restart, 'twsha_inner', landurban, twsha_inner) + + CALL ncio_read_vector (file_restart, 't_roofsno', nl_roof-maxsnl, landurban, t_roofsno) + CALL ncio_read_vector (file_restart, 't_wallsun', nl_wall-maxsnl, landurban, t_wallsun) + CALL ncio_read_vector (file_restart, 't_wallsha', nl_wall-maxsnl, landurban, t_wallsha) + CALL ncio_read_vector (file_restart, 't_gimpsno', nl_soil-maxsnl, landurban, t_gimpsno) + CALL ncio_read_vector (file_restart, 't_gpersno', nl_soil-maxsnl, landurban, t_gpersno) + CALL ncio_read_vector (file_restart, 't_lakesno', nl_soil-maxsnl, landurban, t_lakesno) + + CALL ncio_read_vector (file_restart, 'wliq_roofsno', nl_roof-maxsnl, landurban, wliq_roofsno) + CALL ncio_read_vector (file_restart, 'wliq_gimpsno', nl_soil-maxsnl, landurban, wliq_gimpsno) + CALL ncio_read_vector (file_restart, 'wliq_gpersno', nl_soil-maxsnl, landurban, wliq_gpersno) + CALL ncio_read_vector (file_restart, 'wliq_lakesno', nl_soil-maxsnl, landurban, wliq_lakesno) + CALL ncio_read_vector (file_restart, 'wice_roofsno', nl_roof-maxsnl, landurban, wice_roofsno) + CALL ncio_read_vector (file_restart, 'wice_gimpsno', nl_soil-maxsnl, landurban, wice_gimpsno) + CALL ncio_read_vector (file_restart, 'wice_gpersno', nl_soil-maxsnl, landurban, wice_gpersno) + CALL ncio_read_vector (file_restart, 'wice_lakesno', nl_soil-maxsnl, landurban, wice_lakesno) + + CALL ncio_read_vector (file_restart, 'sag_roof' , landurban, sag_roof ) + CALL ncio_read_vector (file_restart, 'sag_gimp' , landurban, sag_gimp ) + CALL ncio_read_vector (file_restart, 'sag_gper' , landurban, sag_gper ) + CALL ncio_read_vector (file_restart, 'sag_lake' , landurban, sag_lake ) + CALL ncio_read_vector (file_restart, 'scv_roof' , landurban, scv_roof ) + CALL ncio_read_vector (file_restart, 'scv_gimp' , landurban, scv_gimp ) + CALL ncio_read_vector (file_restart, 'scv_gper' , landurban, scv_gper ) + CALL ncio_read_vector (file_restart, 'scv_lake' , landurban, scv_lake ) + CALL ncio_read_vector (file_restart, 'fsno_roof' , landurban, fsno_roof ) + CALL ncio_read_vector (file_restart, 'fsno_gimp' , landurban, fsno_gimp ) + CALL ncio_read_vector (file_restart, 'fsno_gper' , landurban, fsno_gper ) + CALL ncio_read_vector (file_restart, 'fsno_lake' , landurban, fsno_lake ) + CALL ncio_read_vector (file_restart, 'snowdp_roof', landurban, snowdp_roof) + CALL ncio_read_vector (file_restart, 'snowdp_gimp', landurban, snowdp_gimp) + CALL ncio_read_vector (file_restart, 'snowdp_gper', landurban, snowdp_gper) + CALL ncio_read_vector (file_restart, 'snowdp_lake', landurban, snowdp_lake) + CALL ncio_read_vector (file_restart, 'Fhac' , landurban, Fhac ) + CALL ncio_read_vector (file_restart, 'Fwst' , landurban, Fwst ) + CALL ncio_read_vector (file_restart, 'Fach' , landurban, Fach ) + CALL ncio_read_vector (file_restart, 'Fahe' , landurban, Fahe ) + CALL ncio_read_vector (file_restart, 'Fhah' , landurban, Fhah ) + CALL ncio_read_vector (file_restart, 'vehc' , landurban, vehc ) + CALL ncio_read_vector (file_restart, 'meta' , landurban, meta ) + CALL ncio_read_vector (file_restart, 't_room ' , landurban, t_room ) + CALL ncio_read_vector (file_restart, 't_roof' , landurban, t_roof ) + CALL ncio_read_vector (file_restart, 't_wall' , landurban, t_wall ) + CALL ncio_read_vector (file_restart, 'tafu' , landurban, tafu ) + CALL ncio_read_vector (file_restart, 'urb_green' , landurban, urb_green ) + CALL ncio_read_vector (file_restart, 'tree_lai' , landurban, urb_lai ) + CALL ncio_read_vector (file_restart, 'tree_sai' , landurban, urb_sai ) + + END SUBROUTINE READ_UrbanTimeVariables + + SUBROUTINE WRITE_UrbanTimeVariables (file_restart) + + USE MOD_Namelist, only: DEF_REST_CompressLevel + USE MOD_LandUrban + USE MOD_NetCDFVector + USE MOD_Vars_Global + IMPLICIT NONE + + character(len=*), intent(in) :: file_restart + + ! Local variables + integer :: compress + + compress = DEF_REST_CompressLevel + + CALL ncio_create_file_vector (file_restart, landurban) + CALL ncio_define_dimension_vector (file_restart, landurban, 'urban') + + CALL ncio_define_dimension_vector (file_restart, landurban, 'snow' , -maxsnl ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'soil' , nl_soil ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'roof' , nl_roof ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'wall' , nl_wall ) + CALL ncio_define_dimension_vector (file_restart, landurban, 'soilsnow', nl_soil-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landurban, 'roofsnow', nl_roof-maxsnl) + CALL ncio_define_dimension_vector (file_restart, landurban, 'wallsnow', nl_wall-maxsnl) + + CALL ncio_define_dimension_vector (file_restart, landurban, 'band', 2) + CALL ncio_define_dimension_vector (file_restart, landurban, 'rtyp', 2) + + CALL ncio_write_vector (file_restart, 'fwsun' , 'urban', landurban, fwsun , compress) + CALL ncio_write_vector (file_restart, 'dfwsun', 'urban', landurban, dfwsun, compress) + + CALL ncio_write_vector (file_restart, 'sroof', 'band', 2, 'rtyp', 2, 'urban', landurban, sroof, compress) + CALL ncio_write_vector (file_restart, 'swsun', 'band', 2, 'rtyp', 2, 'urban', landurban, swsun, compress) + CALL ncio_write_vector (file_restart, 'swsha', 'band', 2, 'rtyp', 2, 'urban', landurban, swsha, compress) + CALL ncio_write_vector (file_restart, 'sgimp', 'band', 2, 'rtyp', 2, 'urban', landurban, sgimp, compress) + CALL ncio_write_vector (file_restart, 'sgper', 'band', 2, 'rtyp', 2, 'urban', landurban, sgper, compress) + CALL ncio_write_vector (file_restart, 'slake', 'band', 2, 'rtyp', 2, 'urban', landurban, slake, compress) + + CALL ncio_write_vector (file_restart, 'lwsun', 'urban', landurban, lwsun, compress) + CALL ncio_write_vector (file_restart, 'lwsha', 'urban', landurban, lwsha, compress) + CALL ncio_write_vector (file_restart, 'lgimp', 'urban', landurban, lgimp, compress) + CALL ncio_write_vector (file_restart, 'lgper', 'urban', landurban, lgper, compress) + CALL ncio_write_vector (file_restart, 'lveg' , 'urban', landurban, lveg , compress) + + CALL ncio_write_vector (file_restart, 'z_sno_roof' , 'snow', -maxsnl, 'urban', landurban, z_sno_roof , compress) + CALL ncio_write_vector (file_restart, 'z_sno_gimp' , 'snow', -maxsnl, 'urban', landurban, z_sno_gimp , compress) + CALL ncio_write_vector (file_restart, 'z_sno_gper' , 'snow', -maxsnl, 'urban', landurban, z_sno_gper , compress) + CALL ncio_write_vector (file_restart, 'z_sno_lake' , 'snow', -maxsnl, 'urban', landurban, z_sno_lake , compress) + + CALL ncio_write_vector (file_restart, 'dz_sno_roof', 'snow', -maxsnl, 'urban', landurban, dz_sno_roof, compress) + CALL ncio_write_vector (file_restart, 'dz_sno_gimp', 'snow', -maxsnl, 'urban', landurban, dz_sno_gimp, compress) + CALL ncio_write_vector (file_restart, 'dz_sno_gper', 'snow', -maxsnl, 'urban', landurban, dz_sno_gper, compress) + CALL ncio_write_vector (file_restart, 'dz_sno_lake', 'snow', -maxsnl, 'urban', landurban, dz_sno_lake, compress) + + CALL ncio_write_vector (file_restart, 'troof_inner', 'urban', landurban, troof_inner, compress) + CALL ncio_write_vector (file_restart, 'twsun_inner', 'urban', landurban, twsun_inner, compress) + CALL ncio_write_vector (file_restart, 'twsha_inner', 'urban', landurban, twsha_inner, compress) + + CALL ncio_write_vector (file_restart, 't_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, t_roofsno, compress) + CALL ncio_write_vector (file_restart, 't_wallsun', 'wallsnow', nl_wall-maxsnl, 'urban', landurban, t_wallsun, compress) + CALL ncio_write_vector (file_restart, 't_wallsha', 'wallsnow', nl_wall-maxsnl, 'urban', landurban, t_wallsha, compress) + CALL ncio_write_vector (file_restart, 't_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_gimpsno, compress) + CALL ncio_write_vector (file_restart, 't_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_gpersno, compress) + CALL ncio_write_vector (file_restart, 't_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, t_lakesno, compress) + + CALL ncio_write_vector (file_restart, 'wliq_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, wliq_roofsno, compress) + CALL ncio_write_vector (file_restart, 'wliq_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_gimpsno, compress) + CALL ncio_write_vector (file_restart, 'wliq_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_gpersno, compress) + CALL ncio_write_vector (file_restart, 'wliq_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wliq_lakesno, compress) + CALL ncio_write_vector (file_restart, 'wice_roofsno', 'roofsnow', nl_roof-maxsnl, 'urban', landurban, wice_roofsno, compress) + CALL ncio_write_vector (file_restart, 'wice_gimpsno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_gimpsno, compress) + CALL ncio_write_vector (file_restart, 'wice_gpersno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_gpersno, compress) + CALL ncio_write_vector (file_restart, 'wice_lakesno', 'soilsnow', nl_soil-maxsnl, 'urban', landurban, wice_lakesno, compress) + + CALL ncio_write_vector (file_restart, 'sag_roof' , 'urban', landurban, sag_roof , compress) + CALL ncio_write_vector (file_restart, 'sag_gimp' , 'urban', landurban, sag_gimp , compress) + CALL ncio_write_vector (file_restart, 'sag_gper' , 'urban', landurban, sag_gper , compress) + CALL ncio_write_vector (file_restart, 'sag_lake' , 'urban', landurban, sag_lake , compress) + CALL ncio_write_vector (file_restart, 'scv_roof' , 'urban', landurban, scv_roof , compress) + CALL ncio_write_vector (file_restart, 'scv_gimp' , 'urban', landurban, scv_gimp , compress) + CALL ncio_write_vector (file_restart, 'scv_gper' , 'urban', landurban, scv_gper , compress) + CALL ncio_write_vector (file_restart, 'scv_lake' , 'urban', landurban, scv_lake , compress) + CALL ncio_write_vector (file_restart, 'fsno_roof' , 'urban', landurban, fsno_roof , compress) + CALL ncio_write_vector (file_restart, 'fsno_gimp' , 'urban', landurban, fsno_gimp , compress) + CALL ncio_write_vector (file_restart, 'fsno_gper' , 'urban', landurban, fsno_gper , compress) + CALL ncio_write_vector (file_restart, 'fsno_lake' , 'urban', landurban, fsno_lake , compress) + CALL ncio_write_vector (file_restart, 'snowdp_roof', 'urban', landurban, snowdp_roof, compress) + CALL ncio_write_vector (file_restart, 'snowdp_gimp', 'urban', landurban, snowdp_gimp, compress) + CALL ncio_write_vector (file_restart, 'snowdp_gper', 'urban', landurban, snowdp_gper, compress) + CALL ncio_write_vector (file_restart, 'snowdp_lake', 'urban', landurban, snowdp_lake, compress) + CALL ncio_write_vector (file_restart, 't_room' , 'urban', landurban, t_room , compress) + CALL ncio_write_vector (file_restart, 't_roof' , 'urban', landurban, t_roof , compress) + CALL ncio_write_vector (file_restart, 't_wall' , 'urban', landurban, t_wall , compress) + CALL ncio_write_vector (file_restart, 'tafu' , 'urban', landurban, tafu , compress) + CALL ncio_write_vector (file_restart, 'Fhac' , 'urban', landurban, Fhac , compress) + CALL ncio_write_vector (file_restart, 'Fwst' , 'urban', landurban, Fwst , compress) + CALL ncio_write_vector (file_restart, 'Fach' , 'urban', landurban, Fach , compress) + CALL ncio_write_vector (file_restart, 'Fahe' , 'urban', landurban, Fahe , compress) + CALL ncio_write_vector (file_restart, 'Fhah' , 'urban', landurban, Fhah , compress) + CALL ncio_write_vector (file_restart, 'vehc' , 'urban', landurban, vehc , compress) + CALL ncio_write_vector (file_restart, 'meta' , 'urban', landurban, meta , compress) + CALL ncio_write_vector (file_restart, 'tree_lai' , 'urban', landurban, urb_lai , compress) + CALL ncio_write_vector (file_restart, 'tree_sai' , 'urban', landurban, urb_sai , compress) + CALL ncio_write_vector (file_restart, 'urb_green' , 'urban', landurban, urb_green , compress) + + END SUBROUTINE WRITE_UrbanTimeVariables + + SUBROUTINE deallocate_UrbanTimeVariables + + USE MOD_MPAS_MPI + USE MOD_LandUrban + + IF (.true.) THEN + IF (numurban > 0) THEN + deallocate (fwsun ) + deallocate (dfwsun ) + + deallocate (sroof ) + deallocate (swsun ) + deallocate (swsha ) + deallocate (sgimp ) + deallocate (sgper ) + deallocate (slake ) + + deallocate (lwsun ) + deallocate (lwsha ) + deallocate (lgimp ) + deallocate (lgper ) + deallocate (lveg ) + + deallocate (z_sno_roof ) + deallocate (z_sno_gimp ) + deallocate (z_sno_gper ) + deallocate (z_sno_lake ) + + deallocate (dz_sno_roof ) + deallocate (dz_sno_gimp ) + deallocate (dz_sno_gper ) + deallocate (dz_sno_lake ) + + deallocate (t_roofsno ) + deallocate (t_wallsun ) + deallocate (t_wallsha ) + deallocate (t_gimpsno ) + deallocate (t_gpersno ) + deallocate (t_lakesno ) + + deallocate (troof_inner ) + deallocate (twsun_inner ) + deallocate (twsha_inner ) + + deallocate (wliq_roofsno ) + deallocate (wice_roofsno ) + deallocate (wliq_gimpsno ) + deallocate (wice_gimpsno ) + deallocate (wliq_gpersno ) + deallocate (wice_gpersno ) + deallocate (wliq_lakesno ) + deallocate (wice_lakesno ) + + deallocate (sag_roof ) + deallocate (sag_gimp ) + deallocate (sag_gper ) + deallocate (sag_lake ) + deallocate (scv_roof ) + deallocate (scv_gimp ) + deallocate (scv_gper ) + deallocate (scv_lake ) + deallocate (fsno_roof ) + deallocate (fsno_gimp ) + deallocate (fsno_gper ) + deallocate (fsno_lake ) + deallocate (snowdp_roof ) + deallocate (snowdp_gimp ) + deallocate (snowdp_gper ) + deallocate (snowdp_lake ) + + deallocate (Fhac ) + deallocate (Fwst ) + deallocate (Fach ) + deallocate (Fahe ) + deallocate (Fhah ) + deallocate (vehc ) + deallocate (meta ) + + deallocate (t_room ) + deallocate (t_roof ) + deallocate (t_wall ) + deallocate (tafu ) + + deallocate (urb_green ) + deallocate (urb_lai ) + deallocate (urb_sai ) + ENDIF + ENDIF + + END SUBROUTINE deallocate_UrbanTimeVariables + +END MODULE MOD_Urban_Vars_TimeVariables +#endif +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_WallTemperature.F90 b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_WallTemperature.F90 new file mode 100644 index 0000000000..1821feb6c8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/main/URBAN/MOD_Urban_WallTemperature.F90 @@ -0,0 +1,190 @@ +#include + +MODULE MOD_Urban_WallTemperature +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! +! The thickness of the wall (including the shady wall and the sunny +! wall) is read from external data. Just like the soil, it is also +! divided into 10 layers, with the same thickness set for each layer, +! and its thermal parameters are also read from external data. Unlike +! pervious/impervious surfaces, the wall does not consider water +! accumulation or snow cover, so its thermal properties are completely +! determined by its own materials. At the same time, it does not +! consider water transfer, phase change processes, and latent heat +! exchange. +! +! Another difference is in the setting of heat exchange for the +! innermost (bottom) layer. For soil and impervious surfaces, the lack +! of heat exchange in the bottom layer is considered. However, for +! walls, the heat exchange between the indoor wall surface air and the +! innermost layer of the wall is considered. Apart from this, the other +! aspects and the solution process are similar to the temperature +! solution for the soil. +! +! Created by Yongjiu Dai and Hua Yuan, 05/2020 +! +!----------------------------------------------------------------------- + USE MOD_Precision + IMPLICIT NONE + SAVE + + PUBLIC :: UrbanWallTem + +CONTAINS + + + SUBROUTINE UrbanWallTem (deltim,capr,cnfac,& + cv_wall,tk_wall,t_wall,dz_wall,z_wall,zi_wall,& + twall_inner,lwall,clwall,sabwall,fsenwall,cwalls,tkdz_wall) + +!======================================================================= +! Wall temperatures +! o Boundary conditions: +! F = Rnet - Hg - LEg (top), +! For urban sunwall, shadewall, and wall columns, there is a non-zero +! heat flux across the bottom "building inner surface" layer and the +! equations are derived assuming a prescribed or adjusted internal +! building temperature. T = T_wall_inner (at the wall inner surface). +! +! o Wall temperature is predicted from heat conduction in N wall layers +! and up to 5 snow layers. The thermal conductivities at the +! interfaces between two neighbor layers (j, j+1) are derived from an +! assumption that the flux across the interface is equal to that from +! the node j to the interface and the flux from the interface to the +! node j+1. The equation is solved using the Crank-Nicholson method +! and resulted in a tridiagonal system equation. +! +! o no Phase change +! +! Original author: Yongjiu Dai, 05/2020 +!======================================================================= + + USE MOD_Precision + USE MOD_Vars_Global + USE MOD_Const_Physical + USE MOD_Utils, only: tridia + + IMPLICIT NONE + +!-------------------------- Dummy Arguments ---------------------------- + real(r8), intent(in) :: deltim !seconds in a time step [second] + real(r8), intent(in) :: capr !tuning factor to turn first layer T into surface T + real(r8), intent(in) :: cnfac !Crank Nicholson factor between 0 and 1 + + real(r8), intent(in) :: cv_wall(1:nl_wall) !heat capacity of urban wall [J/m3/K] + real(r8), intent(in) :: tk_wall(1:nl_wall) !thermal conductivity of urban wall [W/m/K] + + real(r8), intent(in) :: dz_wall(1:nl_wall) !layer thickness [m] + real(r8), intent(in) :: z_wall (1:nl_wall) !node depth [m] + real(r8), intent(in) :: zi_wall(0:nl_wall) !interface depth [m] + + real(r8), intent(in) :: twall_inner !temperature at the wall inner surface [K] + real(r8), intent(in) :: lwall !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: clwall !atmospheric infrared (longwave) radiation [W/m2] + real(r8), intent(in) :: sabwall !solar radiation absorbed by wall [W/m2] + real(r8), intent(in) :: fsenwall !sensible heat flux from wall [W/m2] + real(r8), intent(in) :: cwalls !deriv. of wall energy flux to wall temp [w/m2/k] + + real(r8), intent(inout) :: t_wall(1:nl_wall) !wall layers' temperature [K] + real(r8), intent(inout) :: tkdz_wall !inner wall heat flux [w/m2/k] + +!-------------------------- Local Variables ---------------------------- + real(r8) wice_wall(1:nl_wall) !ice lens [kg/m2] + real(r8) wliq_wall(1:nl_wall) !liquid water [kg/m2] + + real(r8) cv (1:nl_wall) !heat capacity [J/(m2 K)] + real(r8) thk(1:nl_wall) !thermal conductivity of layer + real(r8) tk (1:nl_wall) !thermal conductivity [W/(m K)] + + real(r8) at (1:nl_wall) !"a" vector for tridiagonal matrix + real(r8) bt (1:nl_wall) !"b" vector for tridiagonal matrix + real(r8) ct (1:nl_wall) !"c" vector for tridiagonal matrix + real(r8) rt (1:nl_wall) !"r" vector for tridiagonal solution + + real(r8) fn (1:nl_wall) !heat diffusion through the layer interface [W/m2] + real(r8) fn1(1:nl_wall) !heat diffusion through the layer interface [W/m2] + real(r8) fact(1:nl_wall) !used in computing tridiagonal matrix + real(r8) dzm !used in computing tridiagonal matrix + real(r8) dzp !used in computing tridiagonal matrix + + real(r8) t_wall_bef(1:nl_wall) !wall/snow temperature before update + real(r8) hs !net energy flux into the surface (w/m2) + real(r8) dhsdt !d(hs)/dT + + integer i,j + +!----------------------------------------------------------------------- + + wice_wall(1:) = 0.0 !ice lens [kg/m2] + wliq_wall(1:) = 0.0 !liquid water [kg/m2] + + cv(1:) = cv_wall(1:)*dz_wall(1:) + + thk(1:) = tk_wall(1:) + + DO j = 1, nl_wall-1 + tk(j) = thk(j)*thk(j+1)*(z_wall(j+1)-z_wall(j)) & + /(thk(j)*(z_wall(j+1)-zi_wall(j))+thk(j+1)*(zi_wall(j)-z_wall(j))) + ENDDO + tk(nl_wall) = thk(nl_wall) + +! net ground heat flux into the wall surface and its temperature derivative + hs = sabwall + lwall - fsenwall + dhsdT = - cwalls + clwall + + t_wall_bef(1:) = t_wall(1:) + + j = 1 + fact(j) = deltim / cv(j) * dz_wall(j) & + / (0.5*(z_wall(j)-zi_wall(j-1)+capr*(z_wall(j+1)-zi_wall(j-1)))) + + DO j = 1, nl_wall + fact(j) = deltim/cv(j) + ENDDO + + DO j = 1, nl_wall - 1 + fn(j) = tk(j)*(t_wall(j+1)-t_wall(j))/(z_wall(j+1)-z_wall(j)) + ENDDO + + j = nl_wall + fn(j) = tk(j)*(twall_inner - cnfac*t_wall(j))/(zi_wall(j)-z_wall(j)) + tkdz_wall= tk(j)/(zi_wall(j)-z_wall(j)) + +! set up vector r and vectors a, b, c that define tridiagonal matrix + j = 1 + dzp = z_wall(j+1)-z_wall(j) + at(j) = 0. + bt(j) = 1+(1.-cnfac)*fact(j)*tk(j)/dzp-fact(j)*dhsdT + ct(j) = -(1.-cnfac)*fact(j)*tk(j)/dzp + rt(j) = t_wall(j) + fact(j)*( hs - dhsdT*t_wall(j) + cnfac*fn(j) ) + + DO j = 2, nl_wall - 1 + dzm = (z_wall(j)-z_wall(j-1)) + dzp = (z_wall(j+1)-z_wall(j)) + at(j) = - (1.-cnfac)*fact(j)* tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j)/dzp + tk(j-1)/dzm) + ct(j) = - (1.-cnfac)*fact(j)* tk(j)/dzp + rt(j) = t_wall(j) + cnfac*fact(j)*( fn(j) - fn(j-1) ) + ENDDO + + j = nl_wall + dzm = (z_wall(j)-z_wall(j-1)) + dzp = (zi_wall(j)-z_wall(j)) + at(j) = - (1.-cnfac)*fact(j)*tk(j-1)/dzm + bt(j) = 1.+ (1.-cnfac)*fact(j)*(tk(j-1)/dzm+tk(j)/dzp) + ct(j) = 0. + rt(j) = t_wall(j) + fact(j)*(fn(j) - cnfac*fn(j-1)) + +! solve for t_wall + i = size(at) + CALL tridia (i ,at ,bt ,ct ,rt ,t_wall) + + j = nl_wall + fn1(j) = tk(j)*(twall_inner - cnfac*t_wall(j))/(zi_wall(j)-z_wall(j)) + + END SUBROUTINE UrbanWallTem + +END MODULE MOD_Urban_WallTemperature +! ---------- EOP ------------ diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 new file mode 100644 index 0000000000..836a1bca58 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_5x5DataReadin.F90 @@ -0,0 +1,554 @@ +#include + +MODULE MOD_5x5DataReadin + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Reading data in netCDF files by 5 degree blocks. +! +! The file name gives the boundaries of the block. +! For example, file "RG_65_75_60_80.URB2010.nc" stores data in region +! from 65N to 60N and 75E to 80E. +! +! Notice that: +! 1. Subroutines loop over all 5 degree blocks in simulation region. +! 2. Latitude in files is from north to south. +! 3. "read_5x5_data_pft" reads data with dimension "pft" and permute +! dimension (lon,lat,pft) in files to (pft,lon,lat) in variables. +! 4. "read_5x5_data_time" reads data with dimension "time" +! at given time. +! 5. "read_5x5_data_pft_time" reads data with dimension "pft" and "time" +! at given time and permute dimension (lon,lat,pft) in files +! to (pft,lon,lat) in variables. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_NetCDFSerial, only: nccheck + IMPLICIT NONE + + integer, parameter :: N_PFT_modis = 16 + + INTERFACE read_5x5_data + MODULE procedure read_5x5_data_int32 + MODULE procedure read_5x5_data_real8 + END INTERFACE read_5x5_data + + PUBLIC :: read_5x5_data_pft + PUBLIC :: read_5x5_data_time + PUBLIC :: read_5x5_data_pft_time + +CONTAINS + + ! ----- + SUBROUTINE this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + USE MOD_Grid + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + + integer, intent(in) :: nxbox, nybox, nxglb + integer, intent(in) :: isouth, inorth, iwest, ieast + integer, intent(inout) :: ibox, jbox, ibox0 + integer, intent(out) :: i0, i1, j0, j1 + integer, intent(out) :: il0, il1, jl0, jl1 + + character (len=*), intent(out) :: file_5x5 + + ! Local variables + integer :: xdsp, ydsp + character(len=4) :: str + + xdsp = (ibox-1) * nxbox + ydsp = (jbox-1) * nybox + + j0 = max(inorth-ydsp, 1) + j1 = min(isouth-ydsp, nybox) + jl0 = j0 + ydsp - inorth + 1 + jl1 = j1 + ydsp - inorth + 1 + + IF (ieast >= iwest) THEN + i0 = max(iwest-xdsp, 1) + i1 = min(ieast-xdsp, nxbox) + il0 = i0 + xdsp - iwest + 1 + il1 = i1 + xdsp - iwest + 1 + ELSE + IF (iwest <= xdsp+nxbox) THEN + i0 = max(iwest-xdsp, 1) + i1 = nxbox + il0 = i0 + xdsp - iwest + 1 + il1 = i1 + xdsp - iwest + 1 + ELSE + i0 = 1 + i1 = min(ieast-xdsp, nxbox) + il0 = i0 + xdsp + nxglb - iwest + 1 + il1 = i1 + xdsp + nxglb - iwest + 1 + ENDIF + ENDIF + + file_5x5 = trim(dir_5x5) // '/RG' + write(str, '(I4)') (19-jbox)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (ibox-37)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (18-jbox)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (ibox-36)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + file_5x5 = trim(file_5x5) // '.' // trim(sfx) // '.nc' + + IF ((ieast >= xdsp + 1) .and. (ieast <= xdsp + nxbox)) THEN + IF (isouth <= ydsp + nybox) THEN + jbox = -1 + ELSE + ibox = ibox0 + jbox = jbox + 1 + ENDIF + ELSE + ibox = mod(ibox, nxglb/nxbox) + 1 + ENDIF + + END SUBROUTINE this_block_and_move_to_next + + ! ----- + SUBROUTINE read_5x5_data_int32 (dir_5x5, sfx, grid, dataname, rdata) + + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + type (block_data_int32_2d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + integer, allocatable :: dcache(:,:) + logical :: fexists + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (.true.) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, (/i0,j0/), (/i1-i0+1,j1-j0+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + rdata%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache + + deallocate (dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_int32 + + ! ----- + SUBROUTINE read_5x5_data_real8 (dir_5x5, sfx, grid, dataname, rdata) + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + real(r8), allocatable :: dcache(:,:) + logical :: fexists + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (.true.) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, (/i0,j0/), (/i1-i0+1,j1-j0+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + rdata%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache + + deallocate(dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_real8 + + ! ----- + SUBROUTINE read_5x5_data_pft (dir_5x5, sfx, grid, dataname, rdata) + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + type (block_data_real8_3d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + real(r8), allocatable :: dcache(:,:,:) + logical :: fexists + integer :: ipft + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (.true.) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1,0:N_PFT_modis-1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, & + (/i0,j0,1/), (/i1-i0+1,j1-j0+1,N_PFT_modis/)) ) + CALL nccheck( nf90_close(ncid) ) + + DO ipft = 0, N_PFT_modis-1 + rdata%blk(iblk,jblk)%val(ipft,il0:il1,jl0:jl1) = dcache(:,:,ipft) + ENDDO + + deallocate (dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_pft + + ! ----- + SUBROUTINE read_5x5_data_time (dir_5x5, sfx, grid, dataname, time, rdata) + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + integer, intent(in) :: time + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + real(r8), allocatable :: dcache(:,:) + logical :: fexists + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (.true.) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, & + (/i0,j0,time/), (/i1-i0+1,j1-j0+1,1/)) ) + CALL nccheck( nf90_close(ncid) ) + + rdata%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache + + deallocate (dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_time + + ! ----- + SUBROUTINE read_5x5_data_pft_time (dir_5x5, sfx, grid, dataname, time, rdata) + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE netcdf + IMPLICIT NONE + + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + type (grid_type), intent(in) :: grid + + character (len=*), intent(in) :: dataname + integer, intent(in) :: time + type (block_data_real8_3d), intent(inout) :: rdata + + ! Local variables + integer :: nxbox, nybox, nxglb, nyglb + integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox, ibox0 + integer :: i0, i1, j0, j1, il0, il1, jl0, jl1 + character(len=256) :: file_5x5 + integer :: ncid, varid + real(r8), allocatable :: dcache(:,:,:) + logical :: fexists + integer :: ipft + + nxglb = grid%nlon + nyglb = grid%nlat + + nxbox = nxglb / 360 * 5 + nybox = nyglb / 180 * 5 + + IF (.true.) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (grid%xcnt(iblk) == 0) CYCLE + IF (grid%ycnt(jblk) == 0) CYCLE + + rdata%blk(iblk,jblk)%val(:,:,:) = 0 + + inorth = grid%ydsp(jblk) + 1 + isouth = grid%ydsp(jblk) + grid%ycnt(jblk) + + iwest = grid%xdsp(iblk) + 1 + ieast = grid%xdsp(iblk) + grid%xcnt(iblk) + IF (ieast > nxglb) ieast = ieast - nxglb + + ibox = grid%xdsp(iblk)/nxbox + 1 + jbox = grid%ydsp(jblk)/nybox + 1 + ibox0 = ibox + + DO WHILE (.true.) + + CALL this_block_and_move_to_next ( & + dir_5x5, sfx, nxbox, nybox, nxglb, isouth, inorth, iwest, ieast, & + ibox, jbox, ibox0, i0, i1, j0, j1, il0, il1, jl0, jl1, & + file_5x5) + + inquire(file=file_5x5, exist=fexists) + IF (fexists) THEN + allocate (dcache (i1-i0+1,j1-j0+1,0:N_PFT_modis-1)) + + CALL nccheck( nf90_open(trim(file_5x5), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid) ) + CALL nccheck( nf90_get_var(ncid, varid, dcache, & + (/i0,j0,1,time/), (/i1-i0+1,j1-j0+1,N_PFT_modis,1/)) ) + CALL nccheck( nf90_close(ncid) ) + + DO ipft = 0, N_PFT_modis-1 + rdata%blk(iblk,jblk)%val(ipft,il0:il1,jl0:jl1) = dcache(:,:,ipft) + ENDDO + + deallocate (dcache) + ENDIF + + IF (jbox == -1) EXIT + + ENDDO + + ENDDO + + ENDIF + + END SUBROUTINE read_5x5_data_pft_time + +END MODULE MOD_5x5DataReadin diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 new file mode 100644 index 0000000000..5fc4504872 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90 @@ -0,0 +1,207 @@ +#include + +MODULE MOD_Block + +!------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! To deal with high-resolution data, the globe is divided into blocks. +! +! (180W,90N) (180E,90N) +! .-----------------------------------. +! | | | | | +! | | | | | +! | | | | | +! .-----------------------------------. +! | | | | | +! | | | | | +! | | | | | +! .-----------------------------------. +! | | | | | +! | | | | | +! | | | | | +! .-----------------------------------. +! (180W,90S) (180E,90S) +! +! 1. +! Boundaries for block (i,j) is saved in +! "gblock%lat_s(j), gblock%lat_n(j), gblock%lon_w(i), gblock%lon_e(i)" +! for south, north, west and east boundaries respectively. +! +! 2. In embedded mode, owner_rank(i,j) records whether this MPAS rank owns +! cells whose CoLM elements are stored in block (i,j). A value of -1 means +! that the block is not part of this rank's local cell subset. +! +! 3. "gblock%nblkme, gblock%xblkme(:), gblock%yblkme(:)" contain the local +! block list derived from MPAS cell ownership. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + ! ---- data types ---- + type :: block_type + + ! Coordinates. + integer :: nxblk, nyblk + real(r8), allocatable :: lat_s (:) + real(r8), allocatable :: lat_n (:) + real(r8), allocatable :: lon_w (:) + real(r8), allocatable :: lon_e (:) + + integer, allocatable :: owner_rank(:,:) + + integer :: nblkme + integer, allocatable :: xblkme(:), yblkme(:) + + CONTAINS + + procedure, PUBLIC :: load_from_file => block_load_from_file + + final :: block_free_mem + + END type block_type + + ! ---- Instance ---- + type (block_type) :: gblock + + + ! ---- PUBLIC SUBROUTINE ---- + PUBLIC :: get_filename_block + +CONTAINS + + ! -------------------------------- + SUBROUTINE block_load_from_file (this, dir_landdata) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI, only: mpas_is_root, CoLM_stop + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + class (block_type) :: this + character(len=*), intent(in) :: dir_landdata + + ! Local variables + character(len=256) :: filename + + filename = trim(dir_landdata) // '/block.nc' + + CALL ncio_read_bcast_serial (filename, 'lat_s', this%lat_s) + CALL ncio_read_bcast_serial (filename, 'lat_n', this%lat_n) + CALL ncio_read_bcast_serial (filename, 'lon_w', this%lon_w) + CALL ncio_read_bcast_serial (filename, 'lon_e', this%lon_e) + + this%nyblk = size(this%lat_s) + this%nxblk = size(this%lon_w) + + IF (this%nxblk < 1 .or. this%nyblk < 1 .or. size(this%lat_n) /= this%nyblk .or. & + size(this%lon_e) /= this%nxblk) THEN + CALL CoLM_stop('CoLM block.nc contains inconsistent block-boundary dimensions.') + ENDIF + IF (.not. all(ieee_is_finite(this%lat_s)) .or. .not. all(ieee_is_finite(this%lat_n)) .or. & + .not. all(ieee_is_finite(this%lon_w)) .or. .not. all(ieee_is_finite(this%lon_e))) THEN + CALL CoLM_stop('CoLM block.nc contains non-finite block boundaries.') + ENDIF + IF (any(this%lat_s < -90._r8) .or. any(this%lat_n > 90._r8) .or. & + any(this%lat_n <= this%lat_s)) THEN + CALL CoLM_stop('CoLM block.nc contains invalid latitude boundaries.') + ENDIF + IF (this%nyblk > 1) THEN + IF (any(this%lat_s(2:) <= this%lat_s(:this%nyblk-1))) & + CALL CoLM_stop('CoLM block.nc latitude blocks are not ordered south to north.') + ENDIF + + IF (mpas_is_root) THEN + write (*,*) 'Block information:' + write (*,'(I3,A,I3,A)') this%nxblk, ' blocks in longitude,', & + this%nyblk, ' blocks in latitude.' + write (*,*) + ENDIF + + IF (allocated(this%owner_rank)) deallocate(this%owner_rank) + allocate (this%owner_rank (this%nxblk,this%nyblk)) + this%owner_rank(:,:) = -1 + this%nblkme = 0 + + END SUBROUTINE block_load_from_file + + ! -------------------------------- + SUBROUTINE block_free_mem (this) + + IMPLICIT NONE + type (block_type) :: this + + IF (allocated (this%lat_s)) deallocate (this%lat_s) + IF (allocated (this%lat_n)) deallocate (this%lat_n) + IF (allocated (this%lon_w)) deallocate (this%lon_w) + IF (allocated (this%lon_e)) deallocate (this%lon_e) + + IF (allocated (this%owner_rank)) deallocate (this%owner_rank) + + IF (allocated (this%xblkme)) deallocate (this%xblkme) + IF (allocated (this%yblkme)) deallocate (this%yblkme) + + END SUBROUTINE block_free_mem + + ! ----- + SUBROUTINE get_blockname (iblk, jblk, blockname) + + IMPLICIT NONE + + integer, intent(in) :: iblk, jblk + + character(len=*), intent(out) :: blockname + + ! Local variables + character(len=4) :: cx + character(len=3) :: cy + IF (gblock%lat_s(jblk) < 0) THEN + write (cy, '(A1,I2.2)') 's', - floor(gblock%lat_s(jblk)) + ELSE + write (cy, '(A1,I2.2)') 'n', floor(gblock%lat_s(jblk)) + ENDIF + + IF (gblock%lon_w(iblk) < 0) THEN + write (cx, '(A1,I3.3)') 'w', - floor(gblock%lon_w(iblk)) + ELSE + write (cx, '(A1,I3.3)') 'e', floor(gblock%lon_w(iblk)) + ENDIF + + blockname = trim(cx) // '_' // trim(cy) + + END SUBROUTINE get_blockname + + ! -------------------------------- + SUBROUTINE get_filename_block (filename, iblk, jblk, fileblock) + + IMPLICIT NONE + + character(len=*), intent(in) :: filename + integer, intent(in) :: iblk, jblk + + character(len=*), intent(out) :: fileblock + + ! Local variables + character(len=8) :: blockname + integer :: i + + CALL get_blockname (iblk, jblk, blockname) + + i = len_trim (filename) + DO WHILE (i > 0) + IF (filename(i:i) == '.') EXIT + i = i - 1 + ENDDO + + IF (i > 0) THEN + fileblock = filename(1:i-1) // '_' // blockname // '.nc' + ELSE + fileblock = filename // '_' // blockname // '.nc' + ENDIF + + END SUBROUTINE get_filename_block + +END MODULE MOD_Block diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 new file mode 100644 index 0000000000..85750fb4b0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90 @@ -0,0 +1,1194 @@ +#include + +MODULE MOD_ComputePushData +!-------------------------------------------------------------------------------- +! DESCRIPTION: +!-------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Utils + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + ! -- Data Type : push data between ranks -- + type :: compute_pushdata_type + + integer :: num_req_uniq + + integer, allocatable :: addr_single (:) + + integer, allocatable :: addr_multi (:,:) + real(r8), allocatable :: area_multi (:,:) + real(r8), allocatable :: sum_area (:) + + ! data is on the same processor + integer :: nself + integer, allocatable :: self_from (:) + integer, allocatable :: self_to (:) +#ifdef MPAS_MPI + ! data is on other processors + integer, allocatable :: n_to_other (:) + integer, allocatable :: n_from_other (:) + type(pointer_int32_1d), allocatable :: to_other (:) + type(pointer_int32_1d), allocatable :: other_to (:) +#endif + CONTAINS + final :: compute_pushdata_free_mem + END type compute_pushdata_type + + + ! -- Data Type : remap data on ranks -- + type :: compute_remapdata_type + + integer :: num_grid + integer, allocatable :: ilon_me (:) + integer, allocatable :: ilat_me (:) + integer, allocatable :: ids_me (:) + + integer :: npset + real(r8), allocatable :: sum_area (:) + integer, allocatable :: npart (:) + type(pointer_int32_1d), allocatable :: part_to (:) ! + type(pointer_real8_1d), allocatable :: areapart (:) ! intersection area + + CONTAINS + final :: compute_remapdata_free_mem + END type compute_remapdata_type + + ! -- public subroutines -- + INTERFACE build_compute_pushdata + MODULE procedure build_compute_pushdata_single + MODULE procedure build_compute_pushdata_multi + END INTERFACE build_compute_pushdata + + PUBLIC :: build_compute_remapdata + + INTERFACE compute_push_data + MODULE procedure compute_push_data_single_real8 + MODULE procedure compute_push_data_single_int32 + MODULE procedure compute_push_data_multi_real8 + END INTERFACE compute_push_data + + INTERFACE compute_remap_data_pset2grid + MODULE procedure compute_remap_data_pset2grid_real8 + END INTERFACE compute_remap_data_pset2grid + + INTERFACE compute_remap_data_grid2pset + MODULE procedure compute_remap_data_grid2pset_real8 + END INTERFACE compute_remap_data_grid2pset + +CONTAINS + + ! ---------- + SUBROUTINE build_compute_pushdata_uniq (num_me, ids_me, n_req_uniq, ids_req_uniq, pushdata) + + IMPLICIT NONE + + integer, intent(in) :: num_me, ids_me (:) + integer, intent(in) :: n_req_uniq, ids_req_uniq (:) + type(compute_pushdata_type), intent(inout) :: pushdata + + ! Local Variables + integer, allocatable :: ids_me_sorted(:), order_ids(:), self_from(:) +#ifdef MPAS_MPI + integer, allocatable :: ids(:), loc_from_me(:), loc_from_other(:) + integer :: request(3) +#endif + integer :: i, iloc, irank, jrank, n_req_other + + + IF (.true.) THEN + + IF (num_me < 0 .or. num_me > size(ids_me)) THEN + CALL CoLM_stop('Invalid local ID count while building CoLM compute push data.') + ENDIF + IF (n_req_uniq < 0 .or. n_req_uniq > size(ids_req_uniq)) THEN + CALL CoLM_stop('Invalid request ID count while building CoLM compute push data.') + ENDIF + + allocate (ids_me_sorted (num_me)) + allocate (order_ids (num_me)) + IF (num_me > 0) THEN + ids_me_sorted = ids_me(1:num_me) + order_ids = (/(i, i = 1, num_me)/) + CALL quicksort (num_me, ids_me_sorted, order_ids) + IF (num_me > 1) THEN + IF (any(ids_me_sorted(2:num_me) == ids_me_sorted(1:num_me-1))) THEN + CALL CoLM_stop('Duplicate local source IDs while building CoLM compute push data.') + ENDIF + ENDIF + ENDIF + + pushdata%nself = 0 + + IF (n_req_uniq > 0) THEN + allocate (self_from (n_req_uniq)) + self_from(:) = -1 + + DO i = 1, n_req_uniq + iloc = find_in_sorted_list1 (ids_req_uniq(i), num_me, ids_me_sorted) + IF (iloc > 0) THEN + self_from(i) = order_ids(iloc) + ENDIF + ENDDO + + pushdata%nself = count(self_from > 0) + IF (pushdata%nself > 0) THEN + allocate (pushdata%self_from (pushdata%nself)) + allocate (pushdata%self_to (pushdata%nself)) + pushdata%self_from = pack(self_from, self_from > 0) + pushdata%self_to = pack((/(i,i=1,n_req_uniq)/), self_from > 0) + ENDIF + ENDIF + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push layout synchronization') + + allocate (pushdata%n_to_other (0:mpas_size-1)) + allocate (pushdata%to_other (0:mpas_size-1)) + + allocate (pushdata%n_from_other (0:mpas_size-1)) + allocate (pushdata%other_to (0:mpas_size-1)) + + pushdata%n_to_other (:) = 0 + pushdata%n_from_other(:) = 0 + + IF (n_req_uniq > 0) allocate (loc_from_other (n_req_uniq)) + + irank = modulo(mpas_rank+1, mpas_size) + jrank = modulo(mpas_rank-1, mpas_size) + DO WHILE (irank /= mpas_rank) + + CALL mpi_isend (n_req_uniq, 1, MPI_INTEGER, jrank, 10, & + mpas_comm, request(1), mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-count send') + + IF (n_req_uniq > 0) THEN + CALL mpi_isend(ids_req_uniq, n_req_uniq, MPI_INTEGER, jrank, 11, & + mpas_comm, request(2), mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-ID send') + ENDIF + + CALL mpi_recv (n_req_other, 1, MPI_INTEGER, irank, 10, & + mpas_comm, mpas_status, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-count receive') + + IF (n_req_other > 0) THEN + + allocate (ids (n_req_other)) + CALL mpi_recv (ids, n_req_other, MPI_INTEGER, irank, 11, & + mpas_comm, mpas_status, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-ID receive') + + allocate (loc_from_me (n_req_other)) + loc_from_me(:) = -1 + + IF (num_me > 0) THEN + DO i = 1, n_req_other + iloc = find_in_sorted_list1 (ids(i), num_me, ids_me_sorted) + IF (iloc > 0) THEN + loc_from_me(i) = order_ids(iloc) + ENDIF + ENDDO + ENDIF + + pushdata%n_to_other(irank) = count(loc_from_me > 0) + IF (pushdata%n_to_other(irank) > 0) THEN + allocate (pushdata%to_other(irank)%val (pushdata%n_to_other(irank))) + pushdata%to_other(irank)%val = pack(loc_from_me, loc_from_me > 0) + ENDIF + + CALL mpi_isend (loc_from_me, n_req_other, MPI_INTEGER, irank, 12, & + mpas_comm, request(3), mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push source-location send') + + ENDIF + + IF (n_req_uniq > 0) THEN + + CALL mpi_recv (loc_from_other, n_req_uniq, MPI_INTEGER, & + jrank, 12, mpas_comm, mpas_status, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push source-location receive') + + pushdata%n_from_other(jrank) = count(loc_from_other > 0) + IF (pushdata%n_from_other(jrank) > 0) THEN + allocate (pushdata%other_to(jrank)%val (pushdata%n_from_other(jrank))) + pushdata%other_to(jrank)%val = pack((/(i,i=1,n_req_uniq)/), loc_from_other > 0) + ENDIF + + ENDIF + + CALL mpi_wait(request(1), MPI_STATUS_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-count send completion') + IF (n_req_uniq > 0) THEN + CALL mpi_wait(request(2), MPI_STATUS_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push request-ID send completion') + ENDIF + IF (n_req_other > 0) THEN + CALL mpi_wait(request(3), MPI_STATUS_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push source-location send completion') + ENDIF + + IF (allocated(ids )) deallocate(ids ) + IF (allocated(loc_from_me)) deallocate(loc_from_me) + + irank = modulo(irank+1, mpas_size) + jrank = modulo(jrank-1, mpas_size) + ENDDO + + IF (allocated (loc_from_other)) deallocate (loc_from_other) + + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('compute-push layout completion') +#endif + + IF (allocated(ids_me_sorted)) deallocate(ids_me_sorted) + IF (allocated(order_ids )) deallocate(order_ids ) + IF (allocated(self_from )) deallocate(self_from ) + + ENDIF + + END SUBROUTINE build_compute_pushdata_uniq + + ! ---------- + SUBROUTINE build_compute_pushdata_single (num_me, ids_me, num_req, ids_req, pushdata) + + IMPLICIT NONE + + integer, intent(in) :: num_me, ids_me (:) + integer, intent(in) :: num_req, ids_req (:) + type(compute_pushdata_type), intent(inout) :: pushdata + + ! Local Variables + integer :: n_req_uniq, iloc, i + integer, allocatable :: ids_req_uniq (:) + + IF (.true.) THEN + + IF (num_me < 0 .or. num_me > size(ids_me)) THEN + CALL CoLM_stop('Invalid local ID count while building single CoLM compute push data.') + ENDIF + IF (num_req < 0 .or. num_req > size(ids_req)) THEN + CALL CoLM_stop('Invalid request count while building single CoLM compute push data.') + ENDIF + + n_req_uniq = 0 + + allocate (ids_req_uniq (num_req)) + IF (num_req > 0) THEN + DO i = 1, num_req + CALL insert_into_sorted_list1 (ids_req(i), n_req_uniq, ids_req_uniq, iloc) + ENDDO + + allocate (pushdata%addr_single (num_req)) + DO i = 1, num_req + pushdata%addr_single(i) = & + find_in_sorted_list1 (ids_req(i), n_req_uniq, ids_req_uniq(1:n_req_uniq)) + ENDDO + ENDIF + + pushdata%num_req_uniq = n_req_uniq + + CALL build_compute_pushdata_uniq ( & + num_me, ids_me, n_req_uniq, ids_req_uniq(1:n_req_uniq), pushdata) + + IF (allocated (ids_req_uniq)) deallocate(ids_req_uniq) + + ENDIF + + END SUBROUTINE build_compute_pushdata_single + + ! ---------- + SUBROUTINE build_compute_pushdata_multi ( & + num_me, ids_me, num_req, ids_req, area_req, pushdata) + + IMPLICIT NONE + + integer, intent(in) :: num_me, ids_me (:) + integer, intent(in) :: num_req, ids_req (:,:) + real(r8), intent(in) :: area_req(:,:) + type(compute_pushdata_type), intent(inout) :: pushdata + + ! Local Variables + integer :: ndim1, n_req_uniq, iloc, i, j, irank + integer, allocatable :: ids_req_uniq (:) + logical, allocatable :: id_found (:) + + IF (.true.) THEN + + IF (num_me < 0 .or. num_me > size(ids_me)) THEN + CALL CoLM_stop('Invalid local ID count while building multi CoLM compute push data.') + ENDIF + IF (num_req < 0 .or. num_req > size(ids_req, 2) .or. num_req > size(area_req, 2)) THEN + CALL CoLM_stop('Invalid request count while building multi CoLM compute push data.') + ENDIF + IF (size(area_req, 1) /= size(ids_req, 1)) THEN + CALL CoLM_stop('ID and area shapes differ while building multi CoLM compute push data.') + ENDIF + IF (num_req > 0) THEN + IF (.not. all(ieee_is_finite(area_req(:,1:num_req)))) THEN + CALL CoLM_stop('Non-finite overlap area while building multi CoLM compute push data.') + ENDIF + ENDIF + + n_req_uniq = 0 + + ndim1 = size(ids_req,1) + allocate (ids_req_uniq (ndim1*num_req)) + + IF (num_req > 0) THEN + + DO j = 1, num_req + DO i = 1, ndim1 + CALL insert_into_sorted_list1 (ids_req(i,j), n_req_uniq, ids_req_uniq, iloc) + ENDDO + ENDDO + + allocate (pushdata%addr_multi (ndim1,num_req)) + + DO j = 1, num_req + DO i = 1, ndim1 + pushdata%addr_multi(i,j) = & + find_in_sorted_list1 (ids_req(i,j), n_req_uniq, ids_req_uniq(1:n_req_uniq)) + ENDDO + ENDDO + ENDIF + + pushdata%num_req_uniq = n_req_uniq + + CALL build_compute_pushdata_uniq ( & + num_me, ids_me, n_req_uniq, ids_req_uniq(1:n_req_uniq), pushdata) + + IF (num_req > 0) THEN + allocate (pushdata%area_multi (ndim1,num_req)) + allocate (pushdata%sum_area (num_req)) + + pushdata%area_multi = area_req(:,1:num_req) + + WHERE ((pushdata%area_multi <= 0.) .or. (ids_req(:,1:num_req) <= 0)) + pushdata%area_multi = 0. + END WHERE + + allocate (id_found (n_req_uniq)) + id_found(:) = .false. + + IF (pushdata%nself > 0) id_found(pushdata%self_to) = .true. +#ifdef MPAS_MPI + DO irank = 0, mpas_size-1 + IF (pushdata%n_from_other(irank) > 0) THEN + id_found(pushdata%other_to(irank)%val) = .true. + ENDIF + ENDDO +#endif + + DO j = 1, num_req + DO i = 1, ndim1 + IF (.not. id_found(pushdata%addr_multi(i,j))) then + pushdata%area_multi(i,j) = 0. + ENDIF + ENDDO + ENDDO + + pushdata%sum_area = sum(pushdata%area_multi, dim = 1) + + deallocate (id_found) + ENDIF + + IF (allocated (ids_req_uniq)) deallocate(ids_req_uniq) + + ENDIF + + END SUBROUTINE build_compute_pushdata_multi + + ! ---------- + + ! ---------- + SUBROUTINE build_compute_remapdata (pixelset, grid, remapdata) + + USE MOD_Grid + USE MOD_Pixelset + USE MOD_SpatialMapping + IMPLICIT NONE + + type(pixelset_type), intent(in) :: pixelset + type(grid_type), intent(in) :: grid + + type(compute_remapdata_type), intent(inout) :: remapdata + + ! Local Variables + type(spatial_mapping_type) :: mapping + integer, allocatable :: ilon_me(:), ilat_me(:) + integer :: ngrid, iproc, ig, iloc, iset, ipart + + + CALL mapping%build_arealweighted (grid, pixelset) + + IF (.true.) THEN + + ngrid = 0 + DO iproc = 0, mpas_size-1 + ngrid = ngrid + mapping%glist(iproc)%ng + ENDDO + + IF (ngrid > 0) THEN + allocate (ilon_me (ngrid)) + allocate (ilat_me (ngrid)) + ENDIF + + ngrid = 0 + DO iproc = 0, mpas_size-1 + DO ig = 1, mapping%glist(iproc)%ng + CALL insert_into_sorted_list2 ( & + mapping%glist(iproc)%ilon(ig), mapping%glist(iproc)%ilat(ig), & + ngrid, ilon_me, ilat_me, iloc) + ENDDO + ENDDO + + remapdata%num_grid = ngrid + + IF (ngrid > 0) THEN + allocate (remapdata%ilon_me (ngrid)) + allocate (remapdata%ilat_me (ngrid)) + allocate (remapdata%ids_me (ngrid)) + remapdata%ilon_me = ilon_me(1:ngrid) + remapdata%ilat_me = ilat_me(1:ngrid) + remapdata%ids_me = (ilat_me(1:ngrid)-1) * grid%nlon + ilon_me(1:ngrid) + ENDIF + + remapdata%npset = mapping%npset + + IF (remapdata%npset < 0) THEN + CALL CoLM_stop('Negative pixel-set count while building CoLM compute remap data.') + ENDIF + + IF (remapdata%npset > 0) THEN + + IF (.not. allocated(mapping%npart) .or. .not. allocated(mapping%address) .or. & + .not. allocated(mapping%areapart) .or. .not. allocated(mapping%glist)) THEN + CALL CoLM_stop('Incomplete spatial mapping while building CoLM compute remap data.') + ENDIF + IF (size(mapping%npart) < remapdata%npset .or. & + size(mapping%address) < remapdata%npset .or. & + size(mapping%areapart) < remapdata%npset) THEN + CALL CoLM_stop('Spatial mapping count mismatch while building CoLM compute remap data.') + ENDIF + + allocate (remapdata%sum_area (remapdata%npset)) + allocate (remapdata%npart (remapdata%npset)) + allocate (remapdata%part_to (remapdata%npset)) + allocate (remapdata%areapart (remapdata%npset)) + + remapdata%npart = mapping%npart + remapdata%sum_area = 0._r8 + + IF (any(remapdata%npart < 0)) THEN + CALL CoLM_stop('Negative part count while building CoLM compute remap data.') + ENDIF + + DO iset = 1, remapdata%npset + IF (remapdata%npart(iset) > 0) THEN + IF (.not. allocated(mapping%address(iset)%val) .or. & + .not. allocated(mapping%areapart(iset)%val)) THEN + CALL CoLM_stop('Incomplete spatial mapping while building CoLM compute remap data.') + ENDIF + IF (size(mapping%address(iset)%val,1) < 2 .or. & + size(mapping%address(iset)%val,2) < remapdata%npart(iset) .or. & + size(mapping%areapart(iset)%val) < remapdata%npart(iset)) THEN + CALL CoLM_stop('Spatial mapping shape mismatch while building CoLM compute remap data.') + ENDIF + allocate (remapdata%part_to(iset)%val (remapdata%npart(iset))) + allocate (remapdata%areapart(iset)%val (remapdata%npart(iset))) + ENDIF + + DO ipart = 1, remapdata%npart(iset) + iproc = mapping%address(iset)%val(1,ipart) + iloc = mapping%address(iset)%val(2,ipart) + IF (iproc < lbound(mapping%glist,1) .or. iproc > ubound(mapping%glist,1)) THEN + CALL CoLM_stop('Spatial mapping rank is outside the CoLM active communicator.') + ENDIF + IF (.not. allocated(mapping%glist(iproc)%ilon) .or. & + .not. allocated(mapping%glist(iproc)%ilat)) THEN + CALL CoLM_stop('Spatial mapping grid list is incomplete.') + ENDIF + IF (iloc < 1 .or. iloc > mapping%glist(iproc)%ng .or. & + iloc > size(mapping%glist(iproc)%ilon) .or. & + iloc > size(mapping%glist(iproc)%ilat)) THEN + CALL CoLM_stop('Spatial mapping address is outside the local CoLM grid list.') + ENDIF + remapdata%part_to(iset)%val(ipart) = find_in_sorted_list2 ( & + mapping%glist(iproc)%ilon(iloc), mapping%glist(iproc)%ilat(iloc), ngrid, ilon_me, ilat_me) + IF (remapdata%part_to(iset)%val(ipart) <= 0) THEN + CALL CoLM_stop('Spatial mapping target is missing from the local CoLM remap grid.') + ENDIF + ! from km^2 to m^2 + remapdata%areapart(iset)%val(ipart) = mapping%areapart(iset)%val(ipart) * 1.e6_r8 + IF (.not. ieee_is_finite(remapdata%areapart(iset)%val(ipart)) .or. & + remapdata%areapart(iset)%val(ipart) <= 0._r8) THEN + CALL CoLM_stop('Invalid overlap area while building CoLM compute remap data.') + ENDIF + ENDDO + + IF (remapdata%npart(iset) > 0) THEN + remapdata%sum_area(iset) = sum(remapdata%areapart(iset)%val) + IF (.not. ieee_is_finite(remapdata%sum_area(iset)) .or. & + remapdata%sum_area(iset) <= 0._r8) THEN + CALL CoLM_stop('Invalid total area while building CoLM compute remap data.') + ENDIF + ENDIF + ENDDO + ENDIF + + IF (allocated(ilon_me)) deallocate(ilon_me) + IF (allocated(ilat_me)) deallocate(ilat_me) + + ENDIF + + END SUBROUTINE build_compute_remapdata + + ! ---------- + SUBROUTINE validate_compute_push_layout (pushdata, send_size, recv_size) + + IMPLICIT NONE + + type(compute_pushdata_type), intent(in) :: pushdata + integer, intent(in) :: send_size, recv_size + + integer :: irank + + IF (send_size < 0 .or. recv_size < 0 .or. pushdata%num_req_uniq < 0 .or. & + pushdata%num_req_uniq > recv_size .or. pushdata%nself < 0) THEN + CALL CoLM_stop('Invalid dimensions in CoLM compute push layout.') + ENDIF + + IF (pushdata%nself > 0) THEN + IF (.not. allocated(pushdata%self_from) .or. .not. allocated(pushdata%self_to)) THEN + CALL CoLM_stop('Incomplete self-address vectors in CoLM compute push layout.') + ENDIF + IF (size(pushdata%self_from) < pushdata%nself .or. size(pushdata%self_to) < pushdata%nself) THEN + CALL CoLM_stop('Short self-address vectors in CoLM compute push layout.') + ENDIF + IF (any(pushdata%self_from(1:pushdata%nself) < 1) .or. & + any(pushdata%self_from(1:pushdata%nself) > send_size) .or. & + any(pushdata%self_to(1:pushdata%nself) < 1) .or. & + any(pushdata%self_to(1:pushdata%nself) > recv_size)) THEN + CALL CoLM_stop('Out-of-range self address in CoLM compute push layout.') + ENDIF + ENDIF + +#ifdef MPAS_MPI + IF (.not. allocated(pushdata%n_to_other) .or. .not. allocated(pushdata%n_from_other) .or. & + .not. allocated(pushdata%to_other) .or. .not. allocated(pushdata%other_to)) THEN + CALL CoLM_stop('Incomplete remote-address tables in CoLM compute push layout.') + ENDIF + IF (lbound(pushdata%n_to_other,1) > 0 .or. ubound(pushdata%n_to_other,1) < mpas_size-1 .or. & + lbound(pushdata%n_from_other,1) > 0 .or. ubound(pushdata%n_from_other,1) < mpas_size-1 .or. & + lbound(pushdata%to_other,1) > 0 .or. ubound(pushdata%to_other,1) < mpas_size-1 .or. & + lbound(pushdata%other_to,1) > 0 .or. ubound(pushdata%other_to,1) < mpas_size-1) THEN + CALL CoLM_stop('Remote-address table bounds do not match the CoLM compute communicator.') + ENDIF + IF (any(pushdata%n_to_other(0:mpas_size-1) < 0) .or. & + any(pushdata%n_from_other(0:mpas_size-1) < 0)) THEN + CALL CoLM_stop('Negative remote message count in CoLM compute push layout.') + ENDIF + + DO irank = 0, mpas_size-1 + IF (pushdata%n_to_other(irank) > 0) THEN + IF (.not. allocated(pushdata%to_other(irank)%val)) THEN + CALL CoLM_stop('Missing remote send addresses in CoLM compute push layout.') + ENDIF + IF (size(pushdata%to_other(irank)%val) < pushdata%n_to_other(irank) .or. & + any(pushdata%to_other(irank)%val(1:pushdata%n_to_other(irank)) < 1) .or. & + any(pushdata%to_other(irank)%val(1:pushdata%n_to_other(irank)) > send_size)) THEN + CALL CoLM_stop('Out-of-range remote send address in CoLM compute push layout.') + ENDIF + ENDIF + IF (pushdata%n_from_other(irank) > 0) THEN + IF (.not. allocated(pushdata%other_to(irank)%val)) THEN + CALL CoLM_stop('Missing remote receive addresses in CoLM compute push layout.') + ENDIF + IF (size(pushdata%other_to(irank)%val) < pushdata%n_from_other(irank) .or. & + any(pushdata%other_to(irank)%val(1:pushdata%n_from_other(irank)) < 1) .or. & + any(pushdata%other_to(irank)%val(1:pushdata%n_from_other(irank)) > recv_size)) THEN + CALL CoLM_stop('Out-of-range remote receive address in CoLM compute push layout.') + ENDIF + ENDIF + ENDDO +#endif + + END SUBROUTINE validate_compute_push_layout + + ! ---------- + SUBROUTINE compute_push_data_uniq_real8 ( & + pushdata, vec_send, vec_recv, fillvalue) + + IMPLICIT NONE + + type(compute_pushdata_type), intent(in) :: pushdata + + real(r8), intent(in) , optional :: vec_send (:) + real(r8), intent(inout), optional :: vec_recv (:) + real(r8), intent(in) , optional :: fillvalue + + ! Local Variables + integer :: ndatasend + integer, allocatable :: req_send (:) + real(r8), allocatable :: sendcache (:) + + integer :: ndatarecv + integer, allocatable :: req_recv (:) + real(r8), allocatable :: recvcache (:) + + integer :: irank, iproc, idsp, istt, iend, i, i_to + + + IF (.true.) THEN + + IF (.not. present(vec_send) .or. .not. present(vec_recv) .or. .not. present(fillvalue)) THEN + CALL CoLM_stop('CoLM real compute push requires send, receive, and fill-value arguments.') + ENDIF + CALL validate_compute_push_layout(pushdata, size(vec_send), size(vec_recv)) + + IF (pushdata%num_req_uniq > 0) THEN + vec_recv = fillvalue + ENDIF + + IF (pushdata%nself > 0) THEN + vec_recv(pushdata%self_to) = vec_send(pushdata%self_from) + ENDIF + +#ifdef MPAS_MPI + ndatasend = sum(pushdata%n_to_other) + IF (ndatasend > 0) THEN + + allocate (sendcache(ndatasend)) + allocate (req_send (count(pushdata%n_to_other > 0))) + + iproc = 0 + idsp = 0 + DO irank = 0, mpas_size-1 + IF (pushdata%n_to_other(irank) > 0) THEN + iproc = iproc + 1 + istt = idsp + 1 + iend = idsp + pushdata%n_to_other(irank) + + sendcache(istt:iend) = vec_send(pushdata%to_other(irank)%val) + CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(irank), MPI_REAL8, & + irank, 101, mpas_comm, req_send(iproc), mpas_mpi_ierr) + CALL mpas_mpi_check('real compute-push data send') + + idsp = iend + ENDIF + ENDDO + ENDIF + + ndatarecv = sum(pushdata%n_from_other) + IF (ndatarecv > 0) THEN + + allocate (recvcache(ndatarecv)) + allocate (req_recv (count(pushdata%n_from_other > 0))) + + iproc = 0 + idsp = 0 + DO irank = 0, mpas_size-1 + IF (pushdata%n_from_other(irank) > 0) THEN + iproc = iproc + 1 + istt = idsp + 1 + iend = idsp + pushdata%n_from_other(irank) + + CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(irank), MPI_REAL8, & + irank, 101, mpas_comm, req_recv(iproc), mpas_mpi_ierr) + CALL mpas_mpi_check('real compute-push data receive') + + idsp = iend + ENDIF + ENDDO + ENDIF + + IF (ndatarecv > 0) THEN + + CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('real compute-push receive completion') + + idsp = 0 + DO irank = 0, mpas_size-1 + DO i = 1, pushdata%n_from_other(irank) + + IF (recvcache(idsp+i) /= fillvalue) THEN + i_to = pushdata%other_to(irank)%val(i) + IF (vec_recv(i_to) == fillvalue) THEN + vec_recv(i_to) = recvcache(idsp+i) + ELSE + vec_recv(i_to) = vec_recv(i_to) + recvcache(idsp+i) + ENDIF + ENDIF + + ENDDO + idsp = idsp + pushdata%n_from_other(irank) + ENDDO + + ENDIF + + IF (ndatasend > 0) THEN + CALL mpi_waitall(size(req_send), req_send, MPI_STATUSES_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('real compute-push send completion') + ENDIF + + IF (allocated(req_send )) deallocate(req_send ) + IF (allocated(sendcache)) deallocate(sendcache) + IF (allocated(req_recv )) deallocate(req_recv ) + IF (allocated(recvcache)) deallocate(recvcache) +#endif + + ENDIF + + END SUBROUTINE compute_push_data_uniq_real8 + + ! ---------- + SUBROUTINE compute_push_data_uniq_int32 ( & + pushdata, vec_send, vec_recv, fillvalue) + + IMPLICIT NONE + + type(compute_pushdata_type), intent(in) :: pushdata + + integer, intent(in) , optional :: vec_send (:) + integer, intent(inout), optional :: vec_recv (:) + integer, intent(in) , optional :: fillvalue + + ! Local Variables + integer :: ndatasend + integer, allocatable :: req_send (:) + integer, allocatable :: sendcache (:) + + integer :: ndatarecv + integer, allocatable :: req_recv (:) + integer, allocatable :: recvcache (:) + + integer :: irank, iproc, idsp, istt, iend, i, i_to + + + IF (.true.) THEN + + IF (.not. present(vec_send) .or. .not. present(vec_recv) .or. .not. present(fillvalue)) THEN + CALL CoLM_stop('CoLM integer compute push requires send, receive, and fill-value arguments.') + ENDIF + CALL validate_compute_push_layout(pushdata, size(vec_send), size(vec_recv)) + + IF (pushdata%num_req_uniq > 0) THEN + vec_recv = fillvalue + ENDIF + + IF (pushdata%nself > 0) THEN + vec_recv(pushdata%self_to) = vec_send(pushdata%self_from) + ENDIF + +#ifdef MPAS_MPI + ndatasend = sum(pushdata%n_to_other) + IF (ndatasend > 0) THEN + + allocate (sendcache(ndatasend)) + allocate (req_send (count(pushdata%n_to_other > 0))) + + iproc = 0 + idsp = 0 + DO irank = 0, mpas_size-1 + IF (pushdata%n_to_other(irank) > 0) THEN + iproc = iproc + 1 + istt = idsp + 1 + iend = idsp + pushdata%n_to_other(irank) + + sendcache(istt:iend) = vec_send(pushdata%to_other(irank)%val) + CALL mpi_isend(sendcache(istt:iend), pushdata%n_to_other(irank), MPI_INTEGER, & + irank, 101, mpas_comm, req_send(iproc), mpas_mpi_ierr) + CALL mpas_mpi_check('integer compute-push data send') + + idsp = iend + ENDIF + ENDDO + ENDIF + + ndatarecv = sum(pushdata%n_from_other) + IF (ndatarecv > 0) THEN + + allocate (recvcache(ndatarecv)) + allocate (req_recv (count(pushdata%n_from_other > 0))) + + iproc = 0 + idsp = 0 + DO irank = 0, mpas_size-1 + IF (pushdata%n_from_other(irank) > 0) THEN + iproc = iproc + 1 + istt = idsp + 1 + iend = idsp + pushdata%n_from_other(irank) + + CALL mpi_irecv(recvcache(istt:iend), pushdata%n_from_other(irank), MPI_INTEGER, & + irank, 101, mpas_comm, req_recv(iproc), mpas_mpi_ierr) + CALL mpas_mpi_check('integer compute-push data receive') + + idsp = iend + ENDIF + ENDDO + ENDIF + + IF (ndatarecv > 0) THEN + + CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('integer compute-push receive completion') + + idsp = 0 + DO irank = 0, mpas_size-1 + DO i = 1, pushdata%n_from_other(irank) + + IF (recvcache(idsp+i) /= fillvalue) THEN + i_to = pushdata%other_to(irank)%val(i) + IF (vec_recv(i_to) == fillvalue) THEN + vec_recv(i_to) = recvcache(idsp+i) + ELSE + vec_recv(i_to) = vec_recv(i_to) + recvcache(idsp+i) + ENDIF + ENDIF + + ENDDO + idsp = idsp + pushdata%n_from_other(irank) + ENDDO + + ENDIF + + IF (ndatasend > 0) THEN + CALL mpi_waitall(size(req_send), req_send, MPI_STATUSES_IGNORE, mpas_mpi_ierr) + CALL mpas_mpi_check('integer compute-push send completion') + ENDIF + + IF (allocated(req_send )) deallocate(req_send ) + IF (allocated(sendcache)) deallocate(sendcache) + IF (allocated(req_recv )) deallocate(req_recv ) + IF (allocated(recvcache)) deallocate(recvcache) +#endif + + ENDIF + + END SUBROUTINE compute_push_data_uniq_int32 + + ! ---------- + SUBROUTINE compute_push_data_single_real8 (pushdata, vec_send, vec_recv, fillvalue) + + IMPLICIT NONE + + type(compute_pushdata_type) :: pushdata + + real(r8), intent(in) :: vec_send (:) + real(r8), intent(inout) :: vec_recv (:) + real(r8), intent(in) :: fillvalue + + ! Local Variables + real(r8), allocatable :: vec_recv_uniq (:) + + IF (.true.) THEN + + IF (size(vec_recv) > 0) vec_recv = fillvalue + IF (allocated(pushdata%addr_single)) THEN + IF (size(vec_recv) < size(pushdata%addr_single)) THEN + CALL CoLM_stop('Receive array is too small for single CoLM compute push data.') + ENDIF + ELSEIF (pushdata%num_req_uniq > 0) THEN + CALL CoLM_stop('Single CoLM compute push data has no request-address map.') + ENDIF + + ! Always allocate (zero-length if no requests) to avoid passing + ! unallocated array to compute_push_data_uniq_real8. + allocate (vec_recv_uniq (pushdata%num_req_uniq)) + IF (pushdata%num_req_uniq > 0) THEN + vec_recv_uniq(:) = fillvalue + ENDIF + + CALL compute_push_data_uniq_real8 (pushdata, vec_send, vec_recv_uniq, fillvalue) + + IF (pushdata%num_req_uniq > 0 .and. allocated(pushdata%addr_single)) THEN + vec_recv(1:size(pushdata%addr_single)) = vec_recv_uniq(pushdata%addr_single) + ENDIF + deallocate (vec_recv_uniq) + + ENDIF + + END SUBROUTINE compute_push_data_single_real8 + + ! ---------- + SUBROUTINE compute_push_data_multi_real8 (pushdata, vec_send, vec_recv, fillvalue, mode) + + IMPLICIT NONE + + type(compute_pushdata_type) :: pushdata + + real(r8), intent(in) :: vec_send (:) + real(r8), intent(inout) :: vec_recv (:) + real(r8), intent(in) :: fillvalue + + character(len=*), intent(in) :: mode + + ! Local Variables + real(r8), allocatable :: vec_recv_uniq (:) + integer :: i, j + real(r8) :: val, sumarea + + IF (.true.) THEN + + IF (trim(mode) /= 'sum' .and. trim(mode) /= 'average') THEN + CALL CoLM_stop('CoLM multi compute push mode must be sum or average.') + ENDIF + IF (size(vec_recv) > 0) vec_recv = fillvalue + IF (allocated(pushdata%addr_multi)) THEN + IF (size(vec_recv) < size(pushdata%addr_multi, 2)) THEN + CALL CoLM_stop('Receive array is too small for multi CoLM compute push data.') + ENDIF + ELSEIF (pushdata%num_req_uniq > 0) THEN + CALL CoLM_stop('Multi CoLM compute push data has no request-address map.') + ENDIF + + ! Always allocate (zero-length if no requests) to avoid passing + ! unallocated array to compute_push_data_uniq_real8. + allocate (vec_recv_uniq (pushdata%num_req_uniq)) + IF (pushdata%num_req_uniq > 0) THEN + vec_recv_uniq(:) = fillvalue + ENDIF + + CALL compute_push_data_uniq_real8 (pushdata, vec_send, vec_recv_uniq, fillvalue) + + IF (pushdata%num_req_uniq > 0) THEN + + DO j = 1, size(pushdata%addr_multi,2) + + sumarea = 0. + + DO i = 1, size(pushdata%addr_multi,1) + val = vec_recv_uniq(pushdata%addr_multi(i,j)) + IF (val /= fillvalue) THEN + IF (vec_recv(j) == fillvalue) THEN + vec_recv(j) = val * pushdata%area_multi(i,j) + ELSE + vec_recv(j) = vec_recv(j) + val * pushdata%area_multi(i,j) + ENDIF + sumarea = sumarea + pushdata%area_multi(i,j) + ENDIF + ENDDO + + IF (trim(mode) == 'average') THEN + IF (vec_recv(j) /= fillvalue) THEN + IF (sumarea > 0._r8) THEN + vec_recv(j) = vec_recv(j) / sumarea + ELSE + vec_recv(j) = fillvalue + ENDIF + ENDIF + ENDIF + ENDDO + + ENDIF + deallocate (vec_recv_uniq) + + ENDIF + + END SUBROUTINE compute_push_data_multi_real8 + + ! ---------- + SUBROUTINE compute_push_data_single_int32 (pushdata, vec_send, vec_recv, fillvalue) + + IMPLICIT NONE + + type(compute_pushdata_type) :: pushdata + + integer, intent(in) :: vec_send (:) + integer, intent(inout) :: vec_recv (:) + integer, intent(in) :: fillvalue + + ! Local Variables + integer, allocatable :: vec_recv_uniq (:) + + IF (.true.) THEN + + IF (size(vec_recv) > 0) vec_recv = fillvalue + IF (allocated(pushdata%addr_single)) THEN + IF (size(vec_recv) < size(pushdata%addr_single)) THEN + CALL CoLM_stop('Receive array is too small for integer CoLM compute push data.') + ENDIF + ELSEIF (pushdata%num_req_uniq > 0) THEN + CALL CoLM_stop('Integer CoLM compute push data has no request-address map.') + ENDIF + + allocate (vec_recv_uniq (pushdata%num_req_uniq)) + IF (pushdata%num_req_uniq > 0) THEN + vec_recv_uniq(:) = fillvalue + ENDIF + + CALL compute_push_data_uniq_int32 (pushdata, vec_send, vec_recv_uniq, fillvalue) + + IF (pushdata%num_req_uniq > 0 .and. allocated(pushdata%addr_single)) THEN + vec_recv(1:size(pushdata%addr_single)) = vec_recv_uniq(pushdata%addr_single) + ENDIF + deallocate (vec_recv_uniq) + + ENDIF + + END SUBROUTINE compute_push_data_single_int32 + + ! --------- + SUBROUTINE compute_remap_data_pset2grid_real8 (remapdata, vec_in, vec_out, fillvalue, filter) + + IMPLICIT NONE + + type(compute_remapdata_type), intent(in) :: remapdata + + real(r8), intent(in) :: vec_in (:) + real(r8), intent(inout) :: vec_out(:) + real(r8), intent(in) :: fillvalue + logical, intent(in) :: filter (:) + + ! Local Variables + integer :: iset, ipart, iloc + real(r8) :: area + + + IF (.true.) THEN + IF (size(vec_in) < remapdata%npset .or. size(filter) < remapdata%npset) THEN + CALL CoLM_stop('Pixel-set input is too small for CoLM compute remap data.') + ENDIF + IF (size(vec_out) < remapdata%num_grid) THEN + CALL CoLM_stop('Grid output is too small for CoLM compute remap data.') + ENDIF + IF (remapdata%num_grid > 0) THEN + + vec_out(:) = fillvalue + + DO iset = 1, remapdata%npset + IF (filter(iset) .and. (vec_in(iset) /= fillvalue)) THEN + DO ipart = 1, remapdata%npart(iset) + + iloc = remapdata%part_to(iset)%val(ipart) + area = remapdata%areapart(iset)%val(ipart) + IF (iloc < 1 .or. iloc > remapdata%num_grid) THEN + CALL CoLM_stop('Pixel-set to grid remap contains an invalid target address.') + ENDIF + + IF (vec_out(iloc) == fillvalue) THEN + vec_out(iloc) = vec_in(iset) * area + ELSE + vec_out(iloc) = vec_out(iloc) + vec_in(iset) * area + ENDIF + + ENDDO + ENDIF + ENDDO + + ENDIF + ENDIF + + END SUBROUTINE compute_remap_data_pset2grid_real8 + + ! --------- + SUBROUTINE compute_remap_data_grid2pset_real8 (remapdata, vec_in, vec_out, fillvalue, mode) + + IMPLICIT NONE + + type(compute_remapdata_type), intent(in) :: remapdata + + real(r8), intent(in) :: vec_in (:) + real(r8), intent(inout) :: vec_out(:) + real(r8), intent(in) :: fillvalue + + character(len=*), intent(in) :: mode + + ! Local Variables + integer :: iset, ipart, iloc + real(r8) :: area, sumarea + + IF (.true.) THEN + IF (trim(mode) /= 'sum' .and. trim(mode) /= 'average') THEN + CALL CoLM_stop('CoLM compute remap mode must be sum or average.') + ENDIF + IF (size(vec_in) < remapdata%num_grid) THEN + CALL CoLM_stop('Grid input is too small for CoLM compute remap data.') + ENDIF + IF (size(vec_out) < remapdata%npset) THEN + CALL CoLM_stop('Pixel-set output is too small for CoLM compute remap data.') + ENDIF + IF (remapdata%npset > 0) THEN + + vec_out(:) = fillvalue + + DO iset = 1, remapdata%npset + + sumarea = 0. + + DO ipart = 1, remapdata%npart(iset) + iloc = remapdata%part_to(iset)%val(ipart) + area = remapdata%areapart(iset)%val(ipart) + IF (iloc < 1 .or. iloc > remapdata%num_grid) THEN + CALL CoLM_stop('Grid to pixel-set remap contains an invalid source address.') + ENDIF + + IF (vec_in(iloc) /= fillvalue) THEN + IF (vec_out(iset) == fillvalue) THEN + vec_out(iset) = vec_in(iloc) * area + ELSE + vec_out(iset) = vec_out(iset) + vec_in(iloc) * area + ENDIF + sumarea = sumarea + area + ENDIF + ENDDO + + IF (trim(mode) == 'average') THEN + IF (vec_out(iset) /= fillvalue) THEN + IF (sumarea > 0._r8 .and. ieee_is_finite(sumarea)) THEN + vec_out(iset) = vec_out(iset) / sumarea + ELSE + vec_out(iset) = fillvalue + ENDIF + ENDIF + ENDIF + ENDDO + + ENDIF + ENDIF + + END SUBROUTINE compute_remap_data_grid2pset_real8 + + ! --------- + SUBROUTINE compute_pushdata_free_mem (this) + + IMPLICIT NONE + type(compute_pushdata_type) :: this + + IF (allocated(this%addr_single )) deallocate(this%addr_single ) + IF (allocated(this%addr_multi )) deallocate(this%addr_multi ) + IF (allocated(this%area_multi )) deallocate(this%area_multi ) + IF (allocated(this%sum_area )) deallocate(this%sum_area ) + IF (allocated(this%self_from )) deallocate(this%self_from ) + IF (allocated(this%self_to )) deallocate(this%self_to ) +#ifdef MPAS_MPI + IF (allocated(this%n_to_other )) deallocate(this%n_to_other ) + IF (allocated(this%n_from_other)) deallocate(this%n_from_other) + IF (allocated(this%to_other )) deallocate(this%to_other ) + IF (allocated(this%other_to )) deallocate(this%other_to ) +#endif + + END SUBROUTINE compute_pushdata_free_mem + + ! --------- + SUBROUTINE compute_remapdata_free_mem (this) + + IMPLICIT NONE + type(compute_remapdata_type) :: this + + IF (allocated(this%ilon_me )) deallocate(this%ilon_me ) + IF (allocated(this%ilat_me )) deallocate(this%ilat_me ) + IF (allocated(this%ids_me )) deallocate(this%ids_me ) + IF (allocated(this%npart )) deallocate(this%npart ) + IF (allocated(this%sum_area)) deallocate(this%sum_area) + IF (allocated(this%part_to )) deallocate(this%part_to ) + IF (allocated(this%areapart)) deallocate(this%areapart) + + END SUBROUTINE compute_remapdata_free_mem + +END MODULE MOD_ComputePushData diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 new file mode 100644 index 0000000000..61fc85e9c3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_DataType.F90 @@ -0,0 +1,709 @@ +#include + +MODULE MOD_DataType + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Definitions of data types used in CoLM. +! +! Most frequently used data types in CoLM are "blocked" data types +! including, +! 1. Blocked 2D data of 4-byte integer type; +! 2. Blocked 2D data of 8-byte float type; +! 3. Blocked 3D data of 8-byte float type; +! 4. Blocked 4D data of 8-byte float type; +! +! Subroutines are used to +! 1. allocate memory; +! 2. flush data values; +! 3. copy data; +! 4. do linear transformation and interpolations. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_Precision + + ! ---- data types ---- + !------- + type :: pointer_real8_1d + real(r8), allocatable :: val(:) + CONTAINS + final :: pointer_real8_1d_free_mem + END type pointer_real8_1d + + !------- + type :: pointer_int8_1d + integer(1), allocatable :: val(:) + CONTAINS + final :: pointer_int8_1d_free_mem + END type pointer_int8_1d + + !------- + type :: pointer_int32_1d + integer, allocatable :: val(:) + CONTAINS + final :: pointer_int32_1d_free_mem + END type pointer_int32_1d + + !------- + type :: pointer_int64_1d + integer*8, allocatable :: val(:) + CONTAINS + final :: pointer_int64_1d_free_mem + END type pointer_int64_1d + + !------- + type :: pointer_logic_1d + logical, allocatable :: val(:) + CONTAINS + final :: pointer_logic_1d_free_mem + END type pointer_logic_1d + + !------- + type :: pointer_int32_2d + integer, allocatable :: val (:,:) + CONTAINS + final :: pointer_int32_2d_free_mem + END type pointer_int32_2d + + type :: block_data_int32_2d + type(pointer_int32_2d), allocatable :: blk (:,:) + CONTAINS + final :: block_data_int32_2d_free_mem + END type block_data_int32_2d + + !------- + type :: pointer_real8_2d + real(r8), allocatable :: val (:,:) + CONTAINS + final :: pointer_real8_2d_free_mem + END type pointer_real8_2d + + type :: block_data_real8_2d + type(pointer_real8_2d), allocatable :: blk (:,:) + CONTAINS + final :: block_data_real8_2d_free_mem + END type block_data_real8_2d + + !------- + type :: pointer_real8_3d + real(r8), allocatable :: val (:,:,:) + CONTAINS + final :: pointer_real8_3d_free_mem + END type pointer_real8_3d + + type :: block_data_real8_3d + integer :: lb1, ub1 + type(pointer_real8_3d), allocatable :: blk (:,:) + CONTAINS + final :: block_data_real8_3d_free_mem + END type block_data_real8_3d + + !------- + type :: pointer_real8_4d + real(r8), allocatable :: val (:,:,:,:) + CONTAINS + final :: pointer_real8_4d_free_mem + END type pointer_real8_4d + + type :: block_data_real8_4d + integer :: lb1, ub1, lb2, ub2 + type(pointer_real8_4d), allocatable :: blk (:,:) + CONTAINS + final :: block_data_real8_4d_free_mem + END type block_data_real8_4d + + ! ---- PUBLIC subroutines ---- + !------ + INTERFACE allocate_block_data + MODULE procedure allocate_block_data_int32_2d + MODULE procedure allocate_block_data_real8_2d + MODULE procedure allocate_block_data_real8_3d + MODULE procedure allocate_block_data_real8_4d + END INTERFACE allocate_block_data + + !------ + INTERFACE flush_block_data + MODULE procedure flush_block_data_int32_2d + MODULE procedure flush_block_data_real8_2d + MODULE procedure flush_block_data_real8_3d + MODULE procedure flush_block_data_real8_4d + END INTERFACE flush_block_data + + !----- + PUBLIC :: block_data_linear_transform + PUBLIC :: block_data_copy + PUBLIC :: block_data_linear_interp + PUBLIC :: block_data_division + +CONTAINS + + !------------------ + SUBROUTINE pointer_real8_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_real8_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_real8_1d_free_mem + + !------------------ + SUBROUTINE pointer_int8_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_int8_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_int8_1d_free_mem + + !------------------ + SUBROUTINE pointer_int32_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_int32_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_int32_1d_free_mem + + !------------------ + SUBROUTINE pointer_int64_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_int64_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_int64_1d_free_mem + + !------------------ + SUBROUTINE pointer_logic_1d_free_mem (this) + + IMPLICIT NONE + + type(pointer_logic_1d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_logic_1d_free_mem + + !------------------ + SUBROUTINE pointer_int32_2d_free_mem (this) + + IMPLICIT NONE + + type(pointer_int32_2d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_int32_2d_free_mem + + !------------------ + SUBROUTINE allocate_block_data_int32_2d (grid, gdata) + + USE MOD_Grid + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + type(block_data_int32_2d), intent(out) :: gdata + + ! Local variables + integer :: iblkme, iblk, jblk + + allocate (gdata%blk (gblock%nxblk,gblock%nyblk)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + allocate (gdata%blk(iblk,jblk)%val (grid%xcnt(iblk), grid%ycnt(jblk))) + ENDDO + + END SUBROUTINE allocate_block_data_int32_2d + + !------------------ + SUBROUTINE block_data_int32_2d_free_mem (this) + + USE MOD_Block + IMPLICIT NONE + + type(block_data_int32_2d) :: this + + ! Local variables + integer :: iblk, jblk + + IF (allocated (this%blk)) THEN + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (allocated (this%blk(iblk,jblk)%val)) THEN + deallocate (this%blk(iblk,jblk)%val) + ENDIF + ENDDO + ENDDO + + deallocate (this%blk) + ENDIF + + END SUBROUTINE block_data_int32_2d_free_mem + + !------------------ + SUBROUTINE pointer_real8_2d_free_mem (this) + + IMPLICIT NONE + + type(pointer_real8_2d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_real8_2d_free_mem + + !------------------ + SUBROUTINE allocate_block_data_real8_2d (grid, gdata) + + USE MOD_Grid + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + type(block_data_real8_2d), intent(out) :: gdata + + ! Local variables + integer :: iblkme, iblk, jblk + + allocate (gdata%blk (gblock%nxblk,gblock%nyblk)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + allocate (gdata%blk(iblk,jblk)%val (grid%xcnt(iblk), grid%ycnt(jblk))) + ENDDO + + END SUBROUTINE allocate_block_data_real8_2d + + !------------------ + SUBROUTINE block_data_real8_2d_free_mem (this) + + USE MOD_Block + IMPLICIT NONE + + type(block_data_real8_2d) :: this + + ! Local variables + integer :: iblk, jblk + + IF (allocated (this%blk)) THEN + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (allocated (this%blk(iblk,jblk)%val)) THEN + deallocate (this%blk(iblk,jblk)%val) + ENDIF + ENDDO + ENDDO + + deallocate (this%blk) + ENDIF + + END SUBROUTINE block_data_real8_2d_free_mem + + !------------------ + SUBROUTINE pointer_real8_3d_free_mem (this) + + IMPLICIT NONE + + type(pointer_real8_3d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_real8_3d_free_mem + + !------------------ + SUBROUTINE allocate_block_data_real8_3d (grid, gdata, ndim1, lb1) + + USE MOD_Grid + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + type(block_data_real8_3d), intent(out) :: gdata + integer, intent(in) :: ndim1 + integer, intent(in), optional :: lb1 + + ! Local variables + integer :: iblkme, iblk, jblk + + allocate (gdata%blk (gblock%nxblk,gblock%nyblk)) + + IF (present(lb1)) THEN + gdata%lb1 = lb1 + ELSE + gdata%lb1 = 1 + ENDIF + + gdata%ub1 = gdata%lb1-1+ndim1 + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + allocate (gdata%blk(iblk,jblk)%val (gdata%lb1:gdata%ub1, grid%xcnt(iblk), grid%ycnt(jblk))) + ENDDO + + END SUBROUTINE allocate_block_data_real8_3d + + !------------------ + SUBROUTINE block_data_real8_3d_free_mem (this) + + USE MOD_Block + IMPLICIT NONE + + type(block_data_real8_3d) :: this + + ! Local variables + integer :: iblk, jblk + + IF (allocated (this%blk)) THEN + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (allocated (this%blk(iblk,jblk)%val)) THEN + deallocate (this%blk(iblk,jblk)%val) + ENDIF + ENDDO + ENDDO + + deallocate (this%blk) + ENDIF + + END SUBROUTINE block_data_real8_3d_free_mem + + !------------------ + SUBROUTINE pointer_real8_4d_free_mem (this) + + IMPLICIT NONE + + type(pointer_real8_4d) :: this + + IF (allocated(this%val)) THEN + deallocate(this%val) + ENDIF + + END SUBROUTINE pointer_real8_4d_free_mem + + !------------------ + SUBROUTINE allocate_block_data_real8_4d (grid, gdata, ndim1, ndim2, lb1, lb2) + + USE MOD_Grid + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + type(block_data_real8_4d), intent(out) :: gdata + integer, intent(in) :: ndim1, ndim2 + integer, intent(in), optional :: lb1, lb2 + + ! Local variables + integer :: iblkme, iblk, jblk + + allocate (gdata%blk (gblock%nxblk,gblock%nyblk)) + + IF (present(lb1)) THEN + gdata%lb1 = lb1 + ELSE + gdata%lb1 = 1 + ENDIF + + gdata%ub1 = gdata%lb1-1+ndim1 + + IF (present(lb2)) THEN + gdata%lb2 = lb2 + ELSE + gdata%lb2 = 1 + ENDIF + + gdata%ub2 = gdata%lb2-1+ndim2 + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + allocate (gdata%blk(iblk,jblk)%val ( & + gdata%lb1:gdata%ub1, gdata%lb2:gdata%ub2, grid%xcnt(iblk), grid%ycnt(jblk))) + ENDDO + + END SUBROUTINE allocate_block_data_real8_4d + + !------------------ + SUBROUTINE block_data_real8_4d_free_mem (this) + + USE MOD_Block + IMPLICIT NONE + + type(block_data_real8_4d) :: this + + ! Local variables + integer :: iblk, jblk + + IF (allocated (this%blk)) THEN + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (allocated (this%blk(iblk,jblk)%val)) THEN + deallocate (this%blk(iblk,jblk)%val) + ENDIF + ENDDO + ENDDO + + deallocate (this%blk) + ENDIF + + END SUBROUTINE block_data_real8_4d_free_mem + + !------------------ + SUBROUTINE flush_block_data_real8_2d (gdata, spval) + + USE MOD_Precision + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(block_data_real8_2d), intent(inout) :: gdata + real(r8), intent(in) :: spval + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = spval + ENDDO + + END SUBROUTINE flush_block_data_real8_2d + + !------------------ + SUBROUTINE flush_block_data_int32_2d (gdata, spval) + + USE MOD_Precision + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(block_data_int32_2d), intent(inout) :: gdata + integer, intent(in) :: spval + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = spval + ENDDO + + END SUBROUTINE flush_block_data_int32_2d + + !------------------ + SUBROUTINE flush_block_data_real8_3d (gdata, spval) + + USE MOD_Precision + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(block_data_real8_3d), intent(inout) :: gdata + real(r8), intent(in) :: spval + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = spval + ENDDO + + END SUBROUTINE flush_block_data_real8_3d + + !------------------ + SUBROUTINE flush_block_data_real8_4d (gdata, spval) + + USE MOD_Precision + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(block_data_real8_4d), intent(inout) :: gdata + real(r8), intent(in) :: spval + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = spval + ENDDO + + END SUBROUTINE flush_block_data_real8_4d + + !------------------ + SUBROUTINE block_data_linear_transform (gdata, scl, dsp) + + USE MOD_Precision + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(block_data_real8_2d), intent(inout) :: gdata + real(r8), intent(in), optional :: scl + real(r8), intent(in), optional :: dsp + + ! Local variables + integer :: iblkme, iblk, jblk + + IF (present(scl)) THEN + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = gdata%blk(iblk,jblk)%val * scl + ENDDO + ENDIF + + IF (present(dsp)) THEN + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata%blk(iblk,jblk)%val = gdata%blk(iblk,jblk)%val + dsp + ENDDO + ENDIF + + END SUBROUTINE block_data_linear_transform + + !------------------ + SUBROUTINE block_data_copy (gdata_from, gdata_to, sca) + + USE MOD_Precision + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(block_data_real8_2d), intent(in) :: gdata_from + type(block_data_real8_2d), intent(inout) :: gdata_to + real(r8), intent(in), optional :: sca + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + IF (present(sca)) THEN + gdata_to%blk(iblk,jblk)%val = gdata_from%blk(iblk,jblk)%val * sca + ELSE + gdata_to%blk(iblk,jblk)%val = gdata_from%blk(iblk,jblk)%val + ENDIF + ENDDO + + END SUBROUTINE block_data_copy + + !------------------ + SUBROUTINE block_data_linear_interp ( & + gdata_from1, alp1, gdata_from2, alp2, gdata_to) + + USE MOD_Precision + USE MOD_Block + USE MOD_MPAS_MPI + IMPLICIT NONE + + type(block_data_real8_2d), intent(in) :: gdata_from1, gdata_from2 + real(r8), intent(in) :: alp1, alp2 + type(block_data_real8_2d), intent(inout) :: gdata_to + + ! Local variables + integer :: iblkme, iblk, jblk + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + gdata_to%blk(iblk,jblk)%val = & + gdata_from1%blk(iblk,jblk)%val * alp1 & + + gdata_from2%blk(iblk,jblk)%val * alp2 + ENDDO + + END SUBROUTINE block_data_linear_interp + + !----------------- + SUBROUTINE block_data_division (gdata, sumdata, spv) + + USE MOD_Precision + USE MOD_Block + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + type(block_data_real8_2d), intent(inout) :: gdata + type(block_data_real8_2d), intent(inout) :: sumdata + real(r8), intent(in), optional :: spv + + ! Local variables + integer :: iblkme, iblk, jblk + + IF (.true.) THEN + + IF (.not. present(spv)) THEN + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + WHERE (sumdata%blk(iblk,jblk)%val > 0.) + gdata%blk(iblk,jblk)%val = & + gdata%blk(iblk,jblk)%val / sumdata%blk(iblk,jblk)%val + ELSEWHERE + gdata%blk(iblk,jblk)%val = spval + ENDWHERE + ENDDO + + ELSE + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + WHERE ((sumdata%blk(iblk,jblk)%val > 0.) .and. (gdata%blk(iblk,jblk)%val /= spv)) + gdata%blk(iblk,jblk)%val = & + gdata%blk(iblk,jblk)%val / sumdata%blk(iblk,jblk)%val + ELSEWHERE + gdata%blk(iblk,jblk)%val = spv + ENDWHERE + ENDDO + + ENDIF + + ENDIF + + END SUBROUTINE block_data_division + +END MODULE MOD_DataType diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 new file mode 100644 index 0000000000..d4a9842254 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90 @@ -0,0 +1,948 @@ +#include + +MODULE MOD_Grid + +!------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Definition of latitude-longitude grids and data types related to grids. +! +! Latitude-longitude grid can be defined by +! 1. "name" : frequently used grids is predefined in this MODULE; +! 2. "ndims" : how many longitude and latitude grids are used globally; +! 3. "res" : longitude and latitude resolutions in radian +! 4. "center" : longitude and latitude grid centers, and the border lines +! are defined by center lines of grid centers; the region +! boundaries is optional. +! 5. "file" : read grid informations from a file, the variables are +! 'lat_s', 'lat_n', 'lon_w', 'lon_e' +! 6. "copy" : copy grid informations from an existing grid +! +! Grid centers in radian can be calculated by using "set_rlon" and "set_rlat" +! +! Two additional data types are defined: +! 1. "grid_list_type" : list of grid boxes; +! 2. "grid_concat_type" : used to concatenate grids distributed in blocks. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_UserDefFun + IMPLICIT NONE + + ! ---- data types ---- + type :: grid_type + + integer :: nlat + integer :: nlon + + ! Latitude direction. (yinc = 1) means south to north. + integer :: yinc + + ! Coordinates. + real(r8), allocatable :: lat_s (:) + real(r8), allocatable :: lat_n (:) + real(r8), allocatable :: lon_w (:) + real(r8), allocatable :: lon_e (:) + + ! Blocks. + integer, allocatable :: xdsp(:), ydsp(:) + integer, allocatable :: xcnt(:), ycnt(:) + integer, allocatable :: xblk(:), yblk(:) + integer, allocatable :: xloc(:), yloc(:) + + ! Mapping to pixels. + integer, allocatable :: xgrd(:), ygrd(:) + + ! Grid info. + real(r8), allocatable :: rlon(:) + real(r8), allocatable :: rlat(:) + + CONTAINS + procedure, PUBLIC :: define_by_name => grid_define_by_name + procedure, PUBLIC :: define_by_ndims => grid_define_by_ndims + procedure, PUBLIC :: define_by_res => grid_define_by_res + procedure, PUBLIC :: define_by_center => grid_define_by_center + procedure, PUBLIC :: define_from_file => grid_define_from_file + procedure, PUBLIC :: define_by_copy => grid_define_by_copy + + procedure, PUBLIC :: set_rlon => grid_set_rlon + procedure, PUBLIC :: set_rlat => grid_set_rlat + + procedure, PRIVATE :: init => grid_init + procedure, PRIVATE :: normalize => grid_normalize + procedure, PRIVATE :: set_blocks => grid_set_blocks + + final :: grid_free_mem + + END type grid_type + + ! ---- data types ---- + type :: grid_list_type + integer :: ng + integer, allocatable :: ilat(:) + integer, allocatable :: ilon(:) + END type grid_list_type + + type :: segment_type + integer :: blk + integer :: cnt + integer :: bdsp + integer :: gdsp + END type segment_type + + type :: grid_info_type + integer :: nlat, nlon + real(r8), allocatable :: lat_s(:) + real(r8), allocatable :: lat_n(:) + real(r8), allocatable :: lon_w(:) + real(r8), allocatable :: lon_e(:) + real(r8), allocatable :: lon_c(:) !grid center + real(r8), allocatable :: lat_c(:) !grid center + END type grid_info_type + + type :: grid_concat_type + integer :: ndatablk + integer :: nxseg, nyseg + type(segment_type), allocatable :: xsegs(:), ysegs(:) + type(grid_info_type) :: ginfo + CONTAINS + procedure, PUBLIC :: set => set_grid_concat + final :: grid_concat_free_mem + END type grid_concat_type + +CONTAINS + + ! -------------------------------- + SUBROUTINE grid_init (this, nlon, nlat) + + IMPLICIT NONE + class (grid_type) :: this + + integer, intent(in) :: nlon + integer, intent(in) :: nlat + + this%nlat = nlat + this%nlon = nlon + + IF (allocated(this%lat_s)) deallocate(this%lat_s) + IF (allocated(this%lat_n)) deallocate(this%lat_n) + IF (allocated(this%lon_w)) deallocate(this%lon_w) + IF (allocated(this%lon_e)) deallocate(this%lon_e) + allocate (this%lat_s (nlat)) + allocate (this%lat_n (nlat)) + allocate (this%lon_w (nlon)) + allocate (this%lon_e (nlon)) + + END SUBROUTINE grid_init + + ! -------------------------------- + SUBROUTINE grid_define_by_name (this, gridname) + + IMPLICIT NONE + class (grid_type) :: this + + character(len=*), intent(in) :: gridname + + ! Local variables + integer :: nlat, nlon, ilat, ilon + real(r8) :: del_lat, del_lon + + IF (trim(gridname) == 'merit_90m') THEN + + nlat = 180*60*20 + nlon = 360*60*20 + + this%nlat = nlat + this%nlon = nlon + + CALL this%init (this%nlon, this%nlat) + + del_lat = 180.0 / nlat + DO ilat = 1, this%nlat + this%lat_s(ilat) = 90.0 - del_lat * ilat - del_lat/2.0 + this%lat_n(ilat) = 90.0 - del_lat * (ilat-1) - del_lat/2.0 + ENDDO + + del_lon = 360.0 / nlon + DO ilon = 1, this%nlon + this%lon_w(ilon) = -180.0 + del_lon * (ilon-1) - del_lon/2.0 + this%lon_e(ilon) = -180.0 + del_lon * ilon - del_lon/2.0 + ENDDO + + CALL this%normalize () + CALL this%set_blocks () + + ENDIF + + IF (trim(gridname) == 'colm_5km') THEN + + CALL this%define_by_ndims (8640,4320) + + ENDIF + + IF (trim(gridname) == 'colm_1km') THEN + + CALL this%define_by_ndims (43200,21600) + + ENDIF + + + IF (trim(gridname) == 'colm_500m') THEN + + CALL this%define_by_ndims (86400,43200) + + ENDIF + + IF (trim(gridname) == 'colm_100m') THEN + + CALL this%define_by_ndims (432000,216000) + + ENDIF + + IF (trim(gridname) == 'nitrif_2deg') THEN + + CALL this%define_by_ndims (144,96) + + ENDIF + + END SUBROUTINE grid_define_by_name + + !----------------------------------------------------- + SUBROUTINE grid_define_by_ndims (this, lon_points, lat_points) + + IMPLICIT NONE + class (grid_type) :: this + + integer, intent(in) :: lon_points + integer, intent(in) :: lat_points + + ! Local variables + integer :: ilat, ilon + real(r8) :: del_lat, del_lon + + this%nlat = lat_points + this%nlon = lon_points + + CALL this%init (this%nlon, this%nlat) + + del_lat = 180.0 / lat_points + DO ilat = 1, this%nlat + this%lat_s(ilat) = 90.0 - del_lat * ilat + this%lat_n(ilat) = 90.0 - del_lat * (ilat-1) + ENDDO + + del_lon = 360.0 / lon_points + DO ilon = 1, this%nlon + this%lon_w(ilon) = -180.0 + del_lon * (ilon-1) + this%lon_e(ilon) = -180.0 + del_lon * ilon + ENDDO + + this%lon_e(this%nlon) = -180.0 + + CALL this%normalize () + CALL this%set_blocks () + + END SUBROUTINE grid_define_by_ndims + + !----------------------------------------------------- + SUBROUTINE grid_define_by_res (this, lon_res, lat_res) + + IMPLICIT NONE + class (grid_type) :: this + + real(r8), intent(in) :: lon_res, lat_res + + ! Local variables + integer :: lon_points, lat_points + + lon_points = nint(360.0/lon_res) + lat_points = nint(180.0/lat_res) + + CALL this%define_by_ndims (lon_points, lat_points) + + END SUBROUTINE grid_define_by_res + + !--------------------------------------------- + SUBROUTINE grid_define_by_center (this, lat_in, lon_in, & + south, north, west, east) + + USE MOD_Precision + USE MOD_Utils + IMPLICIT NONE + class (grid_type) :: this + + real(r8), intent(in) :: lat_in(:), lon_in(:) + real(r8), intent(in), optional :: south, north, west, east + + ! Local variables + integer :: ilat, ilon, ilone, ilonw + real(r8), allocatable :: lon_in_n(:) + + this%nlat = size(lat_in) + this%nlon = size(lon_in) + + CALL this%init (this%nlon, this%nlat) + + IF (lat_in(1) > lat_in(this%nlat)) THEN + this%yinc = -1 + ELSE + this%yinc = 1 + ENDIF + + DO ilat = 1, this%nlat + IF (this%yinc == 1) THEN + IF (ilat < this%nlat) THEN + this%lat_n(ilat) = (lat_in(ilat) + lat_in(ilat+1)) * 0.5 + ELSE + IF (present(north)) THEN + this%lat_n(ilat) = north + ELSE + this%lat_n(ilat) = 90.0 + ENDIF + ENDIF + + IF (ilat > 1) THEN + this%lat_s(ilat) = (lat_in(ilat-1) + lat_in(ilat)) * 0.5 + ELSE + IF (present(south)) THEN + this%lat_s(ilat) = south + ELSE + this%lat_s(ilat) = -90.0 + ENDIF + ENDIF + ELSEIF (this%yinc == -1) THEN + IF (ilat > 1) THEN + this%lat_n(ilat) = (lat_in(ilat-1) + lat_in(ilat)) * 0.5 + ELSE + IF (present(north)) THEN + this%lat_n(ilat) = north + ELSE + this%lat_n(ilat) = 90.0 + ENDIF + ENDIF + + IF (ilat < this%nlat) THEN + this%lat_s(ilat) = (lat_in(ilat) + lat_in(ilat+1)) * 0.5 + ELSE + IF (present(south)) THEN + this%lat_s(ilat) = south + ELSE + this%lat_s(ilat) = -90.0 + ENDIF + ENDIF + ENDIF + ENDDO + + allocate (lon_in_n (size(lon_in))) + + lon_in_n = lon_in + DO ilon = 1, size(lon_in_n) + CALL normalize_longitude (lon_in_n(ilon)) + ENDDO + + DO ilon = 1, this%nlon + ilone = mod(ilon,this%nlon) + 1 + IF (lon_in_n(ilon) > lon_in_n(ilone)) THEN + this%lon_e(ilon) = (lon_in_n(ilon) + lon_in_n(ilone) + 360.0) * 0.5 + ELSE + this%lon_e(ilon) = (lon_in_n(ilon) + lon_in_n(ilone)) * 0.5 + ENDIF + + IF ((ilon == this%nlon) .and. (present(east))) THEN + this%lon_e(this%nlon) = east + ENDIF + + ilonw = ilon - 1 + IF (ilonw == 0) ilonw = this%nlon + IF (lon_in_n(ilonw) > lon_in_n(ilon)) THEN + this%lon_w(ilon) = (lon_in_n(ilonw) + lon_in_n(ilon) + 360.0) * 0.5 + ELSE + this%lon_w(ilon) = (lon_in_n(ilonw) + lon_in_n(ilon)) * 0.5 + ENDIF + + IF ((ilon == 1) .and. (present(west))) THEN + this%lon_w(1) = west + ENDIF + ENDDO + + deallocate (lon_in_n) + + CALL this%normalize () + CALL this%set_blocks () + + END SUBROUTINE grid_define_by_center + + !----------------------------------------------------- + SUBROUTINE grid_define_from_file (this, filename, latname, lonname) + + USE MOD_NetCDFSerial + IMPLICIT NONE + class (grid_type) :: this + + character(len=*), intent(in) :: filename + character(len=*), intent(in), optional :: latname, lonname + + ! Local Variables + real(r8), allocatable :: lon_in(:) + real(r8), allocatable :: lat_in(:) + + IF (.not. (present(latname) .and. present(lonname))) THEN + + CALL ncio_read_bcast_serial (filename, 'lat_s', this%lat_s) + CALL ncio_read_bcast_serial (filename, 'lat_n', this%lat_n) + CALL ncio_read_bcast_serial (filename, 'lon_w', this%lon_w) + CALL ncio_read_bcast_serial (filename, 'lon_e', this%lon_e) + + this%nlat = size(this%lat_s) + this%nlon = size(this%lon_w) + + CALL this%normalize () + CALL this%set_blocks () + + ELSE + + CALL ncio_read_bcast_serial (filename, latname, lat_in) + CALL ncio_read_bcast_serial (filename, lonname, lon_in) + CALL this%define_by_center (lat_in, lon_in) + + deallocate (lat_in, lon_in) + ENDIF + + END SUBROUTINE grid_define_from_file + + !----------------------------------------------------- + RECURSIVE SUBROUTINE grid_define_by_copy (this, grid_in) + + USE MOD_NetCDFSerial + IMPLICIT NONE + class(grid_type), intent(inout) :: this + type(grid_type), intent(in) :: grid_in + + CALL this%init (grid_in%nlon, grid_in%nlat) + + this%lat_s = grid_in%lat_s + this%lat_n = grid_in%lat_n + this%lon_w = grid_in%lon_w + this%lon_e = grid_in%lon_e + + CALL this%normalize () + CALL this%set_blocks () + + END SUBROUTINE grid_define_by_copy + + !----------------------------------------------------- + SUBROUTINE grid_normalize (this) + + USE MOD_Utils + IMPLICIT NONE + class(grid_type) :: this + + ! Local variable + integer :: ilon, ilat + + DO ilon = 1, this%nlon + CALL normalize_longitude (this%lon_w(ilon)) + CALL normalize_longitude (this%lon_e(ilon)) + ENDDO + + DO ilat = 1, this%nlat + this%lat_s(ilat) = max(-90.0, min(90.0, this%lat_s(ilat))) + this%lat_n(ilat) = max(-90.0, min(90.0, this%lat_n(ilat))) + ENDDO + + IF (this%lat_s(1) <= this%lat_s(this%nlat)) THEN + this%yinc = 1 + ELSE + this%yinc = -1 + ENDIF + + ! align grid + DO ilon = 1, this%nlon-1 + IF (lon_between_ceil(this%lon_e(ilon), this%lon_w(ilon+1), this%lon_e(ilon+1))) THEN + this%lon_e(ilon) = this%lon_w(ilon+1) + ELSE + this%lon_w(ilon+1) = this%lon_e(ilon) + ENDIF + ENDDO + + IF (this%nlon > 1) THEN + ilon = this%nlon + IF (lon_between_ceil(this%lon_e(ilon), this%lon_w(1), this%lon_e(1))) THEN + this%lon_e(ilon) = this%lon_w(1) + ENDIF + ENDIF + + DO ilat = 1, this%nlat-1 + IF (this%yinc == 1) THEN + this%lat_n(ilat) = max(this%lat_n(ilat),this%lat_s(ilat+1)) + this%lat_s(ilat+1) = this%lat_n(ilat) + ELSEIF (this%yinc == -1) THEN + this%lat_s(ilat) = min(this%lat_s(ilat),this%lat_n(ilat+1)) + this%lat_n(ilat+1) = this%lat_s(ilat) + ENDIF + ENDDO + + END SUBROUTINE grid_normalize + + !----------------------------------------------------- + SUBROUTINE grid_set_blocks (this) + + USE MOD_Namelist + USE MOD_Block + USE MOD_Utils + IMPLICIT NONE + + class (grid_type) :: this + + ! Local variables + integer :: ilat, ilon, iblk, jblk, ilon_e + real(r8) :: edges, edgen, edgew, edgee + + IF (allocated(this%xcnt)) deallocate(this%xcnt) + IF (allocated(this%xdsp)) deallocate(this%xdsp) + IF (allocated(this%ycnt)) deallocate(this%ycnt) + IF (allocated(this%ydsp)) deallocate(this%ydsp) + allocate (this%xcnt (gblock%nxblk)) + allocate (this%xdsp (gblock%nxblk)) + allocate (this%ycnt (gblock%nyblk)) + allocate (this%ydsp (gblock%nyblk)) + + IF (allocated(this%xblk)) deallocate(this%xblk) + IF (allocated(this%yblk)) deallocate(this%yblk) + allocate (this%xblk (this%nlon)) + allocate (this%yblk (this%nlat)) + + IF (allocated(this%xloc)) deallocate(this%xloc) + IF (allocated(this%yloc)) deallocate(this%yloc) + allocate (this%xloc (this%nlon)) + allocate (this%yloc (this%nlat)) + + edges = DEF_domain%edges + edgen = DEF_domain%edgen + edgew = DEF_domain%edgew + edgee = DEF_domain%edgee + + CALL normalize_longitude (edgew) + CALL normalize_longitude (edgee) + + IF (this%yinc == 1) THEN + + this%ycnt(:) = 0 + this%yblk(:) = 0 + + IF (edges < this%lat_s(1)) THEN + jblk = find_nearest_south (this%lat_s(1), gblock%nyblk, gblock%lat_s) + ilat = 1 + ELSE + jblk = find_nearest_south (edges, gblock%nyblk, gblock%lat_s) + ilat = find_nearest_south (edges, this%nlat, this%lat_s) + ENDIF + + this%ydsp(jblk) = ilat - 1 + + DO WHILE (ilat <= this%nlat) + IF (this%lat_s(ilat) < edgen) THEN + IF (this%lat_s(ilat) < gblock%lat_n(jblk)) THEN + + this%ycnt(jblk) = this%ycnt(jblk) + 1 + + this%yblk(ilat) = jblk + this%yloc(ilat) = this%ycnt(jblk) + + ilat = ilat + 1 + ELSE + jblk = jblk + 1 + IF (jblk <= gblock%nyblk) THEN + this%ydsp(jblk) = ilat - 1 + ELSE + EXIT + ENDIF + ENDIF + ELSE + EXIT + ENDIF + ENDDO + + ELSE + + this%ycnt(:) = 0 + this%yblk(:) = 0 + + IF (edgen > this%lat_n(1)) THEN + jblk = find_nearest_north (this%lat_n(1), gblock%nyblk, gblock%lat_n) + ilat = 1 + ELSE + jblk = find_nearest_north (edgen, gblock%nyblk, gblock%lat_n) + ilat = find_nearest_north (edgen, this%nlat, this%lat_n) + ENDIF + + this%ydsp(jblk) = ilat - 1 + + DO WHILE (ilat <= this%nlat) + IF (this%lat_n(ilat) > edges) THEN + IF (this%lat_n(ilat) > gblock%lat_s(jblk)) THEN + + this%ycnt(jblk) = this%ycnt(jblk) + 1 + + this%yblk(ilat) = jblk + this%yloc(ilat) = this%ycnt(jblk) + + ilat = ilat + 1 + ELSE + jblk = jblk - 1 + IF (jblk >= 1) THEN + this%ydsp(jblk) = ilat - 1 + ELSE + EXIT + ENDIF + ENDIF + ELSE + EXIT + ENDIF + ENDDO + + ENDIF + + + this%xcnt(:) = 0 + this%xblk(:) = 0 + + IF ((this%lon_w(1) /= this%lon_e(this%nlon)) & + .and. (lon_between_floor(edgew, this%lon_e(this%nlon), this%lon_w(1)))) THEN + iblk = find_nearest_west (this%lon_w(1), gblock%nxblk, gblock%lon_w) + ilon = 1 + ELSE + iblk = find_nearest_west (edgew, gblock%nxblk, gblock%lon_w) + ilon = find_nearest_west (edgew, this%nlon, this%lon_w) + ENDIF + + this%xdsp(iblk) = ilon - 1 + this%xcnt(iblk) = 1 + this%xblk(ilon) = iblk + this%xloc(ilon) = 1 + + ilon_e = ilon - 1 + IF (ilon_e == 0) ilon_e = this%nlon + ilon = mod(ilon,this%nlon) + 1 + DO WHILE (.true.) + IF (lon_between_floor(this%lon_w(ilon), edgew, edgee)) THEN + IF (lon_between_floor(this%lon_w(ilon), gblock%lon_w(iblk), gblock%lon_e(iblk))) THEN + + this%xcnt(iblk) = this%xcnt(iblk) + 1 + + this%xblk(ilon) = iblk + this%xloc(ilon) = this%xcnt(iblk) + + IF (ilon /= ilon_e) THEN + ilon = mod(ilon,this%nlon) + 1 + ELSE + EXIT + ENDIF + ELSE + iblk = mod(iblk,gblock%nxblk) + 1 + IF (this%xcnt(iblk) == 0) THEN + this%xdsp(iblk) = ilon - 1 + ELSE + ilon_e = this%xdsp(iblk) + this%xcnt(iblk) + IF (ilon_e > this%nlon) ilon_e = ilon_e - this%nlon + + this%xdsp(iblk) = ilon - 1 + this%xcnt(iblk) = 0 + DO WHILE (.true.) + this%xcnt(iblk) = this%xcnt(iblk) + 1 + this%xblk(ilon) = iblk + this%xloc(ilon) = this%xcnt(iblk) + + IF (ilon /= ilon_e) THEN + ilon = mod(ilon,this%nlon) + 1 + ELSE + EXIT + ENDIF + ENDDO + + EXIT + ENDIF + ENDIF + ELSE + EXIT + ENDIF + ENDDO + + END SUBROUTINE grid_set_blocks + + !----------- + SUBROUTINE grid_set_rlon (this) + + USE MOD_Precision + USE MOD_Utils + USE MOD_Vars_Global, only: pi + IMPLICIT NONE + + class (grid_type) :: this + + ! Local variables + integer :: ix + real(r8) :: lon + + IF (.not. allocated(this%rlon)) THEN + allocate (this%rlon(this%nlon)) + ENDIF + + DO ix = 1, this%nlon + IF (this%lon_w(ix) <= this%lon_e(ix)) THEN + lon = (this%lon_w(ix) + this%lon_e(ix)) * 0.5 + ELSE + lon = (this%lon_w(ix) + this%lon_e(ix)) * 0.5 + 180.0 + ENDIF + + CALL normalize_longitude (lon) + + this%rlon(ix) = lon / 180.0_r8 * pi + ENDDO + + END SUBROUTINE grid_set_rlon + + !----------- + SUBROUTINE grid_set_rlat (this) + + USE MOD_Precision + USE MOD_Utils + USE MOD_Vars_Global, only: pi + IMPLICIT NONE + + class (grid_type) :: this + + ! Local variables + integer :: iy + + IF (.not. allocated(this%rlat)) THEN + allocate (this%rlat(this%nlat)) + ENDIF + + DO iy = 1, this%nlat + this%rlat(iy) = & + (this%lat_s(iy) + this%lat_n(iy)) * 0.5 / 180.0_r8 * pi + ENDDO + + END SUBROUTINE grid_set_rlat + + !--------- + SUBROUTINE grid_free_mem (this) + + IMPLICIT NONE + type (grid_type) :: this + + IF (allocated (this%lat_s)) deallocate (this%lat_s) + IF (allocated (this%lat_n)) deallocate (this%lat_n) + IF (allocated (this%lon_w)) deallocate (this%lon_w) + IF (allocated (this%lon_e)) deallocate (this%lon_e) + + IF (allocated (this%xdsp)) deallocate (this%xdsp) + IF (allocated (this%ydsp)) deallocate (this%ydsp) + + IF (allocated (this%xcnt)) deallocate (this%xcnt) + IF (allocated (this%ycnt)) deallocate (this%ycnt) + + IF (allocated (this%xblk)) deallocate (this%xblk) + IF (allocated (this%yblk)) deallocate (this%yblk) + + IF (allocated (this%xloc)) deallocate (this%xloc) + IF (allocated (this%yloc)) deallocate (this%yloc) + + IF (allocated (this%xgrd)) deallocate (this%xgrd) + IF (allocated (this%ygrd)) deallocate (this%ygrd) + + IF (allocated (this%rlon)) deallocate (this%rlon) + IF (allocated (this%rlat)) deallocate (this%rlat) + + END SUBROUTINE grid_free_mem + + !---------- + SUBROUTINE set_grid_concat (this, grid) + + USE MOD_Block + USE MOD_Utils + IMPLICIT NONE + + class(grid_concat_type) :: this + type(grid_type), intent(in) :: grid + + ! Local variables + integer :: ilat_l, ilat_u, ilat, ilatloc, jblk, iyseg + integer :: ilon_w, ilon_e, ilon, ilonloc, iblk, ixseg + + ilat_l = findloc_ud(grid%yblk /= 0) + ilat_u = findloc_ud(grid%yblk /= 0, back=.true.) + + this%ginfo%nlat = ilat_u - ilat_l + 1 + IF (allocated(this%ginfo%lat_s)) deallocate(this%ginfo%lat_s) + IF (allocated(this%ginfo%lat_n)) deallocate(this%ginfo%lat_n) + IF (allocated(this%ginfo%lat_c)) deallocate(this%ginfo%lat_c) + allocate (this%ginfo%lat_s (this%ginfo%nlat)) + allocate (this%ginfo%lat_n (this%ginfo%nlat)) + allocate (this%ginfo%lat_c (this%ginfo%nlat)) + + this%nyseg = 0 + jblk = 0 + ilatloc = 0 + DO ilat = ilat_l, ilat_u + IF (grid%yblk(ilat) /= jblk) THEN + this%nyseg = this%nyseg + 1 + jblk = grid%yblk(ilat) + ENDIF + + ilatloc = ilatloc + 1 + this%ginfo%lat_s(ilatloc) = grid%lat_s(ilat) + this%ginfo%lat_n(ilatloc) = grid%lat_n(ilat) + this%ginfo%lat_c(ilatloc) = (grid%lat_s(ilat)+grid%lat_n(ilat)) * 0.5 + ENDDO + + IF (allocated(this%ysegs)) deallocate(this%ysegs) + allocate (this%ysegs (this%nyseg)) + + iyseg = 0 + jblk = 0 + DO ilat = ilat_l, ilat_u + IF (grid%yblk(ilat) /= jblk) THEN + iyseg = iyseg + 1 + jblk = grid%yblk(ilat) + this%ysegs(iyseg)%blk = jblk + this%ysegs(iyseg)%bdsp = grid%yloc(ilat) - 1 + this%ysegs(iyseg)%gdsp = ilat - ilat_l + this%ysegs(iyseg)%cnt = 1 + ELSE + this%ysegs(iyseg)%cnt = this%ysegs(iyseg)%cnt + 1 + ENDIF + ENDDO + + IF (all(grid%xblk > 0)) THEN + ilon_w = 1 + ilon_e = grid%nlon + ELSE + ilon_w = findloc_ud(grid%xblk /= 0) + DO WHILE (.true.) + ilon = ilon_w - 1 + IF (ilon == 0) ilon = grid%nlon + + IF (grid%xblk(ilon) /= 0) THEN + ilon_w = ilon + ELSE + EXIT + ENDIF + ENDDO + + ilon_e = ilon_w + DO WHILE (.true.) + ilon = mod(ilon_e,grid%nlon) + 1 + + IF (grid%xblk(ilon) /= 0) THEN + ilon_e = ilon + ELSE + EXIT + ENDIF + ENDDO + ENDIF + + this%ginfo%nlon = ilon_e - ilon_w + 1 + IF (this%ginfo%nlon <= 0) THEN + this%ginfo%nlon = this%ginfo%nlon + grid%nlon + ENDIF + + IF (allocated(this%ginfo%lon_w)) deallocate(this%ginfo%lon_w) + IF (allocated(this%ginfo%lon_e)) deallocate(this%ginfo%lon_e) + IF (allocated(this%ginfo%lon_c)) deallocate(this%ginfo%lon_c) + allocate (this%ginfo%lon_w (this%ginfo%nlon)) + allocate (this%ginfo%lon_e (this%ginfo%nlon)) + allocate (this%ginfo%lon_c (this%ginfo%nlon)) + + this%nxseg = 0 + ilon = ilon_w - 1 + iblk = 0 + ilonloc = 0 + DO WHILE (.true.) + ilon = mod(ilon,grid%nlon) + 1 + IF ((grid%xblk(ilon) /= iblk) .or. (grid%xloc(ilon) == 1)) THEN + this%nxseg = this%nxseg + 1 + iblk = grid%xblk(ilon) + ENDIF + + ilonloc = ilonloc + 1 + this%ginfo%lon_w(ilonloc) = grid%lon_w(ilon) + this%ginfo%lon_e(ilonloc) = grid%lon_e(ilon) + + this%ginfo%lon_c(ilonloc) = (grid%lon_w(ilon) + grid%lon_e(ilon)) * 0.5 + IF (grid%lon_w(ilon) > grid%lon_e(ilon)) THEN + this%ginfo%lon_c(ilonloc) = this%ginfo%lon_c(ilonloc) + 180.0 + CALL normalize_longitude (this%ginfo%lon_c(ilonloc)) + ENDIF + + IF (ilon == ilon_e) EXIT + ENDDO + + DO ilon = 2, this%ginfo%nlon + IF ((this%ginfo%lon_c(ilon) < this%ginfo%lon_c(ilon-1)) & + .and. (this%ginfo%lon_c(ilon) < 0)) THEN + this%ginfo%lon_c(ilon) = this%ginfo%lon_c(ilon) + 360.0 + ENDIF + ENDDO + + IF (allocated(this%xsegs)) deallocate(this%xsegs) + allocate (this%xsegs (this%nxseg)) + + ixseg = 0 + iblk = 0 + ilon = ilon_w - 1 + ilonloc = 0 + DO WHILE (.true.) + ilon = mod(ilon,grid%nlon) + 1 + ilonloc = ilonloc + 1 + IF ((grid%xblk(ilon) /= iblk) .or. (grid%xloc(ilon) == 1)) THEN + ixseg = ixseg + 1 + iblk = grid%xblk(ilon) + this%xsegs(ixseg)%blk = iblk + this%xsegs(ixseg)%bdsp = grid%xloc(ilon) - 1 + this%xsegs(ixseg)%gdsp = ilonloc - 1 + this%xsegs(ixseg)%cnt = 1 + ELSE + this%xsegs(ixseg)%cnt = this%xsegs(ixseg)%cnt + 1 + ENDIF + + IF (ilon == ilon_e) EXIT + ENDDO + + this%ndatablk = 0 + + DO iyseg = 1, this%nyseg + DO ixseg = 1, this%nxseg + iblk = this%xsegs(ixseg)%blk + jblk = this%ysegs(iyseg)%blk + IF (gblock%owner_rank(iblk,jblk) >= 0) THEN + this%ndatablk = this%ndatablk + 1 + ENDIF + ENDDO + ENDDO + + END SUBROUTINE set_grid_concat + + !------- + SUBROUTINE grid_concat_free_mem (this) + + IMPLICIT NONE + + type(grid_concat_type) :: this + + IF (allocated(this%xsegs)) deallocate(this%xsegs) + IF (allocated(this%ysegs)) deallocate(this%ysegs) + + IF (allocated(this%ginfo%lat_s)) deallocate(this%ginfo%lat_s) + IF (allocated(this%ginfo%lat_n)) deallocate(this%ginfo%lat_n) + IF (allocated(this%ginfo%lat_c)) deallocate(this%ginfo%lat_c) + IF (allocated(this%ginfo%lon_w)) deallocate(this%ginfo%lon_w) + IF (allocated(this%ginfo%lon_e)) deallocate(this%ginfo%lon_e) + IF (allocated(this%ginfo%lon_c)) deallocate(this%ginfo%lon_c) + + END SUBROUTINE grid_concat_free_mem + +END MODULE MOD_Grid diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_IncompleteGamma.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_IncompleteGamma.F90 new file mode 100644 index 0000000000..2d8a195d55 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_IncompleteGamma.F90 @@ -0,0 +1,946 @@ +MODULE MOD_IncompleteGamma + + USE MOD_Precision, ONLY: r8 + IMPLICIT REAL(KIND=r8) (A-H,O-Z) + +! ALGORITHM 654, COLLECTED ALGORITHMS FROM ACM. +! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, +! VOL. 13, NO. 3, P. 318. + +CONTAINS + + SUBROUTINE GRATIO (A, X, ANS, QANS, IND) +! ---------------------------------------------------------------------- +! EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS +! P(A,X) AND Q(A,X) +! +! ---------- +! +! IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X +! ARE NOT BOTH 0. +! +! ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE +! P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER. +! IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS +! POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF +! IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE +! 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY +! IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT. +! +! ERROR RETURN ... +! ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE, +! WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT. +! P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN +! X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE. +! ---------------------------------------------------------------------- +! WRITTEN BY ALFRED H. MORRIS, JR. +! NAVAL SURFACE WEAPONS CENTER +! DAHLGREN, VIRGINIA +! -------------------- + REAL(r8) J, L, ACC0(3), BIG(3), E00(3), X00(3), WK(20) + REAL(r8) D0(13), D1(12), D2(10), D3(8), D4(6), D5(4), D6(2) +! -------------------- + DATA ACC0(1)/5.E-15/, ACC0(2)/5.E-7/, ACC0(3)/5.E-4/ + DATA BIG(1)/20.0/, BIG(2)/14.0/, BIG(3)/10.0/ + DATA E00(1)/.25E-3/, E00(2)/.25E-1/, E00(3)/.14/ + DATA X00(1)/31.0/, X00(2)/17.0/, X00(3)/9.7/ +! -------------------- +! ALOG10 = LN(10) +! RT2PIN = 1/SQRT(2*PI) +! RTPI = SQRT(PI) +! -------------------- + DATA ALOG10/2.30258509299405/ + DATA RT2PIN/.398942280401433/ + DATA RTPI /1.77245385090552/ + DATA THIRD /.333333333333333/ +! -------------------- + DATA D0(1) / .833333333333333E-01/, D0(2) /-.148148148148148E-01/, & + D0(3) / .115740740740741E-02/, D0(4) / .352733686067019E-03/, & + D0(5) /-.178755144032922E-03/, D0(6) / .391926317852244E-04/, & + D0(7) /-.218544851067999E-05/, D0(8) /-.185406221071516E-05/, & + D0(9) / .829671134095309E-06/, D0(10)/-.176659527368261E-06/, & + D0(11)/ .670785354340150E-08/, D0(12)/ .102618097842403E-07/, & + D0(13)/-.438203601845335E-08/ +! -------------------- + DATA D10 /-.185185185185185E-02/, D1(1) /-.347222222222222E-02/, & + D1(2) / .264550264550265E-02/, D1(3) /-.990226337448560E-03/, & + D1(4) / .205761316872428E-03/, D1(5) /-.401877572016461E-06/, & + D1(6) /-.180985503344900E-04/, D1(7) / .764916091608111E-05/, & + D1(8) /-.161209008945634E-05/, D1(9) / .464712780280743E-08/, & + D1(10)/ .137863344691572E-06/, D1(11)/-.575254560351770E-07/, & + D1(12)/ .119516285997781E-07/ +! -------------------- + DATA D20 / .413359788359788E-02/, D2(1) /-.268132716049383E-02/, & + D2(2) / .771604938271605E-03/, D2(3) / .200938786008230E-05/, & + D2(4) /-.107366532263652E-03/, D2(5) / .529234488291201E-04/, & + D2(6) /-.127606351886187E-04/, D2(7) / .342357873409614E-07/, & + D2(8) / .137219573090629E-05/, D2(9) /-.629899213838006E-06/, & + D2(10)/ .142806142060642E-06/ +! -------------------- + DATA D30 / .649434156378601E-03/, D3(1) / .229472093621399E-03/, & + D3(2) /-.469189494395256E-03/, D3(3) / .267720632062839E-03/, & + D3(4) /-.756180167188398E-04/, D3(5) /-.239650511386730E-06/, & + D3(6) / .110826541153473E-04/, D3(7) /-.567495282699160E-05/, & + D3(8) / .142309007324359E-05/ +! -------------------- + DATA D40 /-.861888290916712E-03/, D4(1) / .784039221720067E-03/, & + D4(2) /-.299072480303190E-03/, D4(3) /-.146384525788434E-05/, & + D4(4) / .664149821546512E-04/, D4(5) /-.396836504717943E-04/, & + D4(6) / .113757269706784E-04/ +! -------------------- + DATA D50 /-.336798553366358E-03/, D5(1) /-.697281375836586E-04/, & + D5(2) / .277275324495939E-03/, D5(3) /-.199325705161888E-03/, & + D5(4) / .679778047793721E-04/ +! -------------------- + DATA D60 / .531307936463992E-03/, D6(1) /-.592166437353694E-03/, & + D6(2) / .270878209671804E-03/ +! -------------------- + DATA D70 / .344367606892378E-03/ +! -------------------- +! ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST +! FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . +! +! E = SPMPAR(1) + E = epsilon(1._r8) +! +! -------------------- + IF (A .LT. 0.0 .OR. X .LT. 0.0) GO TO 400 + IF (A .EQ. 0.0 .AND. X .EQ. 0.0) GO TO 400 + IF (A*X .EQ. 0.0) GO TO 331 +! + IOP = IND + 1 + IF (IOP .NE. 1 .AND. IOP .NE. 2) IOP = 3 + ACC = DMAX1(ACC0(IOP),E) + E0 = E00(IOP) + X0 = X00(IOP) +! +! SELECT THE APPROPRIATE ALGORITHM +! + IF (A .GE. 1.0) GO TO 10 + IF (A .EQ. 0.5) GO TO 320 + IF (X .LT. 1.1) GO TO 110 + T1 = A*LOG(X) - X + U = A*EXP(T1) + IF (U .EQ. 0.0) GO TO 310 + R = U*(1.0 + GAM1(A)) + GO TO 170 +! + 10 IF (A .GE. BIG(IOP)) GO TO 20 + IF (A .GT. X .OR. X .GE. X0) GO TO 11 + TWOA = A + A + M = INT(TWOA) + IF (TWOA .NE. REAL(M, r8)) GO TO 11 + I = M/2 + IF (A .EQ. REAL(I, r8)) GO TO 140 + GO TO 150 + 11 T1 = A*LOG(X) - X + R = EXP(T1)/GAMMA(A) + GO TO 30 +! + 20 L = X/A + IF (L .EQ. 0.0) GO TO 300 + S = 0.5 + (0.5 - L) + Z = RLOG(L) + IF (Z .GE. 700.0/A) GO TO 330 + Y = A*Z + RTA = SQRT(A) + IF (ABS(S) .LE. E0/RTA) GO TO 250 + IF (ABS(S) .LE. 0.4) GO TO 200 +! + T = (1.0/A)**2 + T1 = (((0.75*T - 1.0)*T + 3.5)*T - 105.0)/(A*1260.0) + T1 = T1 - Y + R = RT2PIN*RTA*EXP(T1) +! + 30 IF (R .EQ. 0.0) GO TO 331 + IF (X .LE. DMAX1(A,ALOG10)) GO TO 50 + IF (X .LT. X0) GO TO 170 + GO TO 80 +! +! TAYLOR SERIES FOR P/R +! + 50 APN = A + 1.0 + T = X/APN + WK(1) = T + DO N = 2,20 + APN = APN + 1.0 + T = T*(X/APN) + IF (T .LE. 1.E-3) GO TO 60 + WK(N) = T + ENDDO + N = 20 +! + 60 SUM = T + TOL = 0.5*ACC + 61 APN = APN + 1.0 + T = T*(X/APN) + SUM = SUM + T + IF (T .GT. TOL) GO TO 61 +! + MAX = N - 1 + DO M = 1,MAX + N = N - 1 + SUM = SUM + WK(N) + ENDDO + ANS = (R/A)*(1.0 + SUM) + QANS = 0.5 + (0.5 - ANS) + RETURN +! +! ASYMPTOTIC EXPANSION +! + 80 AMN = A - 1.0 + T = AMN/X + WK(1) = T + DO N = 2,20 + AMN = AMN - 1.0 + T = T*(AMN/X) + IF (ABS(T) .LE. 1.E-3) GO TO 90 + WK(N) = T + ENDDO + N = 20 +! + 90 SUM = T + 91 IF (ABS(T) .LE. ACC) GO TO 100 + AMN = AMN - 1.0 + T = T*(AMN/X) + SUM = SUM + T + GO TO 91 +! + 100 MAX = N - 1 + DO M = 1,MAX + N = N - 1 + SUM = SUM + WK(N) + ENDDO + QANS = (R/X)*(1.0 + SUM) + ANS = 0.5 + (0.5 - QANS) + RETURN +! +! TAYLOR SERIES FOR P(A,X)/X**A +! + 110 AN = 3.0 + C = X + SUM = X/(A + 3.0) + TOL = 3.0*ACC/(A + 1.0) + 111 AN = AN + 1.0 + C = -C*(X/AN) + T = C/(A + AN) + SUM = SUM + T + IF (ABS(T) .GT. TOL) GO TO 111 + J = A*X*((SUM/6.0 - 0.5/(A + 2.0))*X + 1.0/(A + 1.0)) +! + Z = A*LOG(X) + H = GAM1(A) + G = 1.0 + H + IF (X .LT. 0.25) GO TO 120 + IF (A .LT. X/2.59) GO TO 135 + GO TO 130 + 120 IF (Z .GT. -.13394) GO TO 135 +! + 130 W = EXP(Z) + ANS = W*G*(0.5 + (0.5 - J)) + QANS = 0.5 + (0.5 - ANS) + RETURN +! + 135 L = REXP(Z) + W = 0.5 + (0.5 + L) + QANS = (W*J - L)*G - H + IF (QANS .LT. 0.0) GO TO 310 + ANS = 0.5 + (0.5 - QANS) + RETURN +! +! FINITE SUMS FOR Q WHEN A .GE. 1 +! AND 2*A IS AN INTEGER +! + 140 SUM = EXP(-X) + T = SUM + N = 1 + C = 0.0 + GO TO 160 +! + 150 RTX = SQRT(X) + SUM = ERFC1(0,RTX) + T = EXP(-X)/(RTPI*RTX) + N = 0 + C = -0.5 +! + 160 IF (N .EQ. I) GO TO 161 + N = N + 1 + C = C + 1.0 + T = (X*T)/C + SUM = SUM + T + GO TO 160 + 161 QANS = SUM + ANS = 0.5 + (0.5 - QANS) + RETURN +! +! CONTINUED FRACTION EXPANSION +! + 170 TOL = DMAX1(5.0_r8*E,ACC) + A2NM1 = 1.0 + A2N = 1.0 + B2NM1 = X + B2N = X + (1.0 - A) + C = 1.0 + 171 A2NM1 = X*A2N + C*A2NM1 + B2NM1 = X*B2N + C*B2NM1 + AM0 = A2NM1/B2NM1 + C = C + 1.0 + CMA = C - A + A2N = A2NM1 + CMA*A2N + B2N = B2NM1 + CMA*B2N + AN0 = A2N/B2N + IF (ABS(AN0 - AM0) .GE. TOL*AN0) GO TO 171 +! + QANS = R*AN0 + ANS = 0.5 + (0.5 - QANS) + RETURN +! +! GENERAL TEMME EXPANSION +! + 200 IF (ABS(S) .LE. 2.0*E .AND. A*E*E .GT. 3.28E-3) GO TO 400 + C = EXP(-Y) + W = 0.5*ERFC1(1,SQRT(Y)) + U = 1.0/A + Z = SQRT(Z + Z) + IF (L .LT. 1.0) Z = -Z + IF (IOP < 2) THEN + GO TO 210 + ELSEIF (IOP == 2) THEN + GO TO 220 + ELSE + GO TO 230 + ENDIF +! + 210 IF (ABS(S) .LE. 1.E-3) GO TO 260 + C0 = ((((((((((((D0(13) * Z + D0(12)) * Z + D0(11)) * Z & + + D0(10)) * Z + D0(9)) * Z + D0(8)) * Z + D0(7)) * Z & + + D0(6)) * Z + D0(5)) * Z + D0(4)) * Z + D0(3)) * Z & + + D0(2)) * Z + D0(1)) * Z - THIRD + C1 = (((((((((((D1(12) * Z + D1(11)) * Z + D1(10)) * Z & + + D1(9)) * Z + D1(8)) * Z + D1(7)) * Z + D1(6)) * Z & + + D1(5)) * Z + D1(4)) * Z + D1(3)) * Z + D1(2)) * Z & + + D1(1)) * Z + D10 + C2 = (((((((((D2(10) * Z + D2(9)) * Z + D2(8)) * Z & + + D2(7)) * Z + D2(6)) * Z + D2(5)) * Z + D2(4)) * Z & + + D2(3)) * Z + D2(2)) * Z + D2(1)) * Z + D20 + C3 = (((((((D3(8) * Z + D3(7)) * Z + D3(6)) * Z & + + D3(5)) * Z + D3(4)) * Z + D3(3)) * Z + D3(2)) * Z & + + D3(1)) * Z + D30 + C4 = (((((D4(6) * Z + D4(5)) * Z + D4(4)) * Z + D4(3)) * Z & + + D4(2)) * Z + D4(1)) * Z + D40 + C5 = (((D5(4) * Z + D5(3)) * Z + D5(2)) * Z + D5(1)) * Z & + + D50 + C6 = (D6(2) * Z + D6(1)) * Z + D60 + T = ((((((D70*U + C6)*U + C5)*U + C4)*U + C3)*U + C2)*U & + + C1)*U + C0 + GO TO 240 +! + 220 C0 = (((((D0(6) * Z + D0(5)) * Z + D0(4)) * Z + D0(3)) * Z & + + D0(2)) * Z + D0(1)) * Z - THIRD + C1 = (((D1(4) * Z + D1(3)) * Z + D1(2)) * Z + D1(1)) * Z & + + D10 + C2 = D2(1) * Z + D20 + T = (C2*U + C1)*U + C0 + GO TO 240 +! + 230 T = ((D0(3) * Z + D0(2)) * Z + D0(1)) * Z - THIRD +! + 240 IF (L .LT. 1.0) GO TO 241 + QANS = C*(W + RT2PIN*T/RTA) + ANS = 0.5 + (0.5 - QANS) + RETURN + 241 ANS = C*(W - RT2PIN*T/RTA) + QANS = 0.5 + (0.5 - ANS) + RETURN +! +! TEMME EXPANSION FOR L = 1 +! + 250 IF (A*E*E .GT. 3.28E-3) GO TO 400 + C = 0.5 + (0.5 - Y) + W = (0.5 - SQRT(Y)*(0.5 + (0.5 - Y/3.0))/RTPI)/C + U = 1.0/A + Z = SQRT(Z + Z) + IF (L .LT. 1.0) Z = -Z + IF (IOP < 2) THEN + GO TO 260 + ELSEIF (IOP == 2) THEN + GO TO 270 + ELSE + GO TO 280 + ENDIF +! + 260 C0 = ((((((D0(7) * Z + D0(6)) * Z + D0(5)) * Z + D0(4)) * Z & + + D0(3)) * Z + D0(2)) * Z + D0(1)) * Z - THIRD + C1 = (((((D1(6) * Z + D1(5)) * Z + D1(4)) * Z + D1(3)) * Z & + + D1(2)) * Z + D1(1)) * Z + D10 + C2 = ((((D2(5) * Z + D2(4)) * Z + D2(3)) * Z + D2(2)) * Z & + + D2(1)) * Z + D20 + C3 = (((D3(4) * Z + D3(3)) * Z + D3(2)) * Z + D3(1)) * Z & + + D30 + C4 = (D4(2) * Z + D4(1)) * Z + D40 + C5 = (D5(2) * Z + D5(1)) * Z + D50 + C6 = D6(1) * Z + D60 + T = ((((((D70*U + C6)*U + C5)*U + C4)*U + C3)*U + C2)*U & + + C1)*U + C0 + GO TO 240 +! + 270 C0 = (D0(2) * Z + D0(1)) * Z - THIRD + C1 = D1(1) * Z + D10 + T = (D20*U + C1)*U + C0 + GO TO 240 +! + 280 T = D0(1) * Z - THIRD + GO TO 240 +! +! SPECIAL CASES +! + 300 ANS = 0.0 + QANS = 1.0 + RETURN +! + 310 ANS = 1.0 + QANS = 0.0 + RETURN +! + 320 IF (X .GE. 0.25) GO TO 321 + ANS = ERF(SQRT(X)) + QANS = 0.5 + (0.5 - ANS) + RETURN + 321 QANS = ERFC1(0,SQRT(X)) + ANS = 0.5 + (0.5 - QANS) + RETURN +! + 330 IF (ABS(S) .LE. 2.0*E) GO TO 400 + 331 IF (X .LE. A) GO TO 300 + GO TO 310 +! +! ERROR RETURN +! + 400 ANS = 2.0 + RETURN + + END SUBROUTINE + + + + FUNCTION ERF(X) +! ****************************************************************** +! EVALUATION OF THE REAL ERROR FUNCTION +! ****************************************************************** + DIMENSION A(4),B(4),P(8),Q(8),R(5),S(5) + DATA A(1)/-1.65581836870402E-4/, A(2)/3.25324098357738E-2/, & + A(3)/1.02201136918406E-1/, A(4)/1.12837916709552E00/ + DATA B(1)/4.64988945913179E-3/, B(2)/7.01333417158511E-2/, & + B(3)/4.23906732683201E-1/, B(4)/1.00000000000000E00/ + DATA P(1)/-1.36864857382717E-7/, P(2)/5.64195517478974E-1/, & + P(3)/7.21175825088309E00/, P(4)/4.31622272220567E01/, & + P(5)/1.52989285046940E02/, P(6)/3.39320816734344E02/, & + P(7)/4.51918953711873E02/, P(8)/3.00459261020162E02/ + DATA Q(1)/1.00000000000000E00/, Q(2)/1.27827273196294E01/, & + Q(3)/7.70001529352295E01/, Q(4)/2.77585444743988E02/, & + Q(5)/6.38980264465631E02/, Q(6)/9.31354094850610E02/, & + Q(7)/7.90950925327898E02/, Q(8)/3.00459260956983E02/ + DATA R(1)/2.10144126479064E00/, R(2)/2.62370141675169E01/, & + R(3)/2.13688200555087E01/, R(4)/4.65807828718470E00/, & + R(5)/2.82094791773523E-1/ + DATA S(1)/9.41537750555460E01/, S(2)/1.87114811799590E02/, & + S(3)/9.90191814623914E01/, S(4)/1.80124575948747E01/, & + S(5)/1.00000000000000E00/ + DATA C/5.64189583547756E-1/ +! ------------------- + AX=ABS(X) + X2=AX*AX + IF (AX.GE.0.5) GO TO 10 + TOP=((A(1)*X2+A(2))*X2+A(3))*X2+A(4) + BOT=((B(1)*X2+B(2))*X2+B(3))*X2+B(4) + ERF=X*TOP/BOT + RETURN +! + 10 IF (AX.GT.4.0) GO TO 20 + TOP=((((((P(1)*AX+P(2))*AX+P(3))*AX+P(4))*AX+P(5))*AX & + +P(6))*AX+P(7))*AX+P(8) + BOT=((((((Q(1)*AX+Q(2))*AX+Q(3))*AX+Q(4))*AX+Q(5))*AX & + +Q(6))*AX+Q(7))*AX+Q(8) + ERF=1.0-EXP(-X2)*TOP/BOT + IF (X.LT.0.0) ERF=-ERF + RETURN +! + 20 ERF=1.0 + IF (AX.GE.5.54) GO TO 21 + T=1.0/X2 + TOP=(((R(1)*T+R(2))*T+R(3))*T+R(4))*T+R(5) + BOT=(((S(1)*T+S(2))*T+S(3))*T+S(4))*T+S(5) + ERF=C-TOP/(X2*BOT) + ERF=1.0-EXP(-X2)*ERF/AX + 21 IF (X.LT.0.0) ERF=-ERF + RETURN + + END FUNCTION + + + + REAL(r8) FUNCTION ERFC1(IND,X) +! ---------------------------------------------------------------------- +! EVALUATION OF THE REAL COMPLEMENTARY ERROR FUNCTION +! +! ERFC1(IND,X) = ERFC(X) IF IND = 0 +! ERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE +! ---------------------------------------------------------------------- + DIMENSION A(4),B(4),P(8),Q(8),R(5),S(5) + DATA A(1)/-1.65581836870402E-4/, A(2)/3.25324098357738E-2/, & + A(3)/1.02201136918406E-1/, A(4)/1.12837916709552E00/ + DATA B(1)/4.64988945913179E-3/, B(2)/7.01333417158511E-2/, & + B(3)/4.23906732683201E-1/, B(4)/1.00000000000000E00/ + DATA P(1)/-1.36864857382717E-7/, P(2)/5.64195517478974E-1/, & + P(3)/7.21175825088309E00/, P(4)/4.31622272220567E01/, & + P(5)/1.52989285046940E02/, P(6)/3.39320816734344E02/, & + P(7)/4.51918953711873E02/, P(8)/3.00459261020162E02/ + DATA Q(1)/1.00000000000000E00/, Q(2)/1.27827273196294E01/, & + Q(3)/7.70001529352295E01/, Q(4)/2.77585444743988E02/, & + Q(5)/6.38980264465631E02/, Q(6)/9.31354094850610E02/, & + Q(7)/7.90950925327898E02/, Q(8)/3.00459260956983E02/ + DATA R(1)/2.10144126479064E00/, R(2)/2.62370141675169E01/, & + R(3)/2.13688200555087E01/, R(4)/4.65807828718470E00/, & + R(5)/2.82094791773523E-1/ + DATA S(1)/9.41537750555460E01/, S(2)/1.87114811799590E02/, & + S(3)/9.90191814623914E01/, S(4)/1.80124575948747E01/, & + S(5)/1.00000000000000E00/ + DATA C/5.64189583547756E-1/ +! ------------------- + AX=ABS(X) + X2=AX*AX + IF (AX.GE.0.47) GO TO 10 + TOP=((A(1)*X2+A(2))*X2+A(3))*X2+A(4) + BOT=((B(1)*X2+B(2))*X2+B(3))*X2+B(4) + ERFC1=1.0-X*TOP/BOT + IF (IND.NE.0) ERFC1=EXP(X2)*ERFC1 + RETURN +! + 10 IF (AX.GT.4.0) GO TO 20 + TOP=((((((P(1)*AX+P(2))*AX+P(3))*AX+P(4))*AX+P(5))*AX & + +P(6))*AX+P(7))*AX+P(8) + BOT=((((((Q(1)*AX+Q(2))*AX+Q(3))*AX+Q(4))*AX+Q(5))*AX & + +Q(6))*AX+Q(7))*AX+Q(8) + ERFC1=TOP/BOT + IF (IND.EQ.0) GO TO 11 + IF (X.LT.0.0) ERFC1=2.0*EXP(X2)-ERFC1 + RETURN + 11 ERFC1=EXP(-X2)*ERFC1 + IF (X.LT.0.0) ERFC1=2.0-ERFC1 + RETURN +! + 20 IF (X.LE.-5.33) GO TO 30 + T=1.0/X2 + TOP=(((R(1)*T+R(2))*T+R(3))*T+R(4))*T+R(5) + BOT=(((S(1)*T+S(2))*T+S(3))*T+S(4))*T+S(5) + ERFC1=(C-TOP/(X2*BOT))/AX + IF (IND.EQ.0) GO TO 11 + IF (X.LT.0.0) ERFC1=2.0*EXP(X2)-ERFC1 + RETURN +! + 30 ERFC1=2.0 + IF (IND.NE.0) ERFC1=EXP(X2)*ERFC1 + RETURN + + END FUNCTION + + + + REAL(r8) FUNCTION REXP(X) +! ------------------------------------------------------------------ +! COMPUTATION OF EXP(X) - 1 +! ------------------------------------------------------------------ + DATA P1/ .914041914819518E-09/, P2/ .238082361044469E-01/, & + Q1/-.499999999085958E+00/, Q2/ .107141568980644E+00/, & + Q3/-.119041179760821E-01/, Q4/ .595130811860248E-03/ +! ------------------ + IF (ABS(X) .GT. 0.15) GO TO 10 + REXP = X*(((P2*X + P1)*X + 1.0)/((((Q4*X + Q3)*X + Q2)*X & + + Q1)*X + 1.0)) + RETURN +! + 10 W = EXP(X) + IF (X .GT. 0.0) GO TO 20 + REXP = (W - 0.5) - 0.5 + RETURN + 20 REXP = W*(0.5 + (0.5 - 1.0/W)) + RETURN + END FUNCTION + + + + REAL(r8) FUNCTION RLOG(X) +! ------------------- +! COMPUTATION OF X - 1 - LN(X) +! ------------------- + DATA A/.566749439387324E-01/ + DATA B/.456512608815524E-01/ +! ------------------- + DATA P0/ .333333333333333E+00/, P1/-.224696413112536E+00/, & + P2/ .620886815375787E-02/ + DATA Q1/-.127408923933623E+01/, Q2/ .354508718369557E+00/ +! ------------------- + IF (X .LT. 0.61 .OR. X .GT. 1.57) GO TO 100 + IF (X .LT. 0.82) GO TO 10 + IF (X .GT. 1.18) GO TO 20 +! +! ARGUMENT REDUCTION +! + U = (X - 0.5) - 0.5 + W1 = 0.0 + GO TO 30 +! + 10 U = DBLE(X) - 0.7D0 + U = U/0.7 + W1 = A - U*0.3 + GO TO 30 +! + 20 U = 0.75D0*DBLE(X) - 1.D0 + W1 = B + U/3.0 +! +! SERIES EXPANSION +! + 30 R = U/(U + 2.0) + T = R*R + W = ((P2*T + P1)*T + P0)/((Q2*T + Q1)*T + 1.0) + RLOG = 2.0*T*(1.0/(1.0 - R) - R*W) + W1 + RETURN +! +! + 100 R = (X - 0.5) - 0.5 + RLOG = R - LOG(X) + RETURN + + END FUNCTION + + + + REAL(r8) FUNCTION GAMMA(A) +!----------------------------------------------------------------------- +! +! EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS +! +! ----------- +! +! GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT +! BE COMPUTED. +! +!----------------------------------------------------------------------- +! WRITTEN BY ALFRED H. MORRIS, JR. +! NAVAL SURFACE WEAPONS CENTER +! DAHLGREN, VIRGINIA +!----------------------------------------------------------------------- + REAL(r8) P(7), Q(7) + DOUBLE PRECISION D, G, Z, LNX +!-------------------------- +! D = 0.5*(LN(2*PI) - 1) +!-------------------------- + DATA PI /3.1415926535898/ + DATA D /.41893853320467274178D0/ +!-------------------------- + DATA P(1)/ .539637273585445E-03/, P(2)/ .261939260042690E-02/, & + P(3)/ .204493667594920E-01/, P(4)/ .730981088720487E-01/, & + P(5)/ .279648642639792E+00/, P(6)/ .553413866010467E+00/, & + P(7)/ 1.0/ + DATA Q(1)/-.832979206704073E-03/, Q(2)/ .470059485860584E-02/, & + Q(3)/ .225211131035340E-01/, Q(4)/-.170458969313360E+00/, & + Q(5)/-.567902761974940E-01/, Q(6)/ .113062953091122E+01/, & + Q(7)/ 1.0/ +!-------------------------- + DATA R1/.820756370353826E-03/, R2/-.595156336428591E-03/, & + R3/.793650663183693E-03/, R4/-.277777777770481E-02/, & + R5/.833333333333333E-01/ +!-------------------------- + GAMMA = 0.0 + X = A + IF (ABS(A) .GE. 15.0) GO TO 60 +!----------------------------------------------------------------------- +! EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15 +!----------------------------------------------------------------------- + T = 1.0 + M = INT(A) - 1 +! +! LET T BE THE PRODUCT OF A-J WHEN A .GE. 2 +! + IF (M < 0) THEN + GO TO 20 + ELSEIF (M == 0) THEN + GO TO 12 + ELSE + GO TO 10 + ENDIF + + 10 DO J = 1,M + X = X - 1.0 + T = X*T + ENDDO + 12 X = X - 1.0 + GO TO 40 +! +! LET T BE THE PRODUCT OF A+J WHEN A .LT. 1 +! + 20 T = A + IF (A .GT. 0.0) GO TO 30 + M = - M - 1 + IF (M .EQ. 0) GO TO 22 + DO J = 1,M + X = X + 1.0 + T = X*T + ENDDO + 22 X = (X + 0.5) + 0.5 + T = X*T + IF (T .EQ. 0.0) RETURN +! + 30 CONTINUE +! +! THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS +! CODE MAY BE OMITTED IF DESIRED. +! + IF (ABS(T) .GE. 1.E-30) GO TO 40 +! IF (ABS(T)*SPMPAR(3) .LE. 1.0001) RETURN + IF (ABS(T)*HUGE(1._r8) .LE. 1.0001) RETURN + GAMMA = 1.0/T + RETURN +! +! COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1 +! + 40 TOP = P(1) + BOT = Q(1) + DO I = 2,7 + TOP = P(I) + X*TOP + BOT = Q(I) + X*BOT + ENDDO + GAMMA = TOP/BOT +! +! TERMINATION +! + IF (A .LT. 1.0) GO TO 50 + GAMMA = GAMMA*T + RETURN + 50 GAMMA = GAMMA/T + RETURN +!----------------------------------------------------------------------- +! EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15 +!----------------------------------------------------------------------- + 60 IF (ABS(A) .GE. 1.E3) RETURN + IF (A .GT. 0.0) GO TO 70 + X = -A + N = X + T = X - N + IF (T .GT. 0.9) T = 1.0 - T + S = SIN(PI*T)/PI + IF (MOD(N,2) .EQ. 0) S = -S + IF (S .EQ. 0.0) RETURN +! +! COMPUTE THE MODIFIED ASYMPTOTIC SUM +! + 70 T = 1.0/(X*X) + G = ((((R1*T + R2)*T + R3)*T + R4)*T + R5)/X +! +! ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X) +! BUT LESS ACCURACY WILL NORMALLY BE OBTAINED. +! + LNX = GLOG(X) +! +! FINAL ASSEMBLY +! + Z = X + G = (D + G) + (Z - 0.5D0)*(LNX - 1.D0) + W = G + T = G - DBLE(W) + IF (W .GT. 0.99999*EXPARG(0)) RETURN + GAMMA = EXP(W)*(1.0 + T) + IF (A .LT. 0.0) GAMMA = (1.0/(GAMMA*S))/X + RETURN + + END FUNCTION + + + + DOUBLE PRECISION FUNCTION GLOG(X) +! ------------------- +! EVALUATION OF LN(X) FOR X .GE. 15 +! ------------------- + REAL(r8) X + DOUBLE PRECISION Z, W(163) +! ------------------- + DATA C1/.286228750476730/, C2/.399999628131494/, & + C3/.666666666752663/ +! ------------------- +! W(J) = LN(J + 14) FOR EACH J +! ------------------- + DATA W(1) /.270805020110221007D+01/, & + W(2) /.277258872223978124D+01/, W(3) /.283321334405621608D+01/, & + W(4) /.289037175789616469D+01/, W(5) /.294443897916644046D+01/, & + W(6) /.299573227355399099D+01/, W(7) /.304452243772342300D+01/, & + W(8) /.309104245335831585D+01/, W(9) /.313549421592914969D+01/, & + W(10)/.317805383034794562D+01/, W(11)/.321887582486820075D+01/, & + W(12)/.325809653802148205D+01/, W(13)/.329583686600432907D+01/, & + W(14)/.333220451017520392D+01/, W(15)/.336729582998647403D+01/, & + W(16)/.340119738166215538D+01/, W(17)/.343398720448514625D+01/, & + W(18)/.346573590279972655D+01/, W(19)/.349650756146648024D+01/, & + W(20)/.352636052461616139D+01/, W(21)/.355534806148941368D+01/, & + W(22)/.358351893845611000D+01/, W(23)/.361091791264422444D+01/, & + W(24)/.363758615972638577D+01/, W(25)/.366356164612964643D+01/, & + W(26)/.368887945411393630D+01/, W(27)/.371357206670430780D+01/, & + W(28)/.373766961828336831D+01/, W(29)/.376120011569356242D+01/, & + W(30)/.378418963391826116D+01/ + DATA W(31)/.380666248977031976D+01/, & + W(32)/.382864139648909500D+01/, W(33)/.385014760171005859D+01/, & + W(34)/.387120101090789093D+01/, W(35)/.389182029811062661D+01/, & + W(36)/.391202300542814606D+01/, W(37)/.393182563272432577D+01/, & + W(38)/.395124371858142735D+01/, W(39)/.397029191355212183D+01/, & + W(40)/.398898404656427438D+01/, W(41)/.400733318523247092D+01/, & + W(42)/.402535169073514923D+01/, W(43)/.404305126783455015D+01/, & + W(44)/.406044301054641934D+01/, W(45)/.407753744390571945D+01/, & + W(46)/.409434456222210068D+01/, W(47)/.411087386417331125D+01/, & + W(48)/.412713438504509156D+01/, W(49)/.414313472639153269D+01/, & + W(50)/.415888308335967186D+01/, W(51)/.417438726989563711D+01/, & + W(52)/.418965474202642554D+01/, W(53)/.420469261939096606D+01/, & + W(54)/.421950770517610670D+01/, W(55)/.423410650459725938D+01/, & + W(56)/.424849524204935899D+01/, W(57)/.426267987704131542D+01/, & + W(58)/.427666611901605531D+01/, W(59)/.429045944114839113D+01/, & + W(60)/.430406509320416975D+01/ + DATA W(61)/.431748811353631044D+01/, & + W(62)/.433073334028633108D+01/, W(63)/.434380542185368385D+01/, & + W(64)/.435670882668959174D+01/, W(65)/.436944785246702149D+01/, & + W(66)/.438202663467388161D+01/, W(67)/.439444915467243877D+01/, & + W(68)/.440671924726425311D+01/, W(69)/.441884060779659792D+01/, & + W(70)/.443081679884331362D+01/, W(71)/.444265125649031645D+01/, & + W(72)/.445434729625350773D+01/, W(73)/.446590811865458372D+01/, & + W(74)/.447733681447820647D+01/, W(75)/.448863636973213984D+01/, & + W(76)/.449980967033026507D+01/, W(77)/.451085950651685004D+01/, & + W(78)/.452178857704904031D+01/, W(79)/.453259949315325594D+01/, & + W(80)/.454329478227000390D+01/, W(81)/.455387689160054083D+01/, & + W(82)/.456434819146783624D+01/, W(83)/.457471097850338282D+01/, & + W(84)/.458496747867057192D+01/, W(85)/.459511985013458993D+01/, & + W(86)/.460517018598809137D+01/, W(87)/.461512051684125945D+01/, & + W(88)/.462497281328427108D+01/, W(89)/.463472898822963577D+01/, & + W(90)/.464439089914137266D+01/ + DATA W(91) /.465396035015752337D+01/, & + W(92) /.466343909411206714D+01/, W(93) /.467282883446190617D+01/, & + W(94) /.468213122712421969D+01/, W(95) /.469134788222914370D+01/, & + W(96) /.470048036579241623D+01/, W(97) /.470953020131233414D+01/, & + W(98) /.471849887129509454D+01/, W(99) /.472738781871234057D+01/, & + W(100)/.473619844839449546D+01/, W(101)/.474493212836325007D+01/, & + W(102)/.475359019110636465D+01/, W(103)/.476217393479775612D+01/, & + W(104)/.477068462446566476D+01/, W(105)/.477912349311152939D+01/, & + W(106)/.478749174278204599D+01/, W(107)/.479579054559674109D+01/, & + W(108)/.480402104473325656D+01/, W(109)/.481218435537241750D+01/, & + W(110)/.482028156560503686D+01/, W(111)/.482831373730230112D+01/, & + W(112)/.483628190695147800D+01/, W(113)/.484418708645859127D+01/, & + W(114)/.485203026391961717D+01/, W(115)/.485981240436167211D+01/, & + W(116)/.486753445045558242D+01/, W(117)/.487519732320115154D+01/, & + W(118)/.488280192258637085D+01/, W(119)/.489034912822175377D+01/, & + W(120)/.489783979995091137D+01/ + DATA W(121)/.490527477843842945D+01/, & + W(122)/.491265488573605201D+01/, W(123)/.491998092582812492D+01/, & + W(124)/.492725368515720469D+01/, W(125)/.493447393313069176D+01/, & + W(126)/.494164242260930430D+01/, W(127)/.494875989037816828D+01/, & + W(128)/.495582705760126073D+01/, W(129)/.496284463025990728D+01/, & + W(130)/.496981329957600062D+01/, W(131)/.497673374242057440D+01/, & + W(132)/.498360662170833644D+01/, W(133)/.499043258677873630D+01/, & + W(134)/.499721227376411506D+01/, W(135)/.500394630594545914D+01/, & + W(136)/.501063529409625575D+01/, W(137)/.501727983681492433D+01/, & + W(138)/.502388052084627639D+01/, W(139)/.503043792139243546D+01/, & + W(140)/.503695260241362916D+01/, W(141)/.504342511691924662D+01/, & + W(142)/.504985600724953705D+01/, W(143)/.505624580534830806D+01/, & + W(144)/.506259503302696680D+01/, W(145)/.506890420222023153D+01/, & + W(146)/.507517381523382692D+01/, W(147)/.508140436498446300D+01/, & + W(148)/.508759633523238407D+01/, W(149)/.509375020080676233D+01/, & + W(150)/.509986642782419842D+01/ + DATA W(151)/.510594547390058061D+01/, & + W(152)/.511198778835654323D+01/, W(153)/.511799381241675511D+01/, & + W(154)/.512396397940325892D+01/, W(155)/.512989871492307347D+01/, & + W(156)/.513579843705026176D+01/, W(157)/.514166355650265984D+01/, & + W(158)/.514749447681345304D+01/, W(159)/.515329159449777895D+01/, & + W(160)/.515905529921452903D+01/, W(161)/.516478597392351405D+01/, & + W(162)/.517048399503815178D+01/, W(163)/.517614973257382914D+01/ +! + IF (X .GE. 178.0) GO TO 10 + N = X + T = (X - N)/(X + N) + T2 = T*T + Z = (((C1*T2 + C2)*T2 + C3)*T2 + 2.0)*T + GLOG = W(N - 14) + Z + RETURN +! + 10 GLOG = LOG(X) + RETURN + + END FUNCTION + + + + REAL(r8) FUNCTION EXPARG (IDUMMY) +!-------------------------------------------------------------------- +! COMPUTATION OF THE LARGEST ARGUMENT W FOR WHICH EXP(W) +! MAY BE COMPUTED. (ONLY AN APPROXIMATE VALUE IS NEEDED.) +!-------------------------------------------------------------------- +! EXPARG = 0.99999*ALOG(SPMPAR(3)) + EXPARG = 0.99999*LOG(HUGE(1._r8)) + RETURN + END + + + + REAL(r8) FUNCTION GAM1(A) +! ------------------------------------------------------------------ +! COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5 +! ------------------------------------------------------------------ + REAL(r8) P(7), Q(5), R(9) +! ------------------- + DATA P(1)/ .577215664901533E+00/, P(2)/-.409078193005776E+00/, & + P(3)/-.230975380857675E+00/, P(4)/ .597275330452234E-01/, & + P(5)/ .766968181649490E-02/, P(6)/-.514889771323592E-02/, & + P(7)/ .589597428611429E-03/ +! ------------------- + DATA Q(1)/ .100000000000000E+01/, Q(2)/ .427569613095214E+00/, & + Q(3)/ .158451672430138E+00/, Q(4)/ .261132021441447E-01/, & + Q(5)/ .423244297896961E-02/ +! ------------------- + DATA R(1)/-.422784335098468E+00/, R(2)/-.771330383816272E+00/, & + R(3)/-.244757765222226E+00/, R(4)/ .118378989872749E+00/, & + R(5)/ .930357293360349E-03/, R(6)/-.118290993445146E-01/, & + R(7)/ .223047661158249E-02/, R(8)/ .266505979058923E-03/, & + R(9)/-.132674909766242E-03/ +! ------------------- + DATA S1 / .273076135303957E+00/, S2 / .559398236957378E-01/ +! ------------------- + T = A + D = A - 0.5 + IF (D .GT. 0.0) T = D - 0.5 + IF (T < 0) THEN + GO TO 30 + ELSEIF (T == 0) THEN + GO TO 10 + ELSE + GO TO 20 + ENDIF +! + 10 GAM1 = 0.0 + RETURN +! + 20 TOP = (((((P(7)*T + P(6))*T + P(5))*T + P(4))*T + P(3))*T & + + P(2))*T + P(1) + BOT = (((Q(5)*T + Q(4))*T + Q(3))*T + Q(2))*T + 1.0 + W = TOP/BOT + IF (D .GT. 0.0) GO TO 21 + GAM1 = A*W + RETURN + 21 GAM1 = (T/A)*((W - 0.5) - 0.5) + RETURN +! + 30 TOP = (((((((R(9)*T + R(8))*T + R(7))*T + R(6))*T + R(5))*T & + + R(4))*T + R(3))*T + R(2))*T + R(1) + BOT = (S2*T + S1)*T + 1.0 + W = TOP/BOT + IF (D .GT. 0.0) GO TO 31 + GAM1 = A*((W + 0.5) + 0.5) + RETURN + 31 GAM1 = T*W/A + RETURN + + END FUNCTION + +END MODULE MOD_IncompleteGamma diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90 new file mode 100644 index 0000000000..22710badca --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90 @@ -0,0 +1,87 @@ +#include + +MODULE MOD_LandElm + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Build pixelset "landelm". +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant Function Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! "landelm" refers to pixelset ELEMENT. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + USE MOD_Pixelset + IMPLICIT NONE + + ! ---- Instance ---- + type(pixelset_type) :: landelm + +CONTAINS + + ! ------------------------------- + SUBROUTINE landelm_build + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Mesh + IMPLICIT NONE + + ! Local Variables + integer :: ielm, nelm_glb + + IF (mpas_is_root) THEN + write(*,'(A)') 'Making land elements:' + ENDIF + + IF (.true.) THEN + + allocate (landelm%eindex (numelm)) + allocate (landelm%ipxstt (numelm)) + allocate (landelm%ipxend (numelm)) + allocate (landelm%settyp (numelm)) + allocate (landelm%ielm (numelm)) + + DO ielm = 1, numelm + landelm%eindex(ielm) = mesh(ielm)%indx + landelm%ipxstt(ielm) = 1 + landelm%ipxend(ielm) = mesh(ielm)%npxl + landelm%settyp(ielm) = 0 + landelm%ielm (ielm) = ielm + ENDDO + + ENDIF + + landelm%nset = numelm + CALL landelm%set_vecgs + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('land-element count reduction entry') + + IF (.true.) THEN + CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('land-element count reduction') + IF (mpas_rank == 0) THEN + write(*,'(A,I12,A)') 'Total: ', nelm_glb, ' elements.' + ENDIF + ENDIF + + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('land-element construction completion') +#else + write(*,'(A,I12,A)') 'Total: ', numelm, ' elements.' +#endif + + END SUBROUTINE landelm_build + +END MODULE MOD_LandElm diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90 new file mode 100644 index 0000000000..cf95355f2b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90 @@ -0,0 +1,119 @@ +#include + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + +MODULE MOD_LandPFT + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Build pixelset "landpft" (Plant Function Type). +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant Function Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! "landpft" refers to pixelset PFT. +! +! Created by Shupeng Zhang, May 2023 +! porting codes from Hua Yuan's OpenMP version to MPI parallel version. +!----------------------------------------------------------------------- + + USE MOD_Namelist + USE MOD_Pixelset + USE MOD_Const_LC + USE MOD_Vars_Global + IMPLICIT NONE + + ! ---- Instance ---- + integer :: numpft + type(pixelset_type) :: landpft + + integer , allocatable :: pft2patch (:) !patch index of a PFT + integer , allocatable :: patch_pft_s (:) !start PFT index of a patch + integer , allocatable :: patch_pft_e (:) !end PFT index of a patch + +CONTAINS + + ! ------------------------------- + + ! ---------------------- + SUBROUTINE map_patch_to_pft + + USE MOD_MPAS_MPI + USE MOD_LandPatch + USE MOD_Const_LC + IMPLICIT NONE + + integer :: ipatch, ipft + + IF (.true.) THEN + + IF (allocated(patch_pft_s)) deallocate(patch_pft_s) + IF (allocated(patch_pft_e)) deallocate(patch_pft_e) + IF (allocated(pft2patch )) deallocate(pft2patch ) + + IF (numpatch <= 0 .and. numpft > 0) THEN + CALL CoLM_stop('CoLM has PFT/PC entries on a rank with no loaded patches.') + ENDIF + IF (numpatch <= 0) RETURN + + allocate (patch_pft_s (numpatch)) + allocate (patch_pft_e (numpatch)) + allocate (pft2patch (numpft )) + patch_pft_s(:) = -1 + patch_pft_e(:) = -1 + pft2patch(:) = -1 + + ipft = 1 + DO ipatch = 1, numpatch +#ifndef CROP + IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN +#else + IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN +#endif + + patch_pft_s(ipatch) = ipft + + DO WHILE (ipft <= numpft) + IF ((landpft%eindex(ipft) == landpatch%eindex(ipatch)) & + .and. (landpft%ipxstt(ipft) == landpatch%ipxstt(ipatch)) & + .and. (landpft%settyp(ipft) < N_PFT)) THEN + pft2patch (ipft ) = ipatch + patch_pft_e(ipatch) = ipft + ipft = ipft + 1 + ELSE + EXIT + ENDIF + ENDDO + IF (patch_pft_e(ipatch) < patch_pft_s(ipatch)) THEN + CALL CoLM_stop('A vegetated CoLM patch has no matching PFT/PC state.') + ENDIF +#ifdef CROP + ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN + IF (ipft > numpft) CALL CoLM_stop('A CoLM crop patch has no matching PFT state.') + patch_pft_s(ipatch) = ipft + patch_pft_e(ipatch) = ipft + pft2patch (ipft ) = ipatch + ipft = ipft + 1 +#endif + ELSE + patch_pft_s(ipatch) = -1 + patch_pft_e(ipatch) = -1 + ENDIF + + ENDDO + IF (ipft /= numpft + 1 .or. any(pft2patch < 1)) THEN + CALL CoLM_stop('CoLM PFT/PC entries do not map one-to-one onto loaded patches.') + ENDIF + + ENDIF + + END SUBROUTINE map_patch_to_pft + +END MODULE MOD_LandPFT +#endif diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90 new file mode 100644 index 0000000000..fb7fe94a49 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90 @@ -0,0 +1,46 @@ +#include + +MODULE MOD_LandPatch + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Build pixelset "landpatch". +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant Function Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! "landpatch" refers to pixelset PATCH. +! +! Created by Shupeng Zhang, May 2023 +! porting codes from Hua Yuan's OpenMP version to MPI parallel version. +!----------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_Vars_Global + USE MOD_Const_LC + IMPLICIT NONE + + ! ---- Instance ---- + integer :: numpatch + type(grid_type) :: grid_patch + type(pixelset_type) :: landpatch + + type(subset_type) :: elm_patch + type(superset_type) :: patch2elm + +#ifdef CATCHMENT + type(subset_type) :: hru_patch + type(superset_type) :: patch2hru +#endif + + + +END MODULE MOD_LandPatch diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90 new file mode 100644 index 0000000000..6f5469ca8d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90 @@ -0,0 +1,73 @@ +#include + +MODULE MOD_LandUrban +!----------------------------------------------------------------------- +! +! !DESCRIPTION: +! Build pixelset "landurban". +! +! Original authors: Hua Yuan and Wenzong Dong, 2021, OpenMP version. +! +! +! !REVISIONS: +! 05/2023, Wenzong Dong, Hua Yuan, Shupeng Zhang: porting codes to MPI +! parallel version. +! +!----------------------------------------------------------------------- + + USE MOD_Grid + USE MOD_Pixelset + USE MOD_Vars_Global, only: N_URB, URBAN + + IMPLICIT NONE + + ! ---- Instance ---- + type(grid_type) :: grid_urban + + integer :: numurban + type(pixelset_type) :: landurban + + integer , allocatable :: urban_reg (:) !region index of a urban + integer , allocatable :: urban2patch (:) !patch index of a urban + integer , allocatable :: patch2urban (:) !urban index of a patch + + PUBLIC :: map_patch_to_urban + +CONTAINS + + ! ------------------------------- + + ! ---------------------- + SUBROUTINE map_patch_to_urban + + USE MOD_MPAS_MPI + USE MOD_LandPatch + IMPLICIT NONE + + integer :: ipatch, iurban + + IF (.true.) THEN + + IF ((numpatch <= 0) .or. (numurban <= 0)) RETURN + + IF (allocated(patch2urban)) deallocate(patch2urban) + IF (allocated(urban2patch)) deallocate(urban2patch) + allocate (patch2urban (numpatch)) + allocate (urban2patch (numurban)) + + iurban = 0 + DO ipatch = 1, numpatch + IF (landpatch%settyp(ipatch) == URBAN) THEN + iurban = iurban + 1 + patch2urban(ipatch) = iurban + urban2patch(iurban) = ipatch + ELSE + patch2urban(ipatch) = -1 + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE map_patch_to_urban + +END MODULE MOD_LandUrban diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_MPAS_MPI.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_MPAS_MPI.F90 new file mode 100644 index 0000000000..590f288c45 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_MPAS_MPI.F90 @@ -0,0 +1,115 @@ +#include + +MODULE MOD_MPAS_MPI + +!----------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! MPAS owns MPI initialization, finalization, and domain decomposition. +! Embedded CoLM never creates a process pool or reserves additional ranks. +! Every MPAS rank advances its locally owned CoLM elements, with rank 0 used +! only as a collective root for logging and scalar metadata. +! +! CoLM element ownership is supplied by MPAS cell ownership. Patch/PFT state +! remains internal to CoLM and is mapped back to the owning element/cell by CoLM. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------------------------- + + USE mpi + USE MOD_Precision + IMPLICIT NONE + + integer, parameter :: mpas_root = 0 + + logical :: mpas_is_root = .false. + + ! mpas_comm is borrowed from the MPAS LSM driver and never duplicated or + ! freed here. MPAS owns the isolated message context and its lifetime. + integer :: mpas_comm = MPI_COMM_NULL + integer :: mpas_rank = -1 + integer :: mpas_size = 0 + + integer :: mpas_status (MPI_STATUS_SIZE) + integer :: mpas_mpi_ierr = 0 + + integer, PUBLIC, parameter :: mpi_tag_size = 1 + integer, PUBLIC, parameter :: mpi_tag_mesg = 2 + integer, PUBLIC, parameter :: mpi_tag_data = 3 + + PUBLIC :: mpas_mpi_attach + PUBLIC :: mpas_mpi_detach + PUBLIC :: mpas_mpi_check + +CONTAINS + + !----------------------------------------- + SUBROUTINE mpas_mpi_attach (mpas_domain_comm) + + IMPLICIT NONE + integer, intent(in) :: mpas_domain_comm + IF (mpas_domain_comm == MPI_COMM_NULL) STOP 'MPAS supplied MPI_COMM_NULL to embedded CoLM.' + IF (mpas_comm /= MPI_COMM_NULL) CALL CoLM_stop('Embedded CoLM communicator was initialized more than once.') + + mpas_comm = mpas_domain_comm + + CALL mpi_comm_rank (mpas_comm, mpas_rank, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_stop('Embedded CoLM could not query its MPAS communicator rank.') + CALL mpi_comm_size (mpas_comm, mpas_size, mpas_mpi_ierr) + IF (mpas_mpi_ierr /= MPI_SUCCESS) CALL CoLM_stop('Embedded CoLM could not query its MPAS communicator size.') + IF (mpas_size < 1 .or. mpas_rank < 0 .or. mpas_rank >= mpas_size) THEN + CALL CoLM_stop('Embedded CoLM received an invalid MPAS communicator rank or size.') + ENDIF + + mpas_is_root = (mpas_rank == mpas_root) + + END SUBROUTINE mpas_mpi_attach + + !----------------------------------------- + SUBROUTINE mpas_mpi_detach + + mpas_comm = MPI_COMM_NULL + mpas_rank = -1 + mpas_size = 0 + mpas_is_root = .false. + + END SUBROUTINE mpas_mpi_detach + + !----------------------------------------- + SUBROUTINE mpas_mpi_check (operation) + + IMPLICIT NONE + character(len=*), intent(in) :: operation + + IF (mpas_mpi_ierr /= MPI_SUCCESS) THEN + CALL CoLM_stop('Embedded CoLM MPI failure during '//trim(operation)//'.') + ENDIF + + END SUBROUTINE mpas_mpi_check + + ! -- STOP all processes -- + SUBROUTINE CoLM_stop (mesg) + + IMPLICIT NONE + character(len=*), optional :: mesg + logical :: mpi_inited + logical :: mpi_is_finalized + integer :: ierr_local + + IF (present(mesg)) write(*,*) trim(mesg) + + ierr_local = MPI_SUCCESS + CALL MPI_INITIALIZED (mpi_inited, ierr_local) + mpi_is_finalized = .false. + IF (ierr_local == MPI_SUCCESS .and. mpi_inited) THEN + CALL MPI_FINALIZED (mpi_is_finalized, ierr_local) + ENDIF + IF (ierr_local == MPI_SUCCESS .and. mpi_inited .and. (.not. mpi_is_finalized)) THEN + IF (mpas_comm /= MPI_COMM_NULL) CALL mpi_abort (mpas_comm, 1, ierr_local) + ENDIF + + STOP + + END SUBROUTINE CoLM_stop + +END MODULE MOD_MPAS_MPI diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 new file mode 100644 index 0000000000..f0efc8645b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90 @@ -0,0 +1,137 @@ +#include + +MODULE MOD_Mesh + +!------------------------------------------------------------------------------------ +! !DESCRIPTION: +! +! MESH refers to the set of largest elements in CoLM. +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant Function Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! To represent ELEMENT in CoLM, the land surface is first divided into pixels, +! which are rasterized points defined by fine-resolution data. +! +! ELEMENT in MESH is set of pixels: +! 1. If GRIDBASED, ELEMENT is set of pixels in a longitude-latitude rectangle. +! 2. If UNSTRUCTURED, ELEMENT is set of pixels in an irregular area (usually polygon). +! 3. If CATCHMENT, ELEMENT is set of pixels in a catchment whose area is less than +! a predefined value. +! +! If GRIDBASED is defined, MESH is built by using input files containing mask of +! land area or by defining the resolution of longitude-latitude grid. +! If CATCHMENT or UNSTRUCTURED is defined, MESH is built by using input files +! containing index of elements. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------ + + USE MOD_Precision + USE MOD_Grid + IMPLICIT NONE + + ! ---- data types ---- + type :: irregular_elm_type + + integer*8 :: indx + integer :: xblk, yblk + + integer :: npxl + integer, allocatable :: ilon(:) + integer, allocatable :: ilat(:) + + END type irregular_elm_type + + ! ---- Instance ---- + type (grid_type) :: gridmesh + + integer :: numelm + type (irregular_elm_type), allocatable :: mesh (:) + + integer, allocatable :: nelm_blk(:,:) + +#ifdef GRIDBASED + logical :: read_mesh_from_file = .true. +#endif + +CONTAINS + + ! ------ +#ifdef GRIDBASED + SUBROUTINE init_gridbased_mesh_grid () + + USE MOD_MPAS_MPI + USE MOD_Namelist + IMPLICIT NONE + + IF (mpas_is_root) THEN + inquire (file=trim(DEF_file_mesh), exist=read_mesh_from_file) + ENDIF +#ifdef MPAS_MPI + CALL mpi_bcast (read_mesh_from_file, 1, MPI_LOGICAL, mpas_root, mpas_comm, mpas_mpi_ierr) +#endif + IF (read_mesh_from_file) THEN + CALL gridmesh%define_from_file (DEF_file_mesh) + ELSE + CALL gridmesh%define_by_res (DEF_GRIDBASED_lon_res, DEF_GRIDBASED_lat_res) + ENDIF + + END SUBROUTINE init_gridbased_mesh_grid +#endif + + ! ------- + SUBROUTINE copy_elm (elm_from, elm_to) + + IMPLICIT NONE + type (irregular_elm_type), intent(in) :: elm_from + type (irregular_elm_type), intent(out) :: elm_to + + elm_to%indx = elm_from%indx + elm_to%npxl = elm_from%npxl + elm_to%xblk = elm_from%xblk + elm_to%yblk = elm_from%yblk + + IF (allocated(elm_to%ilat)) deallocate(elm_to%ilat) + IF (allocated(elm_to%ilon)) deallocate(elm_to%ilon) + + allocate (elm_to%ilat (elm_to%npxl)) + allocate (elm_to%ilon (elm_to%npxl)) + elm_to%ilon = elm_from%ilon + elm_to%ilat = elm_from%ilat + + END SUBROUTINE copy_elm + + ! -------------------------------- + + + ! -------------------------------- + SUBROUTINE mesh_free_mem () + + IMPLICIT NONE + + ! Local variables + integer :: ie + + IF (allocated(mesh)) THEN + DO ie = 1, size(mesh) + IF (allocated(mesh(ie)%ilon)) deallocate (mesh(ie)%ilon) + IF (allocated(mesh(ie)%ilat)) deallocate (mesh(ie)%ilat) + ENDDO + + deallocate (mesh) + ENDIF + + IF (allocated(nelm_blk)) deallocate(nelm_blk) + CALL grid_free_mem(gridmesh) + + numelm = 0 + + END SUBROUTINE mesh_free_mem + +END MODULE MOD_Mesh diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 new file mode 100644 index 0000000000..ee69e299c7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90 @@ -0,0 +1,2498 @@ +#include + +MODULE MOD_Namelist + +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! Variables in namelist files and subroutines to read namelist files. +! +! Initial Authors: Shupeng Zhang, Zhongwang Wei, Xingjie Lu, Nan Wei, +! Hua Yuan, Wenzong Dong et al., May 2023 +!----------------------------------------------------------------------- + + USE MOD_Precision, only: r8 + IMPLICIT NONE + SAVE + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 0: CASE name ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: DEF_CASE_NAME = 'CASENAME' + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 1: domain ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~ + + type nl_domain_type + real(r8) :: edges = -90.0 + real(r8) :: edgen = 90.0 + real(r8) :: edgew = -180.0 + real(r8) :: edgee = 180.0 + END type nl_domain_type + + type (nl_domain_type) :: DEF_domain + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 2: blocks and MPI ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! "blocks" is used to deal with high resolution data. + ! It is defined by one of the following (in order of priority): + ! 1) "DEF_BlockInfoFile" : "lat_s","lat_n","lon_w","lon_e" in file ; + ! 2) "DEF_AverageElementSize" : diameter of element (in kilometer); + ! 3) "DEF_nx_blocks" and "DEF_ny_blocks" : number of blocks; + character(len=256) :: DEF_BlockInfoFile = 'null' + real(r8) :: DEF_AverageElementSize = -1. + integer :: DEF_nx_blocks = 72 + integer :: DEF_ny_blocks = 36 + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 3: For Single Point ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: SITE_fsitedata = 'null' + + real(r8) :: SITE_lon_location = -1.e36_r8 + real(r8) :: SITE_lat_location = -1.e36_r8 + + integer :: SITE_landtype = -1 + + logical :: USE_SITE_landtype = .false. + logical :: USE_SITE_pctpfts = .true. + logical :: USE_SITE_pctcrop = .true. + logical :: USE_SITE_htop = .true. + logical :: USE_SITE_LAI = .true. + logical :: USE_SITE_lakedepth = .true. + logical :: USE_SITE_soilreflectance = .true. + logical :: USE_SITE_soilparameters = .true. + logical :: USE_SITE_dbedrock = .true. + logical :: USE_SITE_topography = .true. + logical :: USE_SITE_urban_geometry = .true. + logical :: USE_SITE_urban_ecology = .true. + logical :: USE_SITE_urban_radiation = .true. + logical :: USE_SITE_urban_thermal = .false. + logical :: USE_SITE_urban_human = .true. + logical :: USE_SITE_HistWriteBack = .true. + logical :: USE_SITE_ForcingReadAhead = .true. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 4: simulation time type ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + type nl_simulation_time_type + logical :: greenwich = .TRUE. + integer :: start_year = 2000 + integer :: start_month = 1 + integer :: start_day = 1 + integer :: start_sec = 0 + integer :: end_year = 2003 + integer :: end_month = 1 + integer :: end_day = 1 + integer :: end_sec = 0 + integer :: spinup_year = 0 + integer :: spinup_month = 1 + integer :: spinup_day = 1 + integer :: spinup_sec = 0 + integer :: spinup_repeat = 1 + real(r8) :: timestep = 1800. + END type nl_simulation_time_type + + type (nl_simulation_time_type) :: DEF_simulation_time + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 5: directories and files ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: DEF_dir_rawdata = 'path/to/rawdata/' + character(len=256) :: DEF_dir_runtime = 'path/to/runtime/' + character(len=256) :: DEF_dir_output = 'path/to/output/data' + + character(len=256) :: DEF_dir_landdata = 'path/to/landdata' + character(len=256) :: DEF_dir_restart = 'path/to/restart' + character(len=256) :: DEF_dir_history = 'path/to/history' + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 6: landdata and surface inputs ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: DEF_file_mesh = 'path/to/mesh/file' + real(r8) :: DEF_GRIDBASED_lon_res = 0.5 + real(r8) :: DEF_GRIDBASED_lat_res = 0.5 + + character(len=256) :: DEF_CatchmentMesh_data = 'path/to/catchment/data' + + ! ----- Use surface data from existing dataset ----- + ! case 1: from a larger region + logical :: USE_srfdata_from_larger_region = .false. + character(len=256) :: DEF_dir_existing_srfdata = 'path/to/landdata' + ! case 2: from gridded data with dimensions [patch,lon,lat] or [pft,lon,lat] + ! only available for USGS/IGBP/PFT CLASSIFICATION + logical :: USE_srfdata_from_3D_gridded_data = .false. + + ! ----- land cover data year (for static land cover, i.e. non-LULCC) ----- + ! NOTE: Please check the LC data year range available + integer :: DEF_LC_YEAR = 2005 + + ! ----- Subgrid scheme ----- + logical :: DEF_USE_USGS = .false. + logical :: DEF_USE_IGBP = .false. + logical :: DEF_USE_LCT = .false. + logical :: DEF_USE_PFT = .false. + logical :: DEF_USE_PC = .false. + logical :: DEF_SOLO_PFT = .false. + logical :: DEF_FAST_PC = .true. + logical :: DEF_PC_CROP_SPLIT = .true. + character(len=256) :: DEF_SUBGRID_SCHEME = 'LCT' + + logical :: DEF_LANDONLY = .true. + logical :: DEF_USE_DOMINANT_PATCHTYPE = .false. + + ! soil hydraulic parameters are upscaled from rawdata (1km resolution) + ! to model patches through FIT algorithm (Montzka et al., 2017). + logical :: DEF_USE_SOILPAR_UPS_FIT = .true. + + ! Options for soil reflectance setting schemes + ! 1: Guessed soil color type according to land cover classes + ! 2: Read a global soil color map from CLM + integer :: DEF_SOIL_REFL_SCHEME = 2 + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 7: Leaf Area Index ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! NOTE: Please check the LAI data year range available + integer :: DEF_LAI_START_YEAR = 2000 + integer :: DEF_LAI_END_YEAR = 2020 + + ! add by zhongwang wei @ sysu 2021/12/23 + ! To allow read satellite observed LAI + ! 06/2023, note by hua yuan: change DEF_LAI_CLIM to DEF_LAI_MONTHLY + logical :: DEF_LAI_MONTHLY = .true. + + ! ------LAI change and Land cover year setting ---------- + ! 06/2023, add by wenzong dong and hua yuan: use for updating LAI with simulation year + logical :: DEF_LAI_CHANGE_YEARLY = .true. + + ! 05/2023, add by Xingjie Lu: use for updating LAI with leaf carbon + logical :: DEF_USE_LAIFEEDBACK = .false. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 8: Initialization ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + logical :: DEF_USE_SoilInit = .false. + character(len=256) :: DEF_file_SoilInit = 'null' + + logical :: DEF_USE_SnowInit = .false. + character(len=256) :: DEF_file_SnowInit = 'null' + + logical :: DEF_USE_CN_INIT = .false. + character(len=256) :: DEF_file_cn_init = 'null' + + logical :: DEF_USE_WaterTableInit = .false. + character(len=256) :: DEF_file_WaterTable = 'null' + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 9: LULCC related ------ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Options for LULCC year-to-year transfer schemes + ! 1: Same Type Assignment scheme (STA), state variables assignment for the same type (LC, PFT or PC) + ! 2: Mass and Energy Conservation scheme (MEC), DO mass and energy conservation calculation + integer :: DEF_LULCC_SCHEME = 1 + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 10: Urban model related ------ +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Options for urban type scheme + ! 1: NCAR Urban Classification, 3 urban type with Tall Building, High Density and Medium Density + ! 2: LCZ Classification, 10 urban type with LCZ 1-10 + integer :: DEF_URBAN_type_scheme = 1 + integer :: DEF_URBAN_geom_data = 1 + logical :: DEF_URBAN_ONLY = .false. + logical :: DEF_URBAN_RUN = .false. + logical :: DEF_URBAN_BEM = .true. + logical :: DEF_URBAN_TREE = .true. + logical :: DEF_URBAN_WATER = .true. + logical :: DEF_URBAN_LUCY = .true. + logical :: DEF_USE_CANYON_HWR = .true. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 11: parameterization schemes ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + integer :: DEF_Interception_scheme = 1 !1:CoLM；2:CLM4.5; 3:CLM5; 4:Noah-MP; 5:MATSIRO; 6:VIC; 7:JULES + + ! ----- SOIL parameters and supercool water setting ------ + integer :: DEF_THERMAL_CONDUCTIVITY_SCHEME = 4 ! Options for soil thermal conductivity schemes + ! 1: Farouki (1981) + ! 2: Johansen(1975) + ! 3: Cote and Konrad (2005) + ! 4: Balland and Arp (2005) + ! 5: Lu et al. (2007) + ! 6: Tarnawski and Leong (2012) + ! 7: De Vries (1963) + ! 8: Yan Hengnian, He Hailong et al.(2019) + + logical :: DEF_USE_SUPERCOOL_WATER = .true. ! supercooled soil water scheme, Niu & Yang (2006) + + ! ----- Options for soil surface resistance schemes ----- + ! 0: NONE soil surface resistance + ! 1: SL14, Swenson and Lawrence (2014) + ! 2: SZ09, Sakaguchi and Zeng (2009) + ! 3: TR13, Tang and Riley (2013) + ! 4: LP92, Lee and Pielke (1992) + ! 5: S92, Sellers et al (1992) + integer :: DEF_RSS_SCHEME = 1 + + ! ----- Options for runoff parameterization schemes ----- + ! 0: scheme from TOPMODEL, also used in CoLM2014 + ! 1: scheme from VIC model + ! 2: scheme from XinAnJiang model, also used in ECMWF model + ! 3: scheme from Simple VIC, also used in NoahMP 5.0 + + integer :: DEF_Runoff_SCHEME = 3 + character(len=256) :: DEF_file_VIC_para = 'null' + character(len=256) :: DEF_file_VIC_OPT = 'null' + logical :: DEF_VIC_OPT = .false. + + integer :: DEF_TOPMOD_method = 0 + + ! ----- Treat exposed soil and snow surface separately ----- + ! including solar absorption, sensible/latent heat, ground temperature, + ! ground heat flux and ground evp/dew/subl/fros. Corresponding vars are + ! named as ***_soil, ***_snow. + logical :: DEF_SPLIT_SOILSNOW = .false. + + ! ----- Account for vegetation snow process ----- + ! NOTE: This option will be activated in the new release, accompanied by + ! a new set of canopy structure data, include the snow-free LAI. + logical :: DEF_VEG_SNOW = .false. + + ! ----- Variably Saturated Flow Soil Water ----- + logical :: DEF_USE_VariablySaturatedFlow = .true. + logical :: DEF_USE_BEDROCK = .false. + + ! ----- Ozone stress ----- + logical :: DEF_USE_OZONESTRESS = .true. + logical :: DEF_USE_OZONEDATA = .true. + + ! ----- SNICAR model related ----- + logical :: DEF_USE_SNICAR = .false. + character(len=256) :: DEF_file_snowoptics = 'null' + character(len=256) :: DEF_file_snowaging = 'null' + + ! ----- Hyperspectral related ----- + logical :: DEF_HighResSoil = .true. + logical :: DEF_HighResVeg = .true. + logical :: DEF_PROSPECT = .false. + + CHARACTER(LEN=256) :: DEF_HighResUrban_albedo = 'null' + ! logical :: DEF_Satellite_Params = .false. + ! character(len=256) :: DEF_file_soiloptics = 'null' + ! character(len=256) :: DEF_file_satellite_params = 'null' + ! character(len=256) :: DEF_sla_varname = 'null' + + ! .true. read aerosol deposition data from file or .false. set in the code + logical :: DEF_Aerosol_Readin = .true. + + ! .true. Read aerosol deposition climatology data or .false. yearly changed + logical :: DEF_Aerosol_Clim = .false. + + ! ----- Atmospheric Nitrogen Deposition ----- + !add by Fang Shang @ pku 2023/08 + !1: To allow annuaul ndep data to be read in + !2: To allow monthly ndep data to be read in + integer :: DEF_NDEP_FREQUENCY = 1 + + ! ----- lateral flow related ----- + character(len=256) :: DEF_ElementNeighbour_file = 'null' + character(len=256) :: DEF_UnitCatchment_file = 'null' + character(len=256) :: DEF_ReservoirPara_file = 'null' + + logical :: DEF_USE_EstimatedRiverDepth = .true. + integer :: DEF_Reservoir_Method = 0 + real(r8) :: DEF_GRIDBASED_ROUTING_MAX_DT = 3600. + + ! ----- sediment module ----- + logical :: DEF_USE_SEDIMENT = .false. + real(r8) :: DEF_SED_LAMBDA = 0.4 + real(r8) :: DEF_SED_LYRDPH = 0.00005 + real(r8) :: DEF_SED_DENSITY = 2.65 + real(r8) :: DEF_SED_WATER_DENSITY = 1.0 + real(r8) :: DEF_SED_VISKIN = 1.0e-6 + real(r8) :: DEF_SED_VONKAR = 0.4 + real(r8) :: DEF_SED_PSET = 1.0 + integer :: DEF_SED_TOTLYRNUM = 5 + real(r8) :: DEF_SED_CFL_ADV = 0.5 + real(r8) :: DEF_SED_IGNORE_DPH = 0.05 + real(r8) :: DEF_SED_DT_MAX = 3600. + character(len=256) :: DEF_SED_DIAMETER = "0.0002,0.002,0.02" + real(r8) :: DEF_SED_PYLD = 0.01 + real(r8) :: DEF_SED_PYLDC = 2.0 + real(r8) :: DEF_SED_PYLDPC = 2.0 + real(r8) :: DEF_SED_DSYLUNIT = 1.0e-6 + + ! ----- others ----- + character(len=5) :: DEF_precip_phase_discrimination_scheme = 'II' + + character(len=256) :: DEF_SSP = '585' ! Co2 path for CMIP6 future scenario. + + logical :: DEF_USE_IRRIGATION = .false. ! use irrigation + integer :: DEF_IRRIGATION_ALLOCATION = 1 ! irrigation allocated method + + logical :: DEF_USE_NOSTRESSNITROGEN = .false. ! photosynthesis stress option + integer :: DEF_RSTFAC = 1 ! root resistance factors option + logical :: DEF_USE_PLANTHYDRAULICS = .true. ! Plant Hydraulics + logical :: DEF_USE_MEDLYNST = .false. ! Medlyn stomata model + logical :: DEF_USE_WUEST = .true. ! WUE stomata model + + logical :: DEF_USE_SASU = .false. ! Semi-Analytic-Spin-Up + logical :: DEF_USE_DiagMatrix = .false. + logical :: DEF_USE_PN = .false. ! Punctuated nitrogen addition Spin up + + logical :: DEF_USE_FERT = .true. ! Fertilisation on crop + integer :: DEF_FERT_SOURCE = 1 ! Fertilisation data source + logical :: DEF_USE_NITRIF = .true. ! Nitrification and denitrification switch + logical :: DEF_USE_CNSOYFIXN = .true. ! Soy nitrogen fixation + + logical :: DEF_USE_FIRE = .false. ! Fire MODULE + + logical :: DEF_USE_Dynamic_Lake = .false. ! Dynamic Lake model + + logical :: DEF_USE_Dynamic_Wetland = .false. ! Dynamic wetland model + + logical :: DEF_CheckEquilibrium = .false. + + logical :: DEF_Output_2mWMO = .false. ! 2m WMO temperature + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 12: forcing ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + character(len=256) :: DEF_forcing_namelist = 'null' + + character(len=256) :: DEF_dir_forcing = 'path/to/forcing/data' + + type nl_forcing_type + + character(len=256) :: dataset = 'CRUNCEP' + logical :: solarin_all_band = .true. + character(len=256) :: HEIGHT_mode = 'absolute' + real(r8) :: HEIGHT_V = 100.0 + real(r8) :: HEIGHT_T = 50. + real(r8) :: HEIGHT_Q = 50. + + logical :: regional = .false. + real(r8) :: regbnd(4) = (/-90.0, 90.0, -180.0, 180.0/) + logical :: has_missing_value = .false. + character(len=256) :: missing_value_name = 'missing_value' + + integer :: NVAR = 8 ! variable number of forcing data + integer :: startyr = 2000 ! start year of forcing data + integer :: startmo = 1 ! start month of forcing data + integer :: endyr = 2003 ! end year of forcing data + integer :: endmo = 12 ! end month of forcing data + integer :: dtime(8) = (/21600,21600,21600,21600,0,21600,21600,21600/) + integer :: offset(8) = (/10800,10800,10800,10800,0,10800,0,10800/) + integer :: nlands = 1 ! land grid number in 1d + + logical :: leapyear = .false. ! leapyear calendar + logical :: data2d = .true. ! data in 2 dimension (lon, lat) + logical :: hightdim = .false. ! have "z" dimension + logical :: dim2d = .true. ! lat/lon value in 2 dimension (lon, lat) + + character(len=256) :: latname = 'LATIXY' ! dimension name of latitude + character(len=256) :: lonname = 'LONGXY' ! dimension name of longitude + + character(len=256) :: groupby = 'month' ! file grouped by year/month + + character(len=256) :: fprefix(8) = (/ & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.', & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.', & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.', & + 'Precip6Hrly/clmforc.cruncep.V4.c2011.0.5d.Prec.', & + 'NULL ', & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.', & + 'Solar6Hrly/clmforc.cruncep.V4.c2011.0.5d.Solr. ', & + 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' /) + character(len=256) :: vname(8) = (/ & + 'TBOT ','QBOT ','PSRF ','PRECTmms', & + 'NULL ','WIND ','FSDS ','FLDS ' /) + character(len=256) :: timelog(8) = (/ & + 'instant ','instant ','instant ','forward ', & + 'NULL ','instant ','forward ','forward ' /) + character(len=256) :: tintalgo(8) = (/ & + 'linear ','linear ','linear ','nearest', & + 'NULL ','linear ','coszen ','linear ' /) + + character(len=256) :: CBL_fprefix = 'TPHWL6Hrly/clmforc.cruncep.V4.c2011.0.5d.TPQWL.' + character(len=256) :: CBL_vname = 'blh' + character(len=256) :: CBL_tintalgo = 'linear' + integer :: CBL_dtime = 21600 + integer :: CBL_offset = 10800 + END type nl_forcing_type + + type (nl_forcing_type) :: DEF_forcing + + !CBL height + logical :: DEF_USE_CBL_HEIGHT = .false. + + character(len=20) :: DEF_Forcing_Interp_Method = 'arealweight' ! 'arealweight' (default) or 'bilinear' + + logical :: DEF_USE_Forcing_Downscaling = .false. + logical :: DEF_USE_Forcing_Downscaling_Simple = .false. + character(len=256):: DEF_DS_HiresTopographyDataDir = 'null' + character(len=5) :: DEF_DS_precipitation_adjust_scheme = 'I' + character(len=5) :: DEF_DS_longwave_adjust_scheme = 'II' + + logical :: DEF_USE_ClimForcing_for_Spinup = .false. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 13: data assimilation ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=256) :: DEF_DA_obsdir = 'null' + logical :: DEF_DA_TWS = .false. + logical :: DEF_DA_TWS_GRACE = .false. + logical :: DEF_DA_SM = .false. + integer :: DEF_DA_ENS_NUM = 20 + logical :: DEF_DA_ENS_SM = .false. + logical :: DEF_DA_SM_SMAP = .false. + logical :: DEF_DA_SM_FY = .false. + logical :: DEF_DA_SM_SYNOP = .false. + integer :: DEF_DA_RTM_diel = 0 + integer :: DEF_DA_RTM_rough = 0 + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 14: parameter optimization ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + logical :: DEF_Optimize_Baseflow = .false. + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ----- Part 15: history and restart ----- +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + logical :: DEF_HISTORY_IN_VECTOR = .false. + + logical :: DEF_HIST_grid_as_forcing = .false. + real(r8) :: DEF_HIST_lon_res = 0.5 + real(r8) :: DEF_HIST_lat_res = 0.5 + + character(len=256) :: DEF_WRST_FREQ = 'none' ! write restart file frequency: TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY + character(len=256) :: DEF_HIST_FREQ = 'none' ! write history file frequency: TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY + character(len=256) :: DEF_HIST_groupby = 'MONTH' ! history file in one file: DAY/MONTH/YEAR + character(len=256) :: DEF_HIST_mode = 'one' + logical :: DEF_HIST_WriteBack = .false. + integer :: DEF_REST_CompressLevel = 1 + integer :: DEF_HIST_CompressLevel = 1 + + character(len=256) :: DEF_HIST_vars_namelist = 'null' + logical :: DEF_HIST_vars_out_default = .true. + + + ! ----- history variables ----- + type history_var_type + + logical :: xy_us = .true. + logical :: xy_vs = .true. + logical :: xy_t = .true. + logical :: xy_q = .true. + logical :: xy_prc = .true. + logical :: xy_prl = .true. + logical :: xy_pbot = .true. + logical :: xy_frl = .true. + logical :: xy_solarin = .true. + logical :: xy_rain = .true. + logical :: xy_snow = .true. + logical :: xy_ozone = .true. + logical :: xy_hpbl = .true. + + logical :: taux = .true. + logical :: tauy = .true. + logical :: fsena = .true. + logical :: lfevpa = .true. + logical :: fevpa = .true. + logical :: fsenl = .true. + logical :: fevpl = .true. + logical :: etr = .true. + logical :: fseng = .true. + logical :: fevpg = .true. + logical :: fgrnd = .true. + logical :: sabvsun = .true. + logical :: sabvsha = .true. + logical :: sabg = .true. + logical :: olrg = .true. + logical :: rnet = .true. + logical :: xerr = .true. + logical :: zerr = .true. + logical :: rsur = .true. + logical :: rsur_se = .true. + logical :: rsur_ie = .true. + logical :: rsub = .true. + logical :: rnof = .true. + logical :: xwsur = .true. + logical :: xwsub = .true. + logical :: fldarea = .true. + logical :: qintr = .true. + logical :: qinfl = .true. + logical :: qdrip = .true. + logical :: wat = .true. + logical :: wat_inst = .true. + logical :: wetwat = .true. + logical :: wetwat_inst = .true. + logical :: wetzwt = .true. + logical :: assim = .true. + logical :: respc = .true. + logical :: qcharge = .true. + logical :: t_grnd = .true. + logical :: tleaf = .true. + logical :: ldew = .true. + logical :: scv = .true. + logical :: snowdp = .true. + logical :: fsno = .true. + logical :: frcsat = .true. + logical :: sigf = .true. + logical :: green = .true. + logical :: lai = .true. + logical :: laisun = .true. + logical :: laisha = .true. + logical :: sai = .true. + logical :: alb = .true. + logical :: alb_hires = .true. + logical :: reflectance_out = .true. + logical :: transmittance_out = .true. + logical :: emis = .true. + logical :: z0m = .true. + logical :: trad = .true. + logical :: rss = .true. + logical :: tref = .true. + logical :: t2m_wmo = .true. + logical :: qref = .true. + + logical :: fsen_roof = .true. + logical :: fsen_wsun = .true. + logical :: fsen_wsha = .true. + logical :: fsen_gimp = .true. + logical :: fsen_gper = .true. + logical :: fsen_urbl = .true. + logical :: lfevp_roof = .true. + logical :: lfevp_gimp = .true. + logical :: lfevp_gper = .true. + logical :: lfevp_urbl = .true. + logical :: fhac = .true. + logical :: fwst = .true. + logical :: fach = .true. + logical :: fhah = .true. + logical :: meta = .true. + logical :: vehc = .true. + logical :: t_room = .true. + logical :: tafu = .true. + logical :: t_roof = .true. + logical :: t_wall = .true. + + logical :: assimsun = .true. + logical :: assimsha = .true. + logical :: etrsun = .true. + logical :: etrsha = .true. + + logical :: o3uptakesun = .true. + logical :: o3uptakesha = .true. + + logical :: leafc = .true. + logical :: leafc_storage = .true. + logical :: leafc_xfer = .true. + logical :: frootc = .true. + logical :: frootc_storage = .true. + logical :: frootc_xfer = .true. + logical :: livestemc = .true. + logical :: livestemc_storage = .true. + logical :: livestemc_xfer = .true. + logical :: deadstemc = .true. + logical :: deadstemc_storage = .true. + logical :: deadstemc_xfer = .true. + logical :: livecrootc = .true. + logical :: livecrootc_storage = .true. + logical :: livecrootc_xfer = .true. + logical :: deadcrootc = .true. + logical :: deadcrootc_storage = .true. + logical :: deadcrootc_xfer = .true. + logical :: grainc = .true. + logical :: grainc_storage = .true. + logical :: grainc_xfer = .true. + logical :: leafn = .true. + logical :: leafn_storage = .true. + logical :: leafn_xfer = .true. + logical :: frootn = .true. + logical :: frootn_storage = .true. + logical :: frootn_xfer = .true. + logical :: livestemn = .true. + logical :: livestemn_storage = .true. + logical :: livestemn_xfer = .true. + logical :: deadstemn = .true. + logical :: deadstemn_storage = .true. + logical :: deadstemn_xfer = .true. + logical :: livecrootn = .true. + logical :: livecrootn_storage = .true. + logical :: livecrootn_xfer = .true. + logical :: deadcrootn = .true. + logical :: deadcrootn_storage = .true. + logical :: deadcrootn_xfer = .true. + logical :: grainn = .true. + logical :: grainn_storage = .true. + logical :: grainn_xfer = .true. + logical :: retrasn = .true. + logical :: gpp = .true. + logical :: downreg = .true. + logical :: ar = .true. + logical :: cwdprod = .true. + logical :: cwddecomp = .true. + logical :: hr = .true. + logical :: fpg = .true. + logical :: fpi = .true. + logical :: totvegc = .true. + logical :: totlitc = .true. + logical :: totcwdc = .true. + logical :: totsomc = .true. + logical :: totcolc = .true. + logical :: totvegn = .true. + logical :: totlitn = .true. + logical :: totcwdn = .true. + logical :: totsomn = .true. + logical :: totcoln = .true. + logical :: totsoiln_vr = .true. + logical :: gpp_enftemp = .false. !1 + logical :: gpp_enfboreal = .false. !2 + logical :: gpp_dnfboreal = .false. !3 + logical :: gpp_ebftrop = .false. !4 + logical :: gpp_ebftemp = .false. !5 + logical :: gpp_dbftrop = .false. !6 + logical :: gpp_dbftemp = .false. !7 + logical :: gpp_dbfboreal = .false. !8 + logical :: gpp_ebstemp = .false. !9 + logical :: gpp_dbstemp = .false. !10 + logical :: gpp_dbsboreal = .false. !11 + logical :: gpp_c3arcgrass = .false. !12 + logical :: gpp_c3grass = .false. !13 + logical :: gpp_c4grass = .false. !14 + logical :: leafc_enftemp = .false. !1 + logical :: leafc_enfboreal = .false. !2 + logical :: leafc_dnfboreal = .false. !3 + logical :: leafc_ebftrop = .false. !4 + logical :: leafc_ebftemp = .false. !5 + logical :: leafc_dbftrop = .false. !6 + logical :: leafc_dbftemp = .false. !7 + logical :: leafc_dbfboreal = .false. !8 + logical :: leafc_ebstemp = .false. !9 + logical :: leafc_dbstemp = .false. !10 + logical :: leafc_dbsboreal = .false. !11 + logical :: leafc_c3arcgrass = .false. !12 + logical :: leafc_c3grass = .false. !13 + logical :: leafc_c4grass = .false. !14 + logical :: lai_enftemp = .false. !1 + logical :: lai_enfboreal = .false. !2 + logical :: lai_dnfboreal = .false. !3 + logical :: lai_ebftrop = .false. !4 + logical :: lai_ebftemp = .false. !5 + logical :: lai_dbftrop = .false. !6 + logical :: lai_dbftemp = .false. !7 + logical :: lai_dbfboreal = .false. !8 + logical :: lai_ebstemp = .false. !9 + logical :: lai_dbstemp = .false. !10 + logical :: lai_dbsboreal = .false. !11 + logical :: lai_c3arcgrass = .false. !12 + logical :: lai_c3grass = .false. !13 + logical :: lai_c4grass = .false. !14 + logical :: npp_enftemp = .false. !1 + logical :: npp_enfboreal = .false. !2 + logical :: npp_dnfboreal = .false. !3 + logical :: npp_ebftrop = .false. !4 + logical :: npp_ebftemp = .false. !5 + logical :: npp_dbftrop = .false. !6 + logical :: npp_dbftemp = .false. !7 + logical :: npp_dbfboreal = .false. !8 + logical :: npp_ebstemp = .false. !9 + logical :: npp_dbstemp = .false. !10 + logical :: npp_dbsboreal = .false. !11 + logical :: npp_c3arcgrass = .false. !12 + logical :: npp_c3grass = .false. !13 + logical :: npp_c4grass = .false. !14 + logical :: npptoleafc_enftemp = .false. !1 + logical :: npptoleafc_enfboreal = .false. !2 + logical :: npptoleafc_dnfboreal = .false. !3 + logical :: npptoleafc_ebftrop = .false. !4 + logical :: npptoleafc_ebftemp = .false. !5 + logical :: npptoleafc_dbftrop = .false. !6 + logical :: npptoleafc_dbftemp = .false. !7 + logical :: npptoleafc_dbfboreal = .false. !8 + logical :: npptoleafc_ebstemp = .false. !9 + logical :: npptoleafc_dbstemp = .false. !10 + logical :: npptoleafc_dbsboreal = .false. !11 + logical :: npptoleafc_c3arcgrass = .false. !12 + logical :: npptoleafc_c3grass = .false. !13 + logical :: npptoleafc_c4grass = .false. !14 + + logical :: cphase = .true. + logical :: gddmaturity = .true. + logical :: gddplant = .true. + logical :: vf = .true. + logical :: hui = .true. + logical :: cropprod1c = .true. + logical :: cropprod1c_loss = .true. + logical :: cropseedc_deficit = .true. + logical :: grainc_to_cropprodc = .true. + logical :: plantdate_rainfed_temp_corn = .true. + logical :: plantdate_irrigated_temp_corn = .true. + logical :: plantdate_rainfed_spwheat = .true. + logical :: plantdate_irrigated_spwheat = .true. + logical :: plantdate_rainfed_wtwheat = .true. + logical :: plantdate_irrigated_wtwheat = .true. + logical :: plantdate_rainfed_temp_soybean = .true. + logical :: plantdate_irrigated_temp_soybean = .true. + logical :: plantdate_rainfed_cotton = .true. + logical :: plantdate_irrigated_cotton = .true. + logical :: plantdate_rainfed_rice = .true. + logical :: plantdate_irrigated_rice = .true. + logical :: plantdate_rainfed_sugarcane = .true. + logical :: plantdate_irrigated_sugarcane = .true. + logical :: plantdate_rainfed_trop_corn = .true. + logical :: plantdate_irrigated_trop_corn = .true. + logical :: plantdate_rainfed_trop_soybean = .true. + logical :: plantdate_irrigated_trop_soybean = .true. + logical :: plantdate_unmanagedcrop = .true. + logical :: cropprodc_rainfed_temp_corn = .true. + logical :: cropprodc_irrigated_temp_corn = .true. + logical :: cropprodc_rainfed_spwheat = .true. + logical :: cropprodc_irrigated_spwheat = .true. + logical :: cropprodc_rainfed_wtwheat = .true. + logical :: cropprodc_irrigated_wtwheat = .true. + logical :: cropprodc_rainfed_temp_soybean = .true. + logical :: cropprodc_irrigated_temp_soybean = .true. + logical :: cropprodc_rainfed_cotton = .true. + logical :: cropprodc_irrigated_cotton = .true. + logical :: cropprodc_rainfed_rice = .true. + logical :: cropprodc_irrigated_rice = .true. + logical :: cropprodc_rainfed_sugarcane = .true. + logical :: cropprodc_irrigated_sugarcane = .true. + logical :: cropprodc_rainfed_trop_corn = .true. + logical :: cropprodc_irrigated_trop_corn = .true. + logical :: cropprodc_rainfed_trop_soybean = .true. + logical :: cropprodc_irrigated_trop_soybean = .true. + logical :: cropprodc_unmanagedcrop = .true. + + logical :: grainc_to_seed = .true. + logical :: fert_to_sminn = .true. + + logical :: huiswheat = .true. + logical :: pdcorn = .false. + logical :: pdswheat = .false. + logical :: pdwwheat = .false. + logical :: pdsoybean = .false. + logical :: pdcotton = .false. + logical :: pdrice1 = .false. + logical :: pdrice2 = .false. + logical :: pdsugarcane = .false. + logical :: manunitro = .false. + logical :: fertnitro_corn = .true. + logical :: fertnitro_swheat = .true. + logical :: fertnitro_wwheat = .true. + logical :: fertnitro_soybean = .true. + logical :: fertnitro_cotton = .true. + logical :: fertnitro_rice1 = .true. + logical :: fertnitro_rice2 = .true. + logical :: fertnitro_sugarcane = .true. + logical :: irrig_method_corn = .true. + logical :: irrig_method_swheat = .true. + logical :: irrig_method_wwheat = .true. + logical :: irrig_method_soybean = .true. + logical :: irrig_method_cotton = .true. + logical :: irrig_method_rice1 = .true. + logical :: irrig_method_rice2 = .true. + logical :: irrig_method_sugarcane = .true. + + logical :: sum_irrig = .true. + logical :: sum_deficit_irrig = .true. + logical :: sum_irrig_count = .true. + logical :: waterstorage = .true. + logical :: groundwater_demand = .true. + logical :: groundwater_supply = .true. + logical :: reservoirriver_demand = .true. + logical :: reservoirriver_supply = .true. + + logical :: ndep_to_sminn = .true. + logical :: CONC_O2_UNSAT = .false. + logical :: O2_DECOMP_DEPTH_UNSAT = .false. + logical :: abm = .false. + logical :: gdp = .false. + logical :: peatf = .false. + logical :: hdm = .false. + logical :: lnfm = .false. + + logical :: leafcCap = .false. + logical :: leafc_storageCap = .false. + logical :: leafc_xferCap = .false. + logical :: frootcCap = .false. + logical :: frootc_storageCap = .false. + logical :: frootc_xferCap = .false. + logical :: livestemcCap = .false. + logical :: livestemc_storageCap = .false. + logical :: livestemc_xferCap = .false. + logical :: deadstemcCap = .false. + logical :: deadstemc_storageCap = .false. + logical :: deadstemc_xferCap = .false. + logical :: livecrootcCap = .false. + logical :: livecrootc_storageCap = .false. + logical :: livecrootc_xferCap = .false. + logical :: deadcrootcCap = .false. + logical :: deadcrootc_storageCap = .false. + logical :: deadcrootc_xferCap = .false. + logical :: leafnCap = .false. + logical :: leafn_storageCap = .false. + logical :: leafn_xferCap = .false. + logical :: frootnCap = .false. + logical :: frootn_storageCap = .false. + logical :: frootn_xferCap = .false. + logical :: livestemnCap = .false. + logical :: livestemn_storageCap = .false. + logical :: livestemn_xferCap = .false. + logical :: deadstemnCap = .false. + logical :: deadstemn_storageCap = .false. + logical :: deadstemn_xferCap = .false. + logical :: livecrootnCap = .false. + logical :: livecrootn_storageCap = .false. + logical :: livecrootn_xferCap = .false. + logical :: deadcrootnCap = .false. + logical :: deadcrootn_storageCap = .false. + logical :: deadcrootn_xferCap = .false. + logical :: t_scalar = .false. + logical :: w_scalar = .false. + + logical :: t_soisno = .true. + logical :: wliq_soisno = .true. + logical :: wice_soisno = .true. + + logical :: h2osoi = .true. + logical :: qlayer = .true. + logical :: lake_deficit = .true. + logical :: rstfacsun = .true. + logical :: rstfacsha = .true. + logical :: gssun = .true. + logical :: gssha = .true. + logical :: rootr = .true. + logical :: vegwp = .true. + logical :: BD_all = .true. + logical :: wfc = .true. + logical :: OM_density = .true. + logical :: wdsrf = .true. + logical :: wdsrf_inst = .true. + logical :: zwt = .true. + logical :: wa = .true. + logical :: wa_inst = .true. + + logical :: dz_lake = .true. + logical :: t_lake = .true. + logical :: lake_icefrac = .true. + + logical :: DA_wliq_h2osoi_5cm = .true. + logical :: DA_wliq_h2osoi_5cm_a = .true. + logical :: DA_t_soisno_5cm = .true. + logical :: DA_t_soisno_5cm_a = .true. + logical :: DA_wliq_soisno_ens = .true. + logical :: DA_t_soisno_ens = .true. + logical :: DA_wliq_soisno_5cm_ens_std = .true. + logical :: DA_t_soisno_5cm_ens_std = .true. + logical :: DA_t_brt_smap = .true. + logical :: DA_t_brt_smap_a = .true. + logical :: DA_t_brt_smap_ens = .true. + logical :: DA_t_brt_smap_ens_std = .true. + logical :: DA_t_brt_fy3d = .true. + logical :: DA_t_brt_fy3d_a = .true. + logical :: DA_t_brt_fy3d_ens = .true. + logical :: DA_t_brt_fy3d_ens_std = .true. + + logical :: litr1c_vr = .true. + logical :: litr2c_vr = .true. + logical :: litr3c_vr = .true. + logical :: soil1c_vr = .true. + logical :: soil2c_vr = .true. + logical :: soil3c_vr = .true. + logical :: cwdc_vr = .true. + logical :: litr1n_vr = .true. + logical :: litr2n_vr = .true. + logical :: litr3n_vr = .true. + logical :: soil1n_vr = .true. + logical :: soil2n_vr = .true. + logical :: soil3n_vr = .true. + logical :: cwdn_vr = .true. + + logical :: litr1cCap_vr = .false. + logical :: litr2cCap_vr = .false. + logical :: litr3cCap_vr = .false. + logical :: soil1cCap_vr = .false. + logical :: soil2cCap_vr = .false. + logical :: soil3cCap_vr = .false. + logical :: cwdcCap_vr = .false. + logical :: litr1nCap_vr = .false. + logical :: litr2nCap_vr = .false. + logical :: litr3nCap_vr = .false. + logical :: soil1nCap_vr = .false. + logical :: soil2nCap_vr = .false. + logical :: soil3nCap_vr = .false. + logical :: cwdnCap_vr = .false. + + logical :: sminn_vr = .true. + + logical :: ustar = .true. + logical :: ustar2 = .true. + logical :: tstar = .true. + logical :: qstar = .true. + logical :: zol = .true. + logical :: rib = .true. + logical :: fm = .true. + logical :: fh = .true. + logical :: fq = .true. + logical :: us10m = .true. + logical :: vs10m = .true. + logical :: fm10m = .true. + logical :: sr = .true. + logical :: solvd = .true. + logical :: solvi = .true. + logical :: solnd = .true. + logical :: solni = .true. + logical :: srvd = .true. + logical :: srvi = .true. + logical :: srnd = .true. + logical :: srni = .true. + + logical :: solvdln = .true. + logical :: solviln = .true. + logical :: solndln = .true. + logical :: solniln = .true. + logical :: srvdln = .true. + logical :: srviln = .true. + logical :: srndln = .true. + logical :: srniln = .true. + + logical :: sol_dir_ln_hires = .true. + logical :: sol_dif_ln_hires = .true. + logical :: sr_dir_ln_hires = .true. + logical :: sr_dif_ln_hires = .true. + + logical :: xsubs_bsn = .true. + logical :: xsubs_hru = .true. + logical :: riv_height = .true. + logical :: riv_veloct = .true. + logical :: discharge = .true. + logical :: floodarea = .true. + logical :: floodfrc = .true. + logical :: wdsrf_hru = .true. + logical :: veloc_hru = .true. + logical :: volresv = .true. + logical :: qresv_in = .true. + logical :: qresv_out = .true. + + logical :: sedcon = .true. + logical :: sedout = .true. + logical :: bedout = .true. + logical :: sedinp = .true. + logical :: netflw = .true. + logical :: sedlayer = .true. + logical :: shearvel = .false. + + logical :: sensors = .true. + + END type history_var_type + + type (history_var_type) :: DEF_hist_vars + +CONTAINS + + SUBROUTINE read_namelist (nlfile) + + USE MOD_MPAS_MPI + USE MOD_Utils, only: make_directory + IMPLICIT NONE + + character(len=*), intent(in) :: nlfile + + ! Local variables + logical :: fexists + integer :: ivar + integer :: ierr + character(len=256) :: iomesg + + namelist /nl_colm/ & + DEF_CASE_NAME, & + DEF_domain, & + + SITE_fsitedata, & + SITE_lon_location, & + SITE_lat_location, & + SITE_landtype, & + USE_SITE_landtype, & + USE_SITE_pctpfts, & + USE_SITE_pctcrop, & + USE_SITE_htop, & + USE_SITE_LAI, & + USE_SITE_lakedepth, & + USE_SITE_soilreflectance, & + USE_SITE_soilparameters, & + USE_SITE_dbedrock, & + USE_SITE_topography, & + USE_SITE_HistWriteBack, & + USE_SITE_ForcingReadAhead, & + USE_SITE_urban_geometry, & + USE_SITE_urban_ecology, & + USE_SITE_urban_radiation, & + USE_SITE_urban_thermal, & + USE_SITE_urban_human, & + + DEF_BlockInfoFile, & + DEF_AverageElementSize, & + DEF_nx_blocks, & + DEF_ny_blocks, & + DEF_simulation_time, & + DEF_dir_rawdata, & + DEF_dir_runtime, & + DEF_dir_output, & + DEF_file_mesh, & + DEF_GRIDBASED_lon_res, & + DEF_GRIDBASED_lat_res, & + DEF_CatchmentMesh_data, & + + DEF_USE_LCT, & + DEF_USE_PFT, & + DEF_USE_PC, & + DEF_FAST_PC, & + DEF_PC_CROP_SPLIT, & + DEF_SOLO_PFT, & + DEF_SUBGRID_SCHEME, & + + DEF_LAI_MONTHLY, & !add by zhongwang wei @ sysu 2021/12/23 + DEF_NDEP_FREQUENCY, & !add by Fang Shang @ pku 2023/08 + DEF_Interception_scheme, & !add by zhongwang wei @ sysu 2022/05/23 + DEF_SSP, & !add by zhongwang wei @ sysu 2023/02/07 + + DEF_LAI_START_YEAR, & + DEF_LAI_END_YEAR, & + DEF_LAI_CHANGE_YEARLY, & + DEF_USE_LAIFEEDBACK, & !add by Xingjie Lu, use for updating LAI with leaf carbon + DEF_USE_IRRIGATION, & !add by Hongbin Liang @ sysu + DEF_IRRIGATION_ALLOCATION, & !add by Hongbin Liang @ sysu + DEF_USE_NOSTRESSNITROGEN, & !add by Hongbin Liang @ sysu + DEF_RSTFAC, & !add by Hongbin Liang @ sysu + DEF_LC_YEAR, & + DEF_LULCC_SCHEME, & + + DEF_URBAN_type_scheme, & + DEF_URBAN_geom_data, & + DEF_URBAN_ONLY, & + DEF_URBAN_RUN, & !add by hua yuan, open urban model or not + DEF_URBAN_BEM, & !add by hua yuan, open urban BEM model or not + DEF_URBAN_TREE, & !add by hua yuan, modeling urban tree or not + DEF_URBAN_WATER, & !add by hua yuan, modeling urban water or not + DEF_URBAN_LUCY, & + DEF_USE_CANYON_HWR, & + + DEF_USE_SOILPAR_UPS_FIT, & + DEF_THERMAL_CONDUCTIVITY_SCHEME, & + DEF_USE_SUPERCOOL_WATER, & + DEF_SOIL_REFL_SCHEME, & + DEF_RSS_SCHEME, & + DEF_Runoff_SCHEME, & + DEF_TOPMOD_method, & + DEF_SPLIT_SOILSNOW, & + DEF_VEG_SNOW, & + DEF_file_VIC_para, & + DEF_file_VIC_OPT, & + DEF_VIC_OPT, & !add by Qijia Guo @ sysu + + DEF_dir_existing_srfdata, & + USE_srfdata_from_larger_region, & + USE_srfdata_from_3D_gridded_data, & + + DEF_USE_CBL_HEIGHT, & !add by zhongwang wei @ sysu 2022/12/31 + DEF_USE_PLANTHYDRAULICS, & !add by xingjie lu @ sysu 2023/05/28 + DEF_USE_MEDLYNST, & !add by xingjie lu @ sysu 2023/05/28 + DEF_USE_WUEST, & !add by xingjie lu @ sysu 2024/05/28 + DEF_USE_SASU, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_DiagMatrix, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_PN, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_FERT, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_FERT_SOURCE, & !add by Hongbin Liang @ sysu + DEF_USE_NITRIF, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_CNSOYFIXN, & !add by Xingjie Lu @ sysu 2023/06/27 + DEF_USE_FIRE, & !add by Xingjie Lu @ sysu 2023/06/27 + + DEF_USE_Dynamic_Lake, & !add by Shupeng Zhang @ sysu 2024/09/12 + DEF_USE_Dynamic_Wetland, & !add by Shupeng Zhang @ sysu 2026/01/09 + + DEF_CheckEquilibrium, & !add by Shupeng Zhang @ sysu 2024/11/26 + DEF_Output_2mWMO, & + + DEF_LANDONLY, & + DEF_USE_DOMINANT_PATCHTYPE, & + DEF_USE_VariablySaturatedFlow, & + DEF_USE_BEDROCK, & + DEF_USE_OZONESTRESS, & + DEF_USE_OZONEDATA, & + DEF_USE_SNICAR, & + DEF_Aerosol_Readin, & + DEF_Aerosol_Clim, & + DEF_USE_EstimatedRiverDepth, & + DEF_Reservoir_Method, & + DEF_GRIDBASED_ROUTING_MAX_DT, & + + DEF_USE_SEDIMENT, & + DEF_SED_LAMBDA, & + DEF_SED_LYRDPH, & + DEF_SED_DENSITY, & + DEF_SED_WATER_DENSITY, & + DEF_SED_VISKIN, & + DEF_SED_VONKAR, & + DEF_SED_PSET, & + DEF_SED_TOTLYRNUM, & + DEF_SED_CFL_ADV, & + DEF_SED_IGNORE_DPH, & + DEF_SED_DT_MAX, & + DEF_SED_DIAMETER, & + DEF_SED_PYLD, & + DEF_SED_PYLDC, & + DEF_SED_PYLDPC, & + DEF_SED_DSYLUNIT, & + + DEF_precip_phase_discrimination_scheme, & + + DEF_USE_SoilInit, & + DEF_file_SoilInit, & + + DEF_HighResSoil, & + DEF_HighResVeg, & + DEF_PROSPECT, & + DEF_HighResUrban_albedo, & + ! DEF_Satellite_Params, & + ! DEF_file_soiloptics, & + ! DEF_file_satellite_params, & + ! DEF_sla_varname, & + + DEF_USE_SnowInit, & + DEF_file_SnowInit, & + + DEF_USE_CN_INIT, & + DEF_file_cn_init, & + + DEF_USE_WaterTableInit, & + DEF_file_WaterTable, & + + DEF_file_snowoptics, & + DEF_file_snowaging , & + + DEF_ElementNeighbour_file, & + DEF_UnitCatchment_file, & + DEF_ReservoirPara_file, & + + DEF_DA_obsdir, & + DEF_DA_TWS, & + DEF_DA_TWS_GRACE, & + DEF_DA_SM, & + DEF_DA_ENS_NUM, & + DEF_DA_ENS_SM, & + DEF_DA_SM_SMAP, & + DEF_DA_SM_FY, & + DEF_DA_SM_SYNOP, & + DEF_DA_RTM_diel, & + DEF_DA_RTM_rough, & + + DEF_Optimize_Baseflow, & + + DEF_forcing_namelist, & + + DEF_Forcing_Interp_Method, & + + DEF_USE_Forcing_Downscaling, & + DEF_USE_Forcing_Downscaling_Simple, & + DEF_DS_HiresTopographyDataDir, & + DEF_DS_precipitation_adjust_scheme, & + DEF_DS_longwave_adjust_scheme, & + DEF_USE_ClimForcing_for_Spinup, & + + DEF_HISTORY_IN_VECTOR, & + DEF_HIST_lon_res, & + DEF_HIST_lat_res, & + DEF_HIST_grid_as_forcing, & + DEF_WRST_FREQ, & + DEF_HIST_FREQ, & + DEF_HIST_groupby, & + DEF_HIST_mode, & + DEF_HIST_WriteBack, & + DEF_REST_CompressLevel, & + DEF_HIST_CompressLevel, & + DEF_HIST_vars_namelist, & + DEF_HIST_vars_out_default + + namelist /nl_colm_forcing/ DEF_dir_forcing, DEF_forcing + namelist /nl_colm_history/ DEF_hist_vars + + ! ----- open the namelist file ----- + IF (mpas_is_root) THEN + + open(10, status='OLD', file=nlfile, form="FORMATTED") + read(10, nml=nl_colm, iostat=ierr, iomsg=iomesg) + IF (ierr /= 0) THEN + write(*,*) 'ERROR in ', trim(nlfile), ' : ', trim(iomesg) + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: '// trim(nlfile)) + ENDIF + close(10) + +#ifndef MPAS_EMBEDDED_COLM + open(10, status='OLD', file=trim(DEF_forcing_namelist), form="FORMATTED") + read(10, nml=nl_colm_forcing, iostat=ierr, iomsg=iomesg) + IF (ierr /= 0) THEN + write(*,*) 'ERROR in ', trim(DEF_forcing_namelist), ' : ', trim(iomesg) + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: '// trim(DEF_forcing_namelist)) + ENDIF + close(10) + + IF (trim(DEF_forcing%dataset) == 'POINT') THEN + DEF_forcing%has_missing_value = .false. + ENDIF +#endif + + DEF_dir_landdata = trim(DEF_dir_output) // '/' // trim(adjustl(DEF_CASE_NAME)) // '/landdata' + DEF_dir_restart = trim(DEF_dir_output) // '/' // trim(adjustl(DEF_CASE_NAME)) // '/restart' + DEF_dir_history = trim(DEF_dir_output) // '/' // trim(adjustl(DEF_CASE_NAME)) // '/history' + + CALL make_directory(DEF_dir_output) +#ifndef MPAS_EMBEDDED_COLM + CALL make_directory(DEF_dir_landdata) +#endif + CALL make_directory(DEF_dir_restart) +#ifndef MPAS_EMBEDDED_COLM + CALL make_directory(DEF_dir_history) +#endif + +#ifdef SinglePoint + DEF_nx_blocks = 360 + DEF_ny_blocks = 180 + DEF_HIST_mode = 'one' +#endif + +#ifndef MPAS_EMBEDDED_COLM + IF (DEF_simulation_time%timestep > 3600.) THEN + write(*,*) ' ***** ' + write(*,*) 'Warning: timestep should be less than or equal to 3600 seconds.' + CALL CoLM_Stop () + ENDIF +#endif + +! =============================================================== +! ----- Macros&Namelist conflicts and dependency management ----- +! =============================================================== + + +! ----- SOIL model related ------ Macros&Namelist conflicts and dependency management +#if (defined vanGenuchten_Mualem_SOIL_MODEL) + write(*,*) ' ***** ' + write(*,*) 'Note: DEF_USE_VariablySaturatedFlow is automaticlly set to .true. ' + write(*,*) 'when using vanGenuchten_Mualem_SOIL_MODEL. ' + DEF_USE_VariablySaturatedFlow = .true. +#endif +#if (defined CatchLateralFlow) + write(*,*) ' ***** ' + write(*,*) 'Note: DEF_USE_VariablySaturatedFlow is automaticlly set to .true. ' + write(*,*) 'when defined CatchLateralFlow. ' + DEF_USE_VariablySaturatedFlow = .true. +#endif +#ifdef SinglePoint + IF (DEF_Runoff_SCHEME == 0) THEN + write(*,*) 'Note: DEF_TOPMOD_method is set to 0 in SinglePoint.' + DEF_TOPMOD_method = 0 + ENDIF +#endif + + IF (DEF_Runoff_SCHEME == 1) THEN + DEF_file_VIC_para = trim(DEF_dir_runtime)//'/vic/vic_para.txt' + IF (DEF_VIC_OPT) THEN + DEF_file_VIC_OPT = trim(DEF_dir_runtime)//'vic/vic_para.nc' + ENDIF + ENDIF + +! ----- subgrid type related ------ Macros&Namelist conflicts and dependency management + +#if (defined LULC_USGS || defined LULC_IGBP) + DEF_USE_LCT = .true. + DEF_USE_PFT = .false. + DEF_USE_PC = .false. + DEF_FAST_PC = .false. + DEF_SOLO_PFT = .false. +#ifdef vanGenuchten_Mualem_SOIL_MODEL + write(*,*) ' ***** ' + write(*,*) 'Note: Soil resistance is automaticlly turned off for VG soil + USGS|IGBP scheme.' + DEF_RSS_SCHEME = 0 +#endif +#endif + +#ifdef LULC_IGBP_PFT + DEF_USE_LCT = .false. + DEF_USE_PFT = .true. + DEF_USE_PC = .false. + DEF_FAST_PC = .false. +#endif + +#ifdef LULC_IGBP_PC + DEF_USE_LCT = .false. + DEF_USE_PFT = .false. + DEF_USE_PC = .true. + DEF_SOLO_PFT = .false. +#endif + +#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC) + IF (.not.DEF_LAI_MONTHLY) THEN + write(*,*) ' ***** ' + write(*,*) 'Warning: 8-day LAI data is not supported for ' + write(*,*) 'LULC_IGBP_PFT and LULC_IGBP_PC.' + write(*,*) 'Changed to monthly data, set DEF_LAI_MONTHLY = .true.' + DEF_LAI_MONTHLY = .true. + ENDIF +#endif + + +! ----- BGC and CROP model related ------ Macros&Namelist conflicts and dependency management + +#ifndef BGC + IF(DEF_USE_LAIFEEDBACK)THEN + DEF_USE_LAIFEEDBACK = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: LAI feedback is not supported for BGC off.' + write(*,*) 'DEF_USE_LAIFEEDBACK is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_SASU)THEN + DEF_USE_SASU = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Semi-Analytic Spin-up is on when BGC is off.' + write(*,*) 'DEF_USE_SASU is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_DiagMatrix)THEN + DEF_USE_DiagMatrix = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: CN Matrix Diagnostic is on when BGC is off.' + write(*,*) 'DEF_USE_DiagMatrix is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_PN)THEN + DEF_USE_PN = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Punctuated nitrogen addition spin up is on when BGC is off.' + write(*,*) 'DEF_USE_PN is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_NITRIF)THEN + DEF_USE_NITRIF = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Nitrification-Denitrification is on when BGC is off.' + write(*,*) 'DEF_USE_NITRIF is set to false automatically when BGC is turned off.' + ENDIF + + IF(DEF_USE_FIRE)THEN + DEF_USE_FIRE = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Fire model is on when BGC is off.' + write(*,*) 'DEF_USE_FIRE is set to false automatically when BGC is turned off.' + ENDIF +#endif + +#ifndef CROP + IF(DEF_USE_FERT)THEN + DEF_USE_FERT = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Fertilization is on when CROP is off.' + write(*,*) 'DEF_USE_FERT is set to false automatically when CROP is turned off.' + ENDIF + + IF(DEF_USE_CNSOYFIXN)THEN + DEF_USE_CNSOYFIXN = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Soy nitrogen fixation is on when CROP is off.' + write(*,*) 'DEF_USE_CNSOYFIXN is set to false automatically when CROP is turned off.' + ENDIF + + IF(DEF_USE_IRRIGATION)THEN + DEF_USE_IRRIGATION = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: irrigation is on when CROP is off.' + write(*,*) 'DEF_USE_IRRIGATION is set to false automatically when CROP is turned off.' + ENDIF +#endif + + IF(.not.(DEF_FERT_SOURCE == 1 .or. DEF_FERT_SOURCE == 2))THEN + write(*,*) ' ***** ' + write(*,'(A,I0,A)') 'ERROR: DEF_FERT_SOURCE is ',DEF_FERT_SOURCE,' , should only = 1 or 2' + CALL CoLM_stop () + ENDIF + + IF(.not. DEF_USE_OZONESTRESS)THEN + IF(DEF_USE_OZONEDATA)THEN + DEF_USE_OZONEDATA = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: DEF_USE_OZONEDATA is not supported for OZONESTRESS off.' + write(*,*) 'DEF_USE_OZONEDATA is set to false automatically.' + ENDIF + ENDIF + + IF(DEF_USE_MEDLYNST)THEN + IF(DEF_USE_WUEST)THEN + DEF_USE_MEDLYNST = .false. + DEF_USE_WUEST = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: configure conflict, both DEF_USE_MEDLYNST and DEF_USE_WUEST were set true.' + write(*,*) 'set both DEF_USE_MEDLYNST and DEF_USE_WUEST to false.' + ENDIF + ENDIF + +! ----- SNICAR model ------ Macros&Namelist conflicts and dependency management + + DEF_file_snowoptics = trim(DEF_dir_runtime)//'/snicar/snicar_optics_5bnd_mam_c211006.nc' + DEF_file_snowaging = trim(DEF_dir_runtime)//'/snicar/snicar_drdt_bst_fit_60_c070416.nc' + + IF (.not. DEF_USE_SNICAR) THEN + IF (DEF_Aerosol_Readin) THEN + DEF_Aerosol_Readin = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: DEF_Aerosol_Readin is not needed for DEF_USE_SNICAR off. ' + write(*,*) 'DEF_Aerosol_Readin is set to false automatically.' + ENDIF + ENDIF + + +! ----- Urban model ----- Macros&Namelist conflicts and dependency management + +#ifdef URBAN_MODEL + DEF_URBAN_RUN = .true. + + write(*,*) ' ***** ' + write(*,*) 'When URBAN model is opened, WUEST/SUPERCOOL_WATER/PLANTHYDRAULICS/OZONESTRESS/SOILSNOW' + write(*,*) 'will be set to false automatically for simplicity.' + DEF_USE_WUEST = .false. + DEF_USE_SUPERCOOL_WATER = .false. + DEF_USE_PLANTHYDRAULICS = .false. + DEF_USE_OZONESTRESS = .false. + DEF_USE_OZONEDATA = .false. + DEF_SPLIT_SOILSNOW = .false. +#else + IF (DEF_URBAN_RUN) THEN + write(*,*) ' ***** ' + write(*,*) 'Note: The Urban model is not opened. IF you want to run Urban model ' + write(*,*) 'please #define URBAN_MODEL in define.h. otherwise DEF_URBAN_RUN will ' + write(*,*) 'be set to false automatically.' + DEF_URBAN_RUN = .false. + ENDIF +#endif + + +! ----- LULCC ----- Macros&Namelist conflicts and dependency management + +#ifdef LULCC + + write(*,*) ' ***** ' + write(*,*) 'Warning: The LULCC data is provided for years 2000 to 2020 right now! ' + write(*,*) 'Please make sure the year range you set is suitable. ' + +#if (defined LULC_USGS || defined BGC) + write(*,*) ' ***** ' + write(*,*) 'Fatal ERROR: LULCC is not supported for LULC_USGS/BGC at present. STOP! ' + CALL CoLM_stop () +#endif + IF (.not.DEF_LAI_MONTHLY) THEN + write(*,*) ' ***** ' + write(*,*) 'Note: When LULCC is opened, DEF_LAI_MONTHLY ' + write(*,*) 'will be set to true automatically.' + DEF_LAI_MONTHLY = .true. + ENDIF + + IF (.not.DEF_LAI_CHANGE_YEARLY) THEN + write(*,*) ' ***** ' + write(*,*) 'Note: When LULCC is opened, DEF_LAI_CHANGE_YEARLY ' + write(*,*) 'will be set to true automatically.' + DEF_LAI_CHANGE_YEARLY = .true. + ENDIF + +#if (defined LULC_IGBP_PC || defined URBAN) + !write(*,*) ' ***** ' + !write(*,*) 'Fatal ERROR: LULCC is not supported for LULC_IGBP_PC/URBAN at present. STOP! ' + !write(*,*) 'It is coming soon. ' + !CALL CoLM_stop () + ![update] 24/10/2023: right now IGBP/PFT/PC and Urban are all supported. +#endif + +#if (defined SinglePoint) + write(*,*) ' ***** ' + write(*,*) 'Fatal ERROR: LULCC is not supported for Single Point run at present. STOP! ' + write(*,*) 'It will come later. ' + CALL CoLM_stop () +#endif + +#endif + +#if (defined DEF_LAI_CHANGE_YEARLY) + write(*,*) ' ***** ' + write(*,*) 'Warning: The LAI data is provided for years 2000 to 2020 right now! ' + write(*,*) 'Any year before 2000 or after 2020 will be treated as 2000 or 2020. ' +#endif + + +! ----- single point run ----- Macros&Namelist conflicts and dependency management + +#if (defined SinglePoint) +#ifdef SrfdataDiag + write(*,*) ' ***** ' + write(*,*) 'Surface data diagnose is closed in SinglePoint case.' +#undef SrfdataDiag +#endif + IF (trim(DEF_Forcing_Interp_Method) == 'bilinear') THEN + DEF_Forcing_Interp_Method = 'arealweight' + write(*,*) ' ***** ' + write(*,*) 'Bilinear interpolation is not supported in SinglePoint case.' + ENDIF +#endif + +! ----- Soil water and temperature Initialization ----- Namelist conflicts + + IF (DEF_USE_SoilInit .and. DEF_USE_WaterTableInit) THEN + write(*,*) ' ***** ' + write(*,*) 'If both DEF_USE_SoilInit and DEF_USE_WaterTableInit are .TRUE., ' + write(*,*) 'initial value of water table depth is read from DEF_file_SoilInit,' + write(*,*) 'instead of DEF_file_WaterTable (which is useless in this CASE). ' + ENDIF + +! ----- dynamic lake run ----- Macros&Namelist conflicts and dependency management + +#ifndef CATCHMENT + IF ((.not. DEF_USE_VariablySaturatedFlow) .and. DEF_USE_Dynamic_Lake) THEN + DEF_USE_Dynamic_Lake = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: Dynamic Lake is closed if variably saturated flow algorithm is not used.' + ENDIF + IF (DEF_USE_Dynamic_Lake) THEN + write(*,*) ' ***** ' + write(*,*) 'Warning: Dynamic Lake is not well supported without lateral flow.' + ENDIF +#else + DEF_USE_Dynamic_Lake = .true. + write(*,*) ' ***** ' + write(*,*) 'Warning: Dynamic Lake is used if CATCHMENT-based lateral flow used.' +#endif + +! ----- 2m WMO temperature ---- Macros&Namelist conflicts and dependency management + +#if !defined(GRIDBASED) || (defined LULC_IGBP || defined LULC_USGS) + IF (DEF_Output_2mWMO) THEN + DEF_Output_2mWMO = .false. + write(*,*) ' ***** ' + write(*,*) 'Warning: 2m WMO temperature is not well supported for IGBP and USGS' + write(*,*) 'DEF_Output_2mWMO will be set to false automatically.' + ENDIF +#endif + +! ----- [Complement IF needed] ----- Macros&Namelist conflicts and dependency management + + +! -----END Macros&Namelist conflicts and dependency management ----- +! =============================================================== + + + ENDIF + + +#ifdef MPAS_MPI + CALL mpi_bcast (DEF_Output_2mWMO ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_CASE_NAME ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_domain%edges ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_domain%edgen ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_domain%edgew ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_domain%edgee ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_BlockInfoFile ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_AverageElementSize ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_nx_blocks ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_ny_blocks ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_simulation_time%greenwich ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_simulation_time%start_year ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%start_month ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%start_day ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%start_sec ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_simulation_time%end_year ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%end_month ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%end_day ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%end_sec ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_simulation_time%spinup_year ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%spinup_month ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%spinup_day ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%spinup_sec ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_simulation_time%spinup_repeat ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_simulation_time%timestep ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_dir_rawdata ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_runtime ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_output ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_forcing ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_dir_landdata ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_restart ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_dir_history ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + +#if (defined GRIDBASED || defined UNSTRUCTURED) + CALL mpi_bcast (DEF_file_mesh ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_GRIDBASED_lon_res ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_GRIDBASED_lat_res ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) +#endif + +#ifdef CATCHMENT + CALL mpi_bcast (DEF_CatchmentMesh_data ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) +#endif + + CALL mpi_bcast (DEF_dir_existing_srfdata ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (USE_srfdata_from_larger_region ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (USE_srfdata_from_3D_gridded_data ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + ! 07/2023, added by yuan: subgrid setting related + CALL mpi_bcast (DEF_USE_LCT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_PFT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_PC ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_FAST_PC ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_PC_CROP_SPLIT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SOLO_PFT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SUBGRID_SCHEME ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_LAI_START_YEAR ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_LAI_END_YEAR ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_LAI_CHANGE_YEARLY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + ! 05/2023, added by Xingjie lu + CALL mpi_bcast (DEF_USE_LAIFEEDBACK ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_IRRIGATION ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_IRRIGATION_ALLOCATION ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_NOSTRESSNITROGEN ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_RSTFAC ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + ! LULC related + CALL mpi_bcast (DEF_LC_YEAR ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_LULCC_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_URBAN_type_scheme ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_geom_data ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + ! 05/2023, added by yuan + CALL mpi_bcast (DEF_URBAN_ONLY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_RUN ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_BEM ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_TREE ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_WATER ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_URBAN_LUCY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_CANYON_HWR ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + ! 06/2023, added by weinan + CALL mpi_bcast (DEF_USE_SOILPAR_UPS_FIT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_THERMAL_CONDUCTIVITY_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_SUPERCOOL_WATER ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + ! 06/2023, added by hua yuan + CALL mpi_bcast (DEF_SOIL_REFL_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + ! 07/2023, added by zhuo liu + CALL mpi_bcast (DEF_RSS_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + ! 02/2024, added by Shupeng Zhang + CALL mpi_bcast (DEF_Runoff_SCHEME ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_VIC_OPT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_VIC_para ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_VIC_OPT ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_TOPMOD_method ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + ! 08/2023, added by hua yuan + CALL mpi_bcast (DEF_SPLIT_SOILSNOW ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_VEG_SNOW ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_LAI_MONTHLY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_NDEP_FREQUENCY ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_Interception_scheme ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SSP ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_CBL_HEIGHT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_PLANTHYDRAULICS ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_MEDLYNST ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_WUEST ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_SASU ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_DiagMatrix ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_PN ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_FERT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_FERT_SOURCE ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_NITRIF ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_CNSOYFIXN ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_FIRE ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_Dynamic_Lake ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_Dynamic_Wetland ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_CheckEquilibrium ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_LANDONLY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_DOMINANT_PATCHTYPE ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_VariablySaturatedFlow ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_BEDROCK ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_OZONESTRESS ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_OZONEDATA ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_precip_phase_discrimination_scheme ,5 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_SoilInit ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_SoilInit ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_HighResSoil ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HighResVeg ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_PROSPECT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HighResUrban_albedo ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_SnowInit ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_SnowInit ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_CN_INIT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_cn_init ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_WaterTableInit ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_WaterTable ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_SNICAR ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_snowoptics ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_file_snowaging ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_ElementNeighbour_file ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_UnitCatchment_file ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_ReservoirPara_file ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_DA_obsdir ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_TWS ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_TWS_GRACE ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_SM ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_ENS_NUM ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_ENS_SM ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_SM_SMAP ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_SM_FY ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_SM_SYNOP ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_RTM_diel ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DA_RTM_rough ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_Optimize_Baseflow ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_Aerosol_Readin ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_Aerosol_Clim ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_EstimatedRiverDepth ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_Reservoir_Method ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_GRIDBASED_ROUTING_MAX_DT ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_USE_SEDIMENT ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_LAMBDA ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_LYRDPH ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_DENSITY ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_WATER_DENSITY ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_VISKIN ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_VONKAR ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_PSET ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_TOTLYRNUM ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_CFL_ADV ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_IGNORE_DPH ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_DT_MAX ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_DIAMETER ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_PYLD ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_PYLDC ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_PYLDPC ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_SED_DSYLUNIT ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_HISTORY_IN_VECTOR ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_HIST_lon_res ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_lat_res ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_HIST_grid_as_forcing ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_WRST_FREQ ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_FREQ ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_groupby ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_mode ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_WriteBack ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_REST_CompressLevel ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_HIST_CompressLevel ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + CALL mpi_bcast (DEF_Forcing_Interp_Method ,20 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_Forcing_Downscaling ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_Forcing_Downscaling_Simple ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DS_HiresTopographyDataDir ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DS_precipitation_adjust_scheme ,5 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_DS_longwave_adjust_scheme ,5 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_USE_ClimForcing_for_Spinup ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + +#ifndef MPAS_EMBEDDED_COLM + CALL mpi_bcast (DEF_forcing%dataset ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%solarin_all_band ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%HEIGHT_mode ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%HEIGHT_V ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%HEIGHT_T ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%HEIGHT_Q ,1 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%regional ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%regbnd ,4 ,mpi_real8 ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%has_missing_value ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%missing_value_name ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%NVAR ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%startyr ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%startmo ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%endyr ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%endmo ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%dtime ,8 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%offset ,8 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%nlands ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%leapyear ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%data2d ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%hightdim ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%dim2d ,1 ,mpi_logical ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%latname ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%lonname ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%groupby ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + + DO ivar = 1, 8 + CALL mpi_bcast (DEF_forcing%fprefix(ivar) ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%vname(ivar) ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%timelog(ivar) ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%tintalgo(ivar) ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + ENDDO + CALL mpi_bcast (DEF_forcing%CBL_fprefix ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%CBL_vname ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%CBL_tintalgo ,256 ,mpi_character ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%CBL_dtime ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) + CALL mpi_bcast (DEF_forcing%CBL_offset ,1 ,mpi_integer ,mpas_root ,mpas_comm ,mpas_mpi_ierr) +#endif + CALL mpas_mpi_check('CoLM namelist broadcast') +#endif + +#ifndef MPAS_EMBEDDED_COLM + CALL sync_hist_vars (set_defaults = .true.) + + IF (mpas_is_root) THEN + + inquire (file=trim(DEF_HIST_vars_namelist), exist=fexists) + IF (.not. fexists) THEN + write(*,*) 'History namelist file: ', trim(DEF_HIST_vars_namelist), ' does not exist.' + ELSE + open(10, status='OLD', file=trim(DEF_HIST_vars_namelist), form="FORMATTED") + read(10, nml=nl_colm_history, iostat=ierr, iomsg=iomesg) + IF (ierr /= 0) THEN + write(*,*) 'ERROR in ', trim(DEF_HIST_vars_namelist), ' : ', trim(iomesg) + CALL CoLM_Stop (' ***** ERROR: Problem reading namelist: ' & + // trim(DEF_HIST_vars_namelist)) + ENDIF + close(10) + ENDIF + + IF(DEF_USE_DiagMatrix)THEN + DEF_hist_vars%leafcCap = .true. + DEF_hist_vars%leafc_storageCap = .true. + DEF_hist_vars%leafc_xferCap = .true. + DEF_hist_vars%frootcCap = .true. + DEF_hist_vars%frootc_storageCap = .true. + DEF_hist_vars%frootc_xferCap = .true. + DEF_hist_vars%livestemcCap = .true. + DEF_hist_vars%livestemc_storageCap = .true. + DEF_hist_vars%livestemc_xferCap = .true. + DEF_hist_vars%deadstemcCap = .true. + DEF_hist_vars%deadstemc_storageCap = .true. + DEF_hist_vars%deadstemc_xferCap = .true. + DEF_hist_vars%livecrootcCap = .true. + DEF_hist_vars%livecrootc_storageCap = .true. + DEF_hist_vars%livecrootc_xferCap = .true. + DEF_hist_vars%deadcrootcCap = .true. + DEF_hist_vars%deadcrootc_storageCap = .true. + DEF_hist_vars%deadcrootc_xferCap = .true. + DEF_hist_vars%leafnCap = .true. + DEF_hist_vars%leafn_storageCap = .true. + DEF_hist_vars%leafn_xferCap = .true. + DEF_hist_vars%frootnCap = .true. + DEF_hist_vars%frootn_storageCap = .true. + DEF_hist_vars%frootn_xferCap = .true. + DEF_hist_vars%livestemnCap = .true. + DEF_hist_vars%livestemn_storageCap = .true. + DEF_hist_vars%livestemn_xferCap = .true. + DEF_hist_vars%deadstemnCap = .true. + DEF_hist_vars%deadstemn_storageCap = .true. + DEF_hist_vars%deadstemn_xferCap = .true. + DEF_hist_vars%livecrootnCap = .true. + DEF_hist_vars%livecrootn_storageCap = .true. + DEF_hist_vars%livecrootn_xferCap = .true. + DEF_hist_vars%deadcrootnCap = .true. + DEF_hist_vars%deadcrootn_storageCap = .true. + DEF_hist_vars%deadcrootn_xferCap = .true. + DEF_hist_vars%t_scalar = .true. + DEF_hist_vars%w_scalar = .true. + + DEF_hist_vars%litr1cCap_vr = .true. + DEF_hist_vars%litr2cCap_vr = .true. + DEF_hist_vars%litr3cCap_vr = .true. + DEF_hist_vars%soil1cCap_vr = .true. + DEF_hist_vars%soil2cCap_vr = .true. + DEF_hist_vars%soil3cCap_vr = .true. + DEF_hist_vars%cwdcCap_vr = .true. + DEF_hist_vars%litr1nCap_vr = .true. + DEF_hist_vars%litr2nCap_vr = .true. + DEF_hist_vars%litr3nCap_vr = .true. + DEF_hist_vars%soil1nCap_vr = .true. + DEF_hist_vars%soil2nCap_vr = .true. + DEF_hist_vars%soil3nCap_vr = .true. + DEF_hist_vars%cwdnCap_vr = .true. + ENDIF + ENDIF + + CALL sync_hist_vars (set_defaults = .false.) +#endif + + END SUBROUTINE read_namelist + + ! --------------- + SUBROUTINE sync_hist_vars (set_defaults) + + IMPLICIT NONE + + logical, intent(in) :: set_defaults + + CALL sync_hist_vars_one (DEF_hist_vars%xy_us , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_vs , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_t , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_q , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_prc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_prl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_pbot , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_frl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_solarin , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_rain , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xy_snow , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%xy_hpbl , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%taux , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tauy , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsena , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevpa , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fevpa , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsenl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fevpl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%etr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fseng , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fevpg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fgrnd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sabvsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sabvsha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sabg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%olrg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rnet , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xerr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%zerr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rsur , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rsur_se , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rsur_ie , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rsub , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rnof , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xwsur , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xwsub , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fldarea , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qintr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qinfl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qdrip , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wat_inst , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wetwat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wetwat_inst , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wetzwt , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%assim , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%respc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qcharge , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_grnd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tleaf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%ldew , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%scv , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%snowdp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsno , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frcsat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sigf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%green , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%laisun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%laisha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sai , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%alb , set_defaults) +#ifdef HYPERSPECTRAL + CALL sync_hist_vars_one (DEF_hist_vars%alb_hires , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%reflectance_out , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%transmittance_out , set_defaults) +#endif + CALL sync_hist_vars_one (DEF_hist_vars%emis , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%z0m , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%trad , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rss , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tref , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t2m_wmo , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qref , set_defaults) +#ifdef URBAN_MODEL + CALL sync_hist_vars_one (DEF_hist_vars%fsen_roof , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_wsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_wsha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_gimp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_gper , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fsen_urbl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevp_roof , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevp_gimp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevp_gper , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lfevp_urbl , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fhac , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fwst , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fach , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fhah , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%meta , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%vehc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_room , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tafu , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_roof , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_wall , set_defaults) +#endif + CALL sync_hist_vars_one (DEF_hist_vars%assimsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%assimsha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%etrsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%etrsha , set_defaults) +#ifdef BGC + CALL sync_hist_vars_one (DEF_hist_vars%leafc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainc_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainc_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainn_storage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainn_xfer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%retrasn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%downreg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%ar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdprod , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwddecomp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%hr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fpg , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fpi , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totvegc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totlitc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totcwdc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totsomc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totcolc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totvegn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totlitn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totcwdn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totsomn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totcoln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%totsoiln_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gpp_c4grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_c4grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lai_c4grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npp_c4grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_enftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_enfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dnfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_ebftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_ebftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbftrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbftemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbfboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_ebstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbstemp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_dbsboreal , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_c3arcgrass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_c3grass , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%npptoleafc_c4grass , set_defaults) +#ifdef CROP + CALL sync_hist_vars_one (DEF_hist_vars%cphase , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gddmaturity , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gddplant , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%vf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%hui , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprod1c , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprod1c_loss , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropseedc_deficit , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%grainc_to_cropprodc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_temp_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_temp_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_spwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_spwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_wtwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_wtwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_temp_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_temp_soybean, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_rice , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_rice , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_sugarcane , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_sugarcane , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_trop_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_trop_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_rainfed_trop_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_irrigated_trop_soybean, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%plantdate_unmanagedcrop , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_temp_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_temp_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_spwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_spwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_wtwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_wtwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_temp_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_temp_soybean, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_rice , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_rice , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_sugarcane , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_sugarcane , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_trop_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_trop_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_rainfed_trop_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_irrigated_trop_soybean, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cropprodc_unmanagedcrop , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%grainc_to_seed , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fert_to_sminn , set_defaults) + + IF(DEF_USE_FERT)THEN + CALL sync_hist_vars_one (DEF_hist_vars%manunitro , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_corn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_swheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_wwheat , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_soybean , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_cotton , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_rice1 , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_rice2 , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fertnitro_sugarcane , set_defaults) + ENDIF + + IF(DEF_USE_IRRIGATION)THEN + CALL sync_hist_vars_one (DEF_hist_vars%sum_irrig , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sum_deficit_irrig , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sum_irrig_count , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%waterstorage , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%groundwater_demand , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%groundwater_supply , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%reservoirriver_demand , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%reservoirriver_supply , set_defaults) + ENDIF +#endif + CALL sync_hist_vars_one (DEF_hist_vars%ndep_to_sminn , set_defaults) + IF(DEF_USE_NITRIF)THEN + CALL sync_hist_vars_one (DEF_hist_vars%CONC_O2_UNSAT , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT , set_defaults) + ENDIF + IF(DEF_USE_FIRE)THEN + CALL sync_hist_vars_one (DEF_hist_vars%abm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gdp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%peatf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%hdm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lnfm , set_defaults) + ENDIF + CALL sync_hist_vars_one (DEF_hist_vars%leafcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootcCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootc_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%leafn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%frootn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livestemn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadstemn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%livecrootn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootnCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn_storageCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%deadcrootn_xferCap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_scalar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%w_scalar , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%litr1cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr2cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr3cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil1cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil2cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil3cCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdcCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr1nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr2nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr3nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil1nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil2nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil3nCap_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdnCap_vr , set_defaults) +#endif + IF(DEF_USE_OZONESTRESS)THEN + CALL sync_hist_vars_one (DEF_hist_vars%o3uptakesun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%o3uptakesha , set_defaults) + ENDIF + +#ifdef DataAssimilation + CALL sync_hist_vars_one (DEF_hist_vars%DA_wliq_h2osoi_5cm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_wliq_h2osoi_5cm_a , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_soisno_5cm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_soisno_5cm_a , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_wliq_soisno_ens , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_soisno_ens , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_wliq_soisno_5cm_ens_std, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_soisno_5cm_ens_std , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_smap , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_smap_a , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_smap_ens , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_smap_ens_std , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_fy3d , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_fy3d_a , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_fy3d_ens , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%DA_t_brt_fy3d_ens_std , set_defaults) +#endif + + CALL sync_hist_vars_one (DEF_hist_vars%t_soisno , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wliq_soisno , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wice_soisno , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%h2osoi , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qlayer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lake_deficit, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rstfacsun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rstfacsha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gssun , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%gssha , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rootr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%vegwp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%BD_all , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wfc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%OM_density , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wdsrf , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wdsrf_inst , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%zwt , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wa , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wa_inst , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%dz_lake , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%t_lake , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%lake_icefrac, set_defaults) + +#ifdef BGC + CALL sync_hist_vars_one (DEF_hist_vars%litr1c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr2c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr3c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil1c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil2c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil3c_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdc_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr1n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr2n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%litr3n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil1n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil2n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%soil3n_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%cwdn_vr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sminn_vr , set_defaults) +#endif + + CALL sync_hist_vars_one (DEF_hist_vars%ustar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%ustar2 , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%tstar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qstar , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%zol , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%rib , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fm , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fh , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fq , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%us10m , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%vs10m , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%fm10m , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sr , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solvd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solvi , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solnd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solni , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srvd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srvi , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srnd , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srni , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%solvdln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solviln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solndln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%solniln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srvdln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srviln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srndln , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%srniln , set_defaults) +#ifdef HYPERSPECTRAL + CALL sync_hist_vars_one (DEF_hist_vars%sol_dir_ln_hires, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sol_dif_ln_hires, set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sr_dir_ln_hires , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sr_dif_ln_hires , set_defaults) +#endif + + CALL sync_hist_vars_one (DEF_hist_vars%xsubs_bsn , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%xsubs_hru , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%riv_height , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%riv_veloct , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%discharge , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%floodarea , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%floodfrc , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%wdsrf_hru , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%veloc_hru , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%volresv , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qresv_in , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%qresv_out , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%sedcon , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sedout , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%bedout , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sedinp , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%netflw , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%sedlayer , set_defaults) + CALL sync_hist_vars_one (DEF_hist_vars%shearvel , set_defaults) + + CALL sync_hist_vars_one (DEF_hist_vars%sensors , set_defaults) + + END SUBROUTINE sync_hist_vars + + SUBROUTINE sync_hist_vars_one (onoff, set_defaults) + + USE MOD_MPAS_MPI + IMPLICIT NONE + + logical, intent(inout) :: onoff + logical, intent(in) :: set_defaults + + IF (mpas_is_root) THEN + IF (set_defaults) THEN + onoff = DEF_HIST_vars_out_default + ENDIF + ENDIF + +#ifdef MPAS_MPI + CALL mpi_bcast (onoff, 1, mpi_logical, mpas_root, mpas_comm, mpas_mpi_ierr) +#endif + + END SUBROUTINE sync_hist_vars_one + +END MODULE MOD_Namelist diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 new file mode 100644 index 0000000000..25c100fba1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFBlock.F90 @@ -0,0 +1,461 @@ +#include + +MODULE MOD_NetCDFBlock + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! High-level Subroutines to read and write variables in files with netCDF format. +! +! CoLM read and write netCDF files mainly in three ways: +! 1. Serial: read and write data by a single process; +! 2. Vector: read/write data associated with CoLM pixelsets +! Notice: each file contains vector data in one block. +! 3. Block : read blocked data by IO +! Notice: input file is a single file. +! +! This MODULE contains subroutines of "3. Block". +! +! Created by Shupeng Zhang, May 2023 +!---------------------------------------------------------------------------------- + + USE netcdf + USE MOD_NetCDFSerial + IMPLICIT NONE + + ! PUBLIC subroutines + INTERFACE ncio_read_block + MODULE procedure ncio_read_block_int32_2d + MODULE procedure ncio_read_block_real8_2d + MODULE procedure ncio_read_block_real8_3d + END INTERFACE ncio_read_block + + INTERFACE ncio_read_block_time + MODULE procedure ncio_read_block_int32_2d_time + MODULE procedure ncio_read_block_real8_2d_time + MODULE procedure ncio_read_block_real8_3d_time + END INTERFACE ncio_read_block_time + + PUBLIC :: ncio_read_site_time + +CONTAINS + + ! ---- + SUBROUTINE ncio_read_block_int32_2d (filename, dataname, grid, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + + type (block_data_int32_2d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(2), start2(2), count2(2), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (.true.) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start2 = (/grid%xdsp(iblk)+1, grid%ydsp(jblk)+1/) + count2(1) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count2(2) = grid%ycnt(jblk) + + IF (count2(1) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start2, count2) ) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(1:count2(1),:), start2, count2) ) + + start2(1) = 1 + start_mem = count2(1) + 1 + count2(1) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(start_mem:ndims(1),:), start2, count2) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_int32_2d + + ! ---- + SUBROUTINE ncio_read_block_real8_2d (filename, dataname, grid, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(2), start2(2), count2(2), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (.true.) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start2 = (/grid%xdsp(iblk)+1, grid%ydsp(jblk)+1/) + count2(1) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count2(2) = grid%ycnt(jblk) + + IF (count2(1) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start2, count2) ) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(1:count2(1),:), start2, count2) ) + + start2(1) = 1 + start_mem = count2(1) + 1 + count2(1) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(start_mem:ndims(1),:), start2, count2) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_real8_2d + + ! ---- + SUBROUTINE ncio_read_block_real8_3d (filename, dataname, grid, ndim1, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: ndim1 + + type (block_data_real8_3d), intent(inout) :: rdata + integer :: ncid, varid + + ! Local variables + integer :: iblk, jblk, ndims(3), start3(3), count3(3), start_mem + integer :: iblkme + + IF (.true.) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/ndim1, grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start3 = (/1, grid%xdsp(iblk)+1, grid%ydsp(jblk)+1/) + count3(1) = ndim1 + count3(2) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count3(3) = grid%ycnt(jblk) + + IF (count3(2) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start3, count3) ) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,1:count3(2),:), start3, count3) ) + + start3(2) = 1 + start_mem = count3(2) + 1 + count3(2) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,start_mem:ndims(2),:), start3, count3) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_real8_3d + + ! ---- + SUBROUTINE ncio_read_block_int32_2d_time (filename, dataname, grid, itime, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime + + type (block_data_int32_2d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(2), start3(3), count3(3), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (.true.) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start3 = (/grid%xdsp(iblk)+1, grid%ydsp(jblk)+1, itime/) + count3(1) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count3(2) = grid%ycnt(jblk) + count3(3) = 1 + + IF (count3(1) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start3, count3) ) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(1:count3(1),:), start3, count3) ) + + start3(1) = 1 + start_mem = count3(1) + 1 + count3(1) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(start_mem:ndims(1),:), start3, count3) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_int32_2d_time + + ! ---- + SUBROUTINE ncio_read_block_real8_2d_time (filename, dataname, grid, itime, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: itime + + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(2), start3(3), count3(3), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (.true.) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start3 = (/grid%xdsp(iblk)+1, grid%ydsp(jblk)+1, itime/) + count3(1) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count3(2) = grid%ycnt(jblk) + count3(3) = 1 + IF (count3(1) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start3, count3) ,trace=trim(filename)) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(1:count3(1),:), start3, count3) ) + + start3(1) = 1 + start_mem = count3(1) + 1 + count3(1) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(start_mem:ndims(1),:), start3, count3) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_real8_2d_time + + ! ---- + SUBROUTINE ncio_read_block_real8_3d_time (filename, dataname, grid, ndim1, itime, rdata) + + USE netcdf + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + type (grid_type), intent(in) :: grid + integer, intent(in) :: ndim1, itime + + type (block_data_real8_3d), intent(inout) :: rdata + + ! Local variables + integer :: iblk, jblk, ndims(3), start4(4), count4(4), start_mem + integer :: ncid, varid + integer :: iblkme + + IF (.true.) THEN + + CALL check_ncfile_exist (filename) + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid) ,trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + ndims = (/ndim1, grid%xcnt(iblk), grid%ycnt(jblk)/) + IF (any(ndims == 0)) CYCLE + + start4 = (/1, grid%xdsp(iblk)+1, grid%ydsp(jblk)+1, itime/) + count4(1) = ndim1 + count4(2) = min(grid%xcnt(iblk), grid%nlon-grid%xdsp(iblk)) + count4(3) = grid%ycnt(jblk) + count4(4) = 1 + IF (count4(2) == grid%xcnt(iblk)) THEN + CALL nccheck (nf90_get_var(ncid, varid, rdata%blk(iblk,jblk)%val, & + start4, count4) ,trace=trim(filename)) + ELSE + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,1:count4(2),:), start4, count4) ) + + start4(2) = 1 + start_mem = count4(2) + 1 + count4(2) = grid%xdsp(iblk) + grid%xcnt(iblk) - grid%nlon + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(iblk,jblk)%val(:,start_mem:ndims(2),:), start4, count4) ) + ENDIF + + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + ENDIF + + END SUBROUTINE ncio_read_block_real8_3d_time + + ! ---- + SUBROUTINE ncio_read_site_time (filename, dataname, itime, rdata) + + USE netcdf + USE MOD_Block + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Namelist + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + + type (block_data_real8_2d), intent(inout) :: rdata + + ! Local variables + integer :: start3(3), count3(3) + integer :: varid, dimid + character(len=256), SAVE :: fileopen = 'null' + integer, SAVE :: ncid, time_dim + logical, SAVE :: fid = .false. + + IF (.true.) THEN + CALL check_ncfile_exist (filename) + + IF ((.not. fid) .or. (trim(fileopen) /= trim(filename))) THEN + fid = .true. + fileopen = trim(filename) + + CALL nccheck (nf90_open(trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + + CALL nccheck (nf90_inq_dimid(ncid, 'time', dimid), trace=trim(filename)) + CALL nccheck (nf90_inquire_dimension(ncid, dimid, len=time_dim), trace=trim(filename)) + ENDIF + + CALL nccheck (nf90_inq_varid(ncid, trim(dataname), varid) ,trace=trim(dataname)//' in file '//trim(filename)) + + start3 = (/1, 1, itime/) + count3 = (/1, 1, 1/) + CALL nccheck (nf90_get_var(ncid, varid, & + rdata%blk(gblock%xblkme(1),gblock%yblkme(1))%val, start3, count3) ) + + IF ((itime==time_dim) .and. trim(dataname)==DEF_forcing%vname(DEF_forcing%NVAR)) THEN + CALL nccheck( nf90_close(ncid) ) + ENDIF + + ENDIF + + END SUBROUTINE ncio_read_site_time + +END MODULE MOD_NetCDFBlock diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFPoint.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFPoint.F90 new file mode 100644 index 0000000000..95e7615a95 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFPoint.F90 @@ -0,0 +1,425 @@ +#include + +MODULE MOD_NetCDFPoint + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! High-level Subroutines to read and write variables in files with netCDF format. +! Read data for single point run. +! +! Created by Shupeng Zhang, March 2025 +!---------------------------------------------------------------------------------- + + USE netcdf + USE MOD_Precision + USE MOD_Grid + USE MOD_Utils + USE MOD_NetCDFSerial, only : nccheck + IMPLICIT NONE + + ! PUBLIC subroutines + PUBLIC :: read_point_var_2d_int32 + PUBLIC :: read_point_var_2d_real8 + PUBLIC :: read_point_var_3d_real8 + PUBLIC :: read_point_var_3d_first_real8 + PUBLIC :: read_point_var_2d_time_real8 + PUBLIC :: read_point_var_3d_time_real8 + PUBLIC :: read_point_5x5_var_2d_int32 + PUBLIC :: read_point_5x5_var_2d_real8 + PUBLIC :: read_point_5x5_var_3d_real8 + PUBLIC :: read_point_5x5_var_2d_time_real8 + PUBLIC :: read_point_5x5_var_3d_time_real8 + +CONTAINS + + ! ------ + SUBROUTINE read_point_var_2d_int32 (grid, filename, varname, site_lon, site_lat, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + integer, intent(out) :: rdata + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + integer :: rcache(1) + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, (/ilon,ilat/), (/1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_var_2d_int32 + + ! ------ + SUBROUTINE read_point_var_2d_real8 (grid, filename, varname, site_lon, site_lat, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + real(r8), intent(out) :: rdata + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + real(r8) :: rcache(1) + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, (/ilon,ilat/), (/1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_var_2d_real8 + + ! ------ + SUBROUTINE read_point_var_3d_real8 (grid, filename, varname, site_lon, site_lat, nlastdim, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nlastdim + + real(r8), allocatable, intent(out) :: rdata(:) + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + allocate (rdata (nlastdim)) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, (/ilon,ilat,1/), (/1,1,nlastdim/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_var_3d_real8 + + ! ------ + SUBROUTINE read_point_var_3d_first_real8 (grid, filename, varname, site_lon, site_lat, nfirstdim, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nfirstdim + + real(r8), allocatable, intent(out) :: rdata(:) + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + allocate (rdata (nfirstdim)) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, (/1,ilon,ilat/), (/nfirstdim,1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_var_3d_first_real8 + + ! ------ + SUBROUTINE read_point_var_2d_time_real8 (grid, filename, varname, site_lon, site_lat, itime, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: itime + + real(r8), intent(out) :: rdata + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + real(r8) :: rcache(1) + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, (/ilon,ilat,itime/), (/1,1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_var_2d_time_real8 + + ! ------ + SUBROUTINE read_point_var_3d_time_real8 (grid, filename, varname, site_lon, site_lat, nlastdim, itime, rdata) + + IMPLICIT NONE + + type(grid_type), intent(in) :: grid + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nlastdim + integer, intent(in) :: itime + + real(r8), allocatable, intent(out) :: rdata(:) + + ! local variables + integer :: ilat, ilon + integer :: ncid, varid + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + allocate (rdata (nlastdim)) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, (/ilon,ilat,1,itime/), (/1,1,nlastdim,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_var_3d_time_real8 + + ! ----- + SUBROUTINE get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, file_5x5, start2) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + character (len=*), intent(out) :: file_5x5 + integer, intent(out) :: start2(2) + + ! local variables + integer :: ilon, ilat, nxbox, nybox, ibox, jbox + character (len=4) :: str + + ilon = find_nearest_west (site_lon, grid%nlon, grid%lon_w) + ilat = find_nearest_south (site_lat, grid%nlat, grid%lat_s) + + nxbox = grid%nlon / 360 * 5 + nybox = grid%nlat / 180 * 5 + + ibox = (ilon-1)/nxbox + 1 + jbox = (ilat-1)/nybox + 1 + start2(1) = ilon - (ibox-1)*nxbox + start2(2) = ilat - (jbox-1)*nybox + + file_5x5 = trim(dir_5x5) // '/RG' + write(str, '(I4)') (19-jbox)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (ibox-37)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (18-jbox)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + write(str, '(I4)') (ibox-36)*5 + file_5x5 = trim(file_5x5) // '_' // trim(adjustl(str)) + file_5x5 = trim(file_5x5) // '.' // trim(sfx) // '.nc' + + END SUBROUTINE get_5x5_filename + + ! ----- + SUBROUTINE read_point_5x5_var_2d_int32 (grid, dir_5x5, sfx, varname, site_lon, site_lat, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + integer, intent(out) :: rdata + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start2(2) + integer :: rcache(1) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start2) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, start2, (/1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_5x5_var_2d_int32 + + ! ----- + SUBROUTINE read_point_5x5_var_2d_real8 (grid, dir_5x5, sfx, varname, site_lon, site_lat, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + + real(r8), intent(out) :: rdata + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start2(2) + real(r8) :: rcache(1) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start2) + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, start2, (/1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_5x5_var_2d_real8 + + ! ----- + SUBROUTINE read_point_5x5_var_3d_real8 (grid, dir_5x5, sfx, varname, site_lon, site_lat, nlastdim, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nlastdim + + real(r8), allocatable, intent(out) :: rdata(:) + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start3(3) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start3(1:2)) + + allocate (rdata (nlastdim)) + + start3(3) = 1 + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, start3, (/1,1,nlastdim/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_5x5_var_3d_real8 + + ! ----- + SUBROUTINE read_point_5x5_var_2d_time_real8 (grid, dir_5x5, sfx, varname, site_lon, site_lat, itime, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: itime + + real(r8), intent(out) :: rdata + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start3(3) + real(r8) :: rcache(1) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start3(1:2)) + + start3(3) = itime + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rcache, start3, (/1,1,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + rdata = rcache(1) + + END SUBROUTINE read_point_5x5_var_2d_time_real8 + + ! ----- + SUBROUTINE read_point_5x5_var_3d_time_real8 (grid, dir_5x5, sfx, varname, & + site_lon, site_lat, nlastdim, itime, rdata) + + IMPLICIT NONE + + type (grid_type), intent(in) :: grid + character (len=*), intent(in) :: dir_5x5 + character (len=*), intent(in) :: sfx + character (len=*), intent(in) :: varname + + real(r8), intent(in) :: site_lon + real(r8), intent(in) :: site_lat + integer, intent(in) :: nlastdim + integer, intent(in) :: itime + + real(r8), allocatable, intent(out) :: rdata(:) + + ! Local variables + character(len=256) :: filename + integer :: ncid, varid, start4(4) + + CALL get_5x5_filename (grid, dir_5x5, sfx, site_lon, site_lat, filename, start4(1:2)) + + allocate (rdata (nlastdim)) + + start4(3) = 1 + start4(4) = itime + + CALL nccheck (nf90_open (trim(filename), NF90_NOWRITE, ncid), trace=trim(filename)//' cannot open') + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trace=trim(varname)//' in file '//trim(filename)) + CALL nccheck (nf90_get_var (ncid, varid, rdata, start4, (/1,1,nlastdim,1/)) ) + CALL nccheck (nf90_close (ncid) ) + + END SUBROUTINE read_point_5x5_var_3d_time_real8 + +END MODULE MOD_NetCDFPoint diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 new file mode 100644 index 0000000000..5b7c5d655d --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90 @@ -0,0 +1,2637 @@ +#include + +MODULE MOD_NetCDFSerial + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! High-level Subroutines to read and write variables in files with netCDF format. +! +! CoLM read and write netCDF files mainly in three ways: +! 1. Serial: read and write data by a single process; +! 2. Vector: read/write data associated with CoLM pixelsets +! Notice: each file CONTAINS vector data in one block. +! 3. Block : read blocked data by IO +! Notice: input file is a single file. +! +! This MODULE CONTAINS subroutines of "1. Serial". +! +! Created by Shupeng Zhang, May 2023 +!---------------------------------------------------------------------------------- + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + ! PUBLIC subroutines + + PUBLIC :: ncio_create_file + PUBLIC :: check_ncfile_exist + + INTERFACE ncio_put_attr + MODULE procedure ncio_put_attr_str + MODULE procedure ncio_put_attr_real8 + END INTERFACE ncio_put_attr + + INTERFACE ncio_get_attr + MODULE procedure ncio_get_attr_str + MODULE procedure ncio_get_attr_real8 + END INTERFACE ncio_get_attr + + PUBLIC :: ncio_var_exist + PUBLIC :: ncio_inquire_varsize + PUBLIC :: ncio_inquire_length + + INTERFACE ncio_read_serial + MODULE procedure ncio_read_serial_int32_0d + MODULE procedure ncio_read_serial_real8_0d + MODULE procedure ncio_read_serial_int8_1d + MODULE procedure ncio_read_serial_int32_1d + MODULE procedure ncio_read_serial_int64_1d + MODULE procedure ncio_read_serial_real8_1d + MODULE procedure ncio_read_serial_int8_2d + MODULE procedure ncio_read_serial_int16_2d + MODULE procedure ncio_read_serial_int32_2d + MODULE procedure ncio_read_serial_real4_2d + MODULE procedure ncio_read_serial_real8_2d + MODULE procedure ncio_read_serial_int32_3d + MODULE procedure ncio_read_serial_real8_3d + MODULE procedure ncio_read_serial_real8_4d + MODULE procedure ncio_read_serial_real8_5d + END INTERFACE ncio_read_serial + + INTERFACE ncio_read_bcast_serial + MODULE procedure ncio_read_bcast_serial_int32_0d + MODULE procedure ncio_read_bcast_serial_real8_0d + MODULE procedure ncio_read_bcast_serial_int32_1d + MODULE procedure ncio_read_bcast_serial_int32_2d + MODULE procedure ncio_read_bcast_serial_real8_1d + MODULE procedure ncio_read_bcast_serial_real8_2d + MODULE procedure ncio_read_bcast_serial_real8_3d + MODULE procedure ncio_read_bcast_serial_real8_4d + MODULE procedure ncio_read_bcast_serial_real8_5d + MODULE procedure ncio_read_bcast_serial_logical_1d + END INTERFACE ncio_read_bcast_serial + + INTERFACE ncio_read_part_serial + MODULE procedure ncio_read_part_serial_int32_1d + MODULE procedure ncio_read_part_serial_int32_2d + MODULE procedure ncio_read_part_serial_real8_2d + END INTERFACE ncio_read_part_serial + + INTERFACE ncio_read_indexed_serial + MODULE procedure ncio_read_indexed_serial_int32_1d + MODULE procedure ncio_read_indexed_serial_real8_1d + MODULE procedure ncio_read_indexed_serial_int32_2d + MODULE procedure ncio_read_indexed_serial_real8_2d + END INTERFACE ncio_read_indexed_serial + + PUBLIC :: ncio_read_indexed_serial + + INTERFACE ncio_read_period_serial + MODULE procedure ncio_read_period_serial_real8_2d + END INTERFACE ncio_read_period_serial + + + INTERFACE ncio_define_dimension + MODULE procedure ncio_define_dimension_int32 + MODULE procedure ncio_define_dimension_int64 + END INTERFACE ncio_define_dimension + + INTERFACE ncio_write_serial + MODULE procedure ncio_write_serial_int32_0d + MODULE procedure ncio_write_serial_real8_0d + MODULE procedure ncio_write_serial_int8_1d + MODULE procedure ncio_write_serial_int32_1d + MODULE procedure ncio_write_serial_int64_1d + MODULE procedure ncio_write_serial_real8_1d + MODULE procedure ncio_write_serial_logical_1d + MODULE procedure ncio_write_serial_int8_2d + MODULE procedure ncio_write_serial_int16_2d + MODULE procedure ncio_write_serial_int32_2d + MODULE procedure ncio_write_serial_int64_2d + MODULE procedure ncio_write_serial_real4_2d + MODULE procedure ncio_write_serial_real8_2d + MODULE procedure ncio_write_serial_int32_3d + MODULE procedure ncio_write_serial_real8_3d + MODULE procedure ncio_write_serial_real8_4d + MODULE procedure ncio_write_serial_real8_5d + END INTERFACE ncio_write_serial + + PUBLIC :: ncio_write_serial + PUBLIC :: ncio_write_time + PUBLIC :: ncio_write_lastdim + + INTERFACE ncio_write_serial_time + MODULE procedure ncio_write_serial_real8_0d_time + MODULE procedure ncio_write_serial_real8_1d_time + MODULE procedure ncio_write_serial_real8_2d_time + MODULE procedure ncio_write_serial_real8_3d_time + MODULE procedure ncio_write_serial_real8_4d_time + END INTERFACE ncio_write_serial_time + + PUBLIC :: get_time_now + + PUBLIC :: ncio_write_colm_dimension + +CONTAINS + + ! ---- + SUBROUTINE nccheck (status, trace) + + USE MOD_MPAS_MPI + IMPLICIT NONE + + integer, intent(in) :: status + character(len=*), intent(in), optional :: trace + + IF (status /= NF90_NOERR) THEN + IF (present(trace)) THEN + write(*,'(A)') 'Netcdf error: ' //trim(nf90_strerror(status))// ' ' //trim(trace) + ELSE + write(*,'(A)') 'Netcdf error: ' //trim(nf90_strerror(status)) + ENDIF + + CALL CoLM_stop () + ENDIF + + END SUBROUTINE nccheck + + ! ---- + SUBROUTINE check_ncfile_exist (filename) + + USE MOD_MPAS_MPI + IMPLICIT NONE + + character(len=*), intent(in) :: filename + ! Local Variables + logical :: fexists + + inquire (file=trim(filename), exist=fexists) + IF (.not. fexists) THEN + write(*,*) trim(filename), ' does not exist.' + CALL CoLM_stop () + ENDIF + + END SUBROUTINE check_ncfile_exist + + ! ---- + character(len=27) FUNCTION get_time_now () + + IMPLICIT NONE + character(len=8) :: date + character(len=10) :: time + character(len=5) :: zone + + CALL date_and_time(date, time, zone) + get_time_now = date(1:8)//'-'//time(1:2)//':'//time(3:4)//':'//time(5:6) & + //' UTC'//zone(1:3)//':'//zone(4:5) + + END FUNCTION get_time_now + + ! ---- + SUBROUTINE ncio_create_file (filename) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + + ! Local Variables + integer :: ncid + + CALL nccheck( nf90_create(trim(filename), ior(NF90_CLOBBER,NF90_NETCDF4), ncid) ) + + CALL nccheck( nf90_put_att(ncid, NF90_GLOBAL, 'create_time', get_time_now())) + CALL nccheck (nf90_enddef (ncid)) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_create_file + + ! ---- + SUBROUTINE ncio_put_attr_str (filename, varname, attrname, attrval) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename, varname, attrname, attrval + + ! Local Variables + integer :: ncid, varid + + CALL nccheck( nf90_open (trim(filename), NF90_WRITE, ncid) ) + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trim(varname)) + CALL nccheck (nf90_redef (ncid)) + CALL nccheck (nf90_put_att (ncid, varid, trim(attrname), trim(attrval))) + CALL nccheck (nf90_enddef (ncid)) + CALL nccheck( nf90_close (ncid)) + + END SUBROUTINE ncio_put_attr_str + + ! ---- + SUBROUTINE ncio_get_attr_str (filename, varname, attrname, attrval) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename, varname, attrname + character(len=*), intent(out) :: attrval + + ! Local Variables + integer :: ncid, varid + + CALL nccheck( nf90_open (trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trim(varname)) + CALL nccheck (nf90_get_att (ncid, varid, trim(attrname), attrval)) + CALL nccheck( nf90_close (ncid)) + + END SUBROUTINE ncio_get_attr_str + + ! ---- + SUBROUTINE ncio_get_attr_real8 (filename, varname, attrname, attrval) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename, varname, attrname + real(r8), intent(out) :: attrval + + ! Local Variables + integer :: ncid, varid + + CALL nccheck( nf90_open (trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trim(varname)) + CALL nccheck (nf90_get_att (ncid, varid, trim(attrname), attrval)) + CALL nccheck (nf90_close (ncid)) + + END SUBROUTINE ncio_get_attr_real8 + + ! ---- + SUBROUTINE ncio_put_attr_real8 (filename, varname, attrname, attrval) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename, varname, attrname + real(r8), intent(in) :: attrval + + ! Local Variables + integer :: ncid, varid + + CALL nccheck( nf90_open (trim(filename), NF90_WRITE, ncid) ) + CALL nccheck (nf90_inq_varid (ncid, trim(varname), varid), trim(varname)) + CALL nccheck (nf90_redef (ncid)) + CALL nccheck (nf90_put_att (ncid, varid, trim(attrname), attrval)) + CALL nccheck (nf90_enddef (ncid)) + CALL nccheck( nf90_close (ncid)) + + END SUBROUTINE ncio_put_attr_real8 + + + !--------------------------------------------------------- + SUBROUTINE ncio_inquire_varsize (filename, dataname, varsize) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: varsize(:) + + ! Local variables + integer :: ncid, varid, ndims, idm + integer, allocatable :: dimids(:) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + CALL nccheck( nf90_inquire_variable(ncid, varid, ndims = ndims) ) + allocate (dimids(ndims)) + CALL nccheck( nf90_inquire_variable(ncid, varid, dimids = dimids) ) + + allocate (varsize(ndims)) + DO idm = 1, ndims + CALL nccheck( nf90_inquire_dimension(ncid, dimids(idm), len = varsize(idm)) ) + ENDDO + + CALL nccheck( nf90_close(ncid) ) + deallocate (dimids) + + END SUBROUTINE ncio_inquire_varsize + + !--------------------------------------------------------- + logical FUNCTION ncio_var_exist (filename, dataname, readflag) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + logical, optional,intent(in) :: readflag + + ! Local variables + integer :: ncid, varid, status + logical :: readflag_ + + status = nf90_open(trim(filename), NF90_NOWRITE, ncid) + IF (status == nf90_noerr) THEN + status = nf90_inq_varid(ncid, trim(dataname), varid) + ncio_var_exist = (status == nf90_noerr) + CALL nccheck( nf90_close(ncid) ) + ELSE + ncio_var_exist = .false. + ENDIF + + IF (present(readflag)) THEN + readflag_ = readflag + ELSE + readflag_ = .true. + ENDIF + + IF ((.not. ncio_var_exist) .and. trim(filename) /= 'null' .and. readflag_) THEN + write(*,*) 'Warning: ', trim(dataname), ' not found in ', trim(filename) + ENDIF + + END FUNCTION ncio_var_exist + + !--------------------------------------------------------- + SUBROUTINE ncio_inquire_length (filename, dataname, length) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(out) :: length + + ! Local variables + integer :: ncid, varid, ndims + integer, allocatable :: dimids(:) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + CALL nccheck( nf90_inquire_variable(ncid, varid, ndims = ndims) ) + allocate (dimids(ndims)) + CALL nccheck( nf90_inquire_variable(ncid, varid, dimids = dimids) ) + CALL nccheck( nf90_inquire_dimension(ncid, dimids(ndims), len = length) ) + + CALL nccheck( nf90_close(ncid) ) + deallocate (dimids) + + END SUBROUTINE ncio_inquire_length + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int32_0d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(out) :: rdata + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_serial_int32_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_0d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(out) :: rdata + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_serial_real8_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int8_1d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(1), allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int32_1d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int64_1d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer*8, allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int64_1d + + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_1d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int8_2d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(1), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int16_2d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(2), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int16_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int32_2d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + integer :: dsp, nread + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + IF ((varsize(1) > 1000) .and. (varsize(2) > 100000)) THEN + dsp = 0 + DO WHILE (dsp < varsize(2)) + nread = min(100000,varsize(2)-dsp) + CALL nccheck (nf90_get_var(ncid, varid, & + rdata(1:varsize(1),dsp+1:dsp+nread), (/1,dsp+1/), (/varsize(1),nread/))) + dsp = dsp + nread + ENDDO + ELSE + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + ENDIF + + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real4_2d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(4), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real4_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_2d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + integer :: dsp, nread + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + IF ((varsize(1) > 1000) .and. (varsize(2) > 100000)) THEN + dsp = 0 + DO WHILE (dsp < varsize(2)) + nread = min(100000,varsize(2)-dsp) + CALL nccheck (nf90_get_var(ncid, varid, & + rdata(1:varsize(1),dsp+1:dsp+nread), (/1,dsp+1/), (/varsize(1),nread/))) + dsp = dsp + nread + ENDDO + ELSE + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + ENDIF + + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_int32_3d (filename, dataname, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2), varsize(3)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_int32_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_3d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2), varsize(3)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_4d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2), varsize(3), varsize(4)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_4d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_serial_real8_5d (filename, dataname, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + allocate (rdata (varsize(1), varsize(2), varsize(3), varsize(4), varsize(5)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate (varsize) + + END SUBROUTINE ncio_read_serial_real8_5d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_int32_0d (filename, dataname, rdata) + + USE netcdf + USE MOD_MPAS_MPI + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(out) :: rdata + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_int32_0d (filename, dataname, rdata) + ENDIF + CALL mpi_bcast (rdata, 1, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF scalar integer broadcast') +#else + CALL ncio_read_serial_int32_0d (filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_int32_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_0d (filename, dataname, rdata) + + USE MOD_MPAS_MPI + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(out) :: rdata + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_real8_0d (filename, dataname, rdata) + ENDIF + CALL mpi_bcast (rdata, 1, MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF scalar real broadcast') +#else + CALL ncio_read_serial_real8_0d (filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_int32_1d (filename, dataname, rdata) + + USE MOD_MPAS_MPI + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:) + integer :: vlen + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_int32_1d(filename, dataname, rdata) + vlen = size(rdata) + ENDIF + CALL mpi_bcast (vlen, 1, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF integer vector length broadcast') + IF (.not. mpas_is_root) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF integer vector broadcast') +#else + CALL ncio_read_serial_int32_1d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_int32_2d (filename, dataname, rdata) + + USE MOD_MPAS_MPI + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, allocatable, intent(out) :: rdata (:,:) + integer :: vsize(2) + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_int32_2d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 2, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF integer array shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1), vsize(2))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF integer array broadcast') +#else + CALL ncio_read_serial_int32_2d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_1d (filename, dataname, rdata) + + USE netcdf + USE MOD_MPAS_MPI + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:) + integer :: vlen + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_real8_1d(filename, dataname, rdata) + vlen = size(rdata) + ENDIF + CALL mpi_bcast (vlen, 1, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF real vector length broadcast') + IF (.not. mpas_is_root) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF real vector broadcast') +#else + CALL ncio_read_serial_real8_1d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_2d (filename, dataname, rdata) + + USE netcdf + USE MOD_MPAS_MPI + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:) + integer :: vsize(2) + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_real8_2d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 2, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-2 real shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1),vsize(2))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-2 real broadcast') +#else + CALL ncio_read_serial_real8_2d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_3d (filename, dataname, rdata) + + USE netcdf + USE MOD_MPAS_MPI + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:) + integer :: vsize(3) + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_real8_3d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 3, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-3 real shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3), MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-3 real broadcast') +#else + CALL ncio_read_serial_real8_3d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_4d (filename, dataname, rdata) + + USE netcdf + USE MOD_MPAS_MPI + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:,:) + integer :: vsize(4) + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_real8_4d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 4, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-4 real shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4), MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-4 real broadcast') +#else + CALL ncio_read_serial_real8_4d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_4d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_bcast_serial_real8_5d (filename, dataname, rdata) + + USE netcdf + USE MOD_MPAS_MPI + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), allocatable, intent(out) :: rdata (:,:,:,:,:) + integer :: vsize(5) + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_real8_5d(filename, dataname, rdata) + vsize = shape(rdata) + ENDIF + CALL mpi_bcast (vsize, 5, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-5 real shape broadcast') + IF (.not. mpas_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3),vsize(4),vsize(5))) + CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3)*vsize(4)*vsize(5), MPI_REAL8, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF rank-5 real broadcast') +#else + CALL ncio_read_serial_real8_5d(filename, dataname, rdata) +#endif + + END SUBROUTINE ncio_read_bcast_serial_real8_5d + + ! ------------------------------- + SUBROUTINE ncio_read_bcast_serial_logical_1d (filename, dataname, rdata) + + USE MOD_MPAS_MPI + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + logical, allocatable, intent(out) :: rdata (:) + integer :: vlen + integer(1), allocatable :: rdata_byte(:) + +#ifdef MPAS_MPI + IF (mpas_is_root) THEN + CALL ncio_read_serial_int8_1d(filename, dataname, rdata_byte) + vlen = size(rdata_byte) + + allocate(rdata(vlen)) + rdata = (rdata_byte == 1) + + deallocate (rdata_byte) + ENDIF + CALL mpi_bcast (vlen, 1, MPI_INTEGER, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF logical vector length broadcast') + IF (.not. mpas_is_root) allocate (rdata (vlen)) + CALL mpi_bcast (rdata, vlen, MPI_LOGICAL, mpas_root, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('serial NetCDF logical vector broadcast') +#else + CALL ncio_read_serial_int8_1d(filename, dataname, rdata_byte) + vlen = size(rdata_byte) + + allocate(rdata(vlen)) + rdata = (rdata_byte == 1) + + deallocate (rdata_byte) +#endif + + END SUBROUTINE ncio_read_bcast_serial_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_part_serial_int32_1d (filename, dataname, datastt, dataend, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: datastt, dataend + integer, allocatable, intent(out) :: rdata (:) + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + allocate (rdata (datastt:dataend) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata, & + (/datastt/), (/dataend-datastt+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_part_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_part_serial_int32_2d (filename, dataname, datastt, dataend, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: datastt(2), dataend(2) + integer, allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + allocate (rdata (datastt(1):dataend(1), datastt(2):dataend(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata, & + (/datastt(1),datastt(2)/), (/dataend(1)-datastt(1)+1, dataend(2)-datastt(2)+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_part_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_part_serial_real8_2d (filename, dataname, datastt, dataend, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: datastt(2), dataend(2) + real(r8), allocatable, intent(out) :: rdata (:,:) + + ! Local variables + integer :: ncid, varid + + CALL check_ncfile_exist (filename) + + allocate (rdata (datastt(1):dataend(1), datastt(2):dataend(2)) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata, & + (/datastt(1),datastt(2)/), (/dataend(1)-datastt(1)+1, dataend(2)-datastt(2)+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_part_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_indexed_serial_int32_1d (filename, dataname, index, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: index(:) + integer, allocatable, intent(out) :: rdata(:) + + integer :: ncid, varid + integer :: nidx, istart, iend, nread + + nidx = size(index) + allocate (rdata(nidx)) + IF (nidx == 0) RETURN + IF (any(index < 1)) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + + CALL check_ncfile_exist (filename) + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + istart = 1 + DO WHILE (istart <= nidx) + iend = istart + DO WHILE (iend < nidx) + IF (index(iend+1) /= index(iend) + 1) EXIT + iend = iend + 1 + ENDDO + nread = iend - istart + 1 + CALL nccheck( nf90_get_var(ncid, varid, rdata(istart:iend), & + start=(/index(istart)/), count=(/nread/)) ) + istart = iend + 1 + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_indexed_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_indexed_serial_real8_1d (filename, dataname, index, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: index(:) + real(r8), allocatable, intent(out) :: rdata(:) + + integer :: ncid, varid + integer :: nidx, istart, iend, nread + + nidx = size(index) + allocate (rdata(nidx)) + IF (nidx == 0) RETURN + IF (any(index < 1)) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + + CALL check_ncfile_exist (filename) + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + istart = 1 + DO WHILE (istart <= nidx) + iend = istart + DO WHILE (iend < nidx) + IF (index(iend+1) /= index(iend) + 1) EXIT + iend = iend + 1 + ENDDO + nread = iend - istart + 1 + CALL nccheck( nf90_get_var(ncid, varid, rdata(istart:iend), & + start=(/index(istart)/), count=(/nread/)) ) + istart = iend + 1 + ENDDO + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_read_indexed_serial_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_indexed_serial_int32_2d (filename, dataname, index, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: index(:) + integer, allocatable, intent(out) :: rdata(:,:) + + integer :: ncid, varid + integer :: nidx, istart, iend, nread + integer, allocatable :: varsize(:) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + nidx = size(index) + IF (size(varsize) /= 2) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + allocate (rdata(varsize(1), nidx)) + IF (nidx == 0) THEN + deallocate (varsize) + RETURN + ENDIF + IF (any(index < 1)) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + + CALL check_ncfile_exist (filename) + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + istart = 1 + DO WHILE (istart <= nidx) + iend = istart + DO WHILE (iend < nidx) + IF (index(iend+1) /= index(iend) + 1) EXIT + iend = iend + 1 + ENDDO + nread = iend - istart + 1 + CALL nccheck( nf90_get_var(ncid, varid, rdata(:,istart:iend), & + start=(/1,index(istart)/), count=(/varsize(1),nread/)) ) + istart = iend + 1 + ENDDO + + CALL nccheck( nf90_close(ncid) ) + deallocate (varsize) + + END SUBROUTINE ncio_read_indexed_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_indexed_serial_real8_2d (filename, dataname, index, rdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: index(:) + real(r8), allocatable, intent(out) :: rdata(:,:) + + integer :: ncid, varid + integer :: nidx, istart, iend, nread + integer, allocatable :: varsize(:) + + CALL ncio_inquire_varsize(filename, dataname, varsize) + nidx = size(index) + IF (size(varsize) /= 2) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + allocate (rdata(varsize(1), nidx)) + IF (nidx == 0) THEN + deallocate (varsize) + RETURN + ENDIF + IF (any(index < 1)) CALL nccheck(NF90_EINVAL, trim(dataname)//' indexed read') + + CALL check_ncfile_exist (filename) + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + + istart = 1 + DO WHILE (istart <= nidx) + iend = istart + DO WHILE (iend < nidx) + IF (index(iend+1) /= index(iend) + 1) EXIT + iend = iend + 1 + ENDDO + nread = iend - istart + 1 + CALL nccheck( nf90_get_var(ncid, varid, rdata(:,istart:iend), & + start=(/1,index(istart)/), count=(/varsize(1),nread/)) ) + istart = iend + 1 + ENDDO + + CALL nccheck( nf90_close(ncid) ) + deallocate (varsize) + + END SUBROUTINE ncio_read_indexed_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_period_serial_real8_2d (filename, dataname, timestt, timeend, rdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: timestt, timeend + + real(r8), allocatable, intent(out) :: rdata (:,:,:) + + ! Local variables + integer :: ncid, varid + integer, allocatable :: varsize(:) + + CALL check_ncfile_exist (filename) + + CALL ncio_inquire_varsize (filename, dataname, varsize) + + allocate (rdata (varsize(1), varsize(2), timestt:timeend) ) + + CALL nccheck( nf90_open(trim(filename), NF90_NOWRITE, ncid) ) + CALL nccheck( nf90_inq_varid(ncid, trim(dataname), varid), trim(dataname) ) + CALL nccheck( nf90_get_var(ncid, varid, rdata, & + (/1,1,timestt/), (/varsize(1),varsize(2), timeend-timestt+1/)) ) + CALL nccheck( nf90_close(ncid) ) + + deallocate(varsize) + + END SUBROUTINE ncio_read_period_serial_real8_2d + + ! ------------------------------- + SUBROUTINE ncio_define_dimension_int32 (filename, dimname, dimlen) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dimname + integer, intent(in) :: dimlen + + ! Local variables + integer :: ncid, dimid, status + integer :: varid + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + + status = nf90_inq_dimid(ncid, trim(dimname), dimid) + IF (status /= NF90_NOERR) THEN + CALL nccheck (nf90_redef(ncid)) + IF (dimlen == 0) THEN + CALL nccheck( nf90_def_dim(ncid, trim(dimname), NF90_UNLIMITED, dimid) ) + ELSE + CALL nccheck( nf90_def_dim(ncid, trim(dimname), dimlen, dimid) ) + ENDIF + IF (trim(dimname) .eq. 'lon') THEN + !print *, 'lon-def' + CALL nccheck( nf90_def_var(ncid, 'lon', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','longitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_east') ) + ELSEIF (trim(dimname) .eq.'lat') THEN + !print *, 'lat-def' + CALL nccheck( nf90_def_var(ncid, 'lat', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) + ENDIF + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_define_dimension_int32 + + ! ------------------------------- + SUBROUTINE ncio_define_dimension_int64 (filename, dimname, dimlen) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dimname + integer*8, intent(in) :: dimlen + + ! Local variables + integer :: ncid, dimid, status + integer :: varid + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + + status = nf90_inq_dimid(ncid, trim(dimname), dimid) + IF (status /= NF90_NOERR) THEN + CALL nccheck (nf90_redef(ncid)) + IF (dimlen == 0) THEN + CALL nccheck( nf90_def_dim(ncid, trim(dimname), NF90_UNLIMITED, dimid) ) + ELSE + CALL nccheck( nf90_def_dim(ncid, trim(dimname), int(dimlen), dimid) ) + ENDIF + IF (trim(dimname) .eq. 'lon') THEN + !print *, 'lon-def' + CALL nccheck( nf90_def_var(ncid, 'lon', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','longitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_east') ) + ELSEIF (trim(dimname) .eq.'lat') THEN + !print *, 'lat-def' + CALL nccheck( nf90_def_var(ncid, 'lat', nf90_float, (/dimid/), varid) ) + CALL nccheck( nf90_put_att(ncid, varid, 'long_name','latitude') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units','degrees_north') ) + ENDIF + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_define_dimension_int64 + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int32_0d (filename, dataname, wdata) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: wdata + + ! Local variables + integer :: ncid, varid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + CALL nccheck (nf90_redef(ncid)) + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, varid = varid)) + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int32_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_0d (filename, dataname, wdata) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata + + ! Local variables + integer :: ncid, varid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + CALL nccheck (nf90_redef(ncid)) + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, varid = varid)) + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_0d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int8_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(1), intent(in) :: wdata (:) + + character(len=*), intent(in), optional :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dimname)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dimname), dimid)) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_BYTE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_BYTE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int32_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: wdata (:) + + character(len=*), intent(in), optional :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dimname)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dimname), dimid)) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int64_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer*8, intent(in) :: wdata (:) + + character(len=*), intent(in), optional :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dimname)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dimname), dimid)) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int64_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:) + + character(len=*), intent(in), optional :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dimname)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dimname), dimid)) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_logical_1d (filename, dataname, wdata, dimname, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + logical, intent(in) :: wdata (:) + + character(len=*), intent(in) :: dimname + integer, intent(in), optional :: compress + + ! Local variables + integer(1), allocatable :: wdata_byte(:) + + allocate(wdata_byte(size(wdata))) + WHERE(wdata) + wdata_byte = 1 + ELSEWHERE + wdata_byte = 0 + ENDWHERE + + IF (present(compress)) THEN + CALL ncio_write_serial_int8_1d (filename, dataname, wdata_byte, dimname, compress) + ELSE + CALL ncio_write_serial_int8_1d (filename, dataname, wdata_byte, dimname) + ENDIF + + deallocate(wdata_byte) + + END SUBROUTINE ncio_write_serial_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int8_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(1), intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_BYTE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_BYTE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int16_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer(2), intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_SHORT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_SHORT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int16_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int32_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int32_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int64_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer*8, intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT64, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int64_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real4_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(4), intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_FLOAT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_FLOAT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real4_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_2d (filename, dataname, wdata, & + dim1name, dim2name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_int32_3d (filename, dataname, wdata, & + dim1name, dim2name, dim3name, compress) + + USE netcdf + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: wdata (:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(3), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) .and. present(dim3name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_INT, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_int32_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_3d (filename, dataname, wdata, & + dim1name, dim2name, dim3name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(3), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) .and. present(dim3name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_4d (filename, dataname, wdata, & + dim1name, dim2name, dim3name, dim4name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:,:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name, dim4name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(4), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) & + .and. present(dim3name) .and. present(dim4name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim4name), dimid(4))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_4d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_5d (filename, dataname, wdata, & + dim1name, dim2name, dim3name, dim4name, dim5name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + real(r8), intent(in) :: wdata (:,:,:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + character(len=*), intent(in), optional :: dim4name, dim5name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(5), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) .and. present(dim3name) & + .and. present(dim4name) .and. present(dim5name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim4name), dimid(4))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim5name), dimid(5))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_5d + + !------------------------------ + SUBROUTINE ncio_write_time (filename, dataname, time_component, itime, adjust) + + USE MOD_TimeManager + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: time_component(3) + integer, intent(out) :: itime + + character(len=*), intent(in), optional :: adjust + + ! Local variables + integer, allocatable :: time_file(:) + integer :: ncid, varid, time_id, status + integer :: timelen, minutes + + minutes = minutes_since_1900 (time_component(1), time_component(2), time_component(3)) + + IF (present(adjust)) THEN + SELECTCASE (trim(adjustl(adjust))) + CASE ('HOURLY') + minutes = minutes - 30 + CASE ('DAILY') + minutes = minutes - 720 + CASE ('MONTHLY') + minutes = minutes - 21600 + CASE ('YEARLY') + minutes = minutes - 262800 + ENDSELECT + ENDIF + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status == NF90_NOERR) THEN + CALL nccheck( nf90_inq_dimid(ncid, 'time', time_id) ) + CALL nccheck( nf90_inquire_dimension(ncid, time_id, len = timelen) ) + + itime = 1 + IF (timelen > 0) THEN + allocate (time_file (timelen)) + CALL nccheck( nf90_get_var(ncid, varid, time_file) ) + + DO WHILE (itime <= timelen) + IF (minutes == time_file(itime)) EXIT + itime = itime + 1 + ENDDO + + deallocate(time_file) + ENDIF + + ELSE + status = nf90_inq_dimid(ncid, 'time', time_id) + IF (status /= NF90_NOERR) THEN + CALL nccheck( nf90_redef(ncid) ) + CALL nccheck( nf90_def_dim(ncid, 'time', NF90_UNLIMITED, time_id) ) + CALL nccheck( nf90_enddef(ncid) ) + ENDIF + + CALL nccheck( nf90_redef(ncid) ) + CALL nccheck( nf90_def_var(ncid, trim(dataname), NF90_INT, (/time_id/), varid) ) + + CALL nccheck( nf90_put_att(ncid, varid, 'long_name', 'time') ) + CALL nccheck( nf90_put_att(ncid, varid, 'units', 'minutes since 1900-1-1 0:0:0') ) + CALL nccheck( nf90_enddef(ncid) ) + + itime = 1 + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, minutes, (/itime/)) ) + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_time + + !------------------------------ + SUBROUTINE ncio_write_lastdim (filename, lastname, lastvalue, ilast) + + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: lastname + integer, intent(in) :: lastvalue + integer, intent(out) :: ilast + + ! Local variables + integer :: ncid, varid, dimid, dimlen, status + integer, allocatable :: lastvalue_f(:) + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + + status = nf90_inq_varid(ncid, trim(lastname), varid) + + IF (status == NF90_NOERR) THEN + CALL nccheck( nf90_inq_dimid(ncid, trim(lastname), dimid) ) + CALL nccheck( nf90_inquire_dimension(ncid, dimid, len = dimlen) ) + + ilast = 1 + IF (dimlen > 0) THEN + allocate (lastvalue_f (dimlen)) + CALL nccheck( nf90_get_var(ncid, varid, lastvalue_f) ) + + DO WHILE (ilast <= dimlen) + IF (lastvalue == lastvalue_f(ilast)) EXIT + ilast = ilast + 1 + ENDDO + + deallocate(lastvalue_f) + ENDIF + ELSE + status = nf90_inq_dimid(ncid, trim(lastname), dimid) + IF (status /= NF90_NOERR) THEN + CALL nccheck( nf90_redef(ncid) ) + CALL nccheck( nf90_def_dim(ncid, trim(lastname), NF90_UNLIMITED, dimid) ) + CALL nccheck( nf90_enddef(ncid) ) + ENDIF + + CALL nccheck( nf90_redef(ncid) ) + CALL nccheck( nf90_def_var(ncid, trim(lastname), NF90_INT, (/dimid/), varid) ) + CALL nccheck( nf90_enddef(ncid) ) + + ilast = 1 + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, lastvalue, (/ilast/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_lastdim + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_0d_time ( & + filename, dataname, itime, wdata, dim1name) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata + + character(len=*), intent(in), optional :: dim1name + + ! Local variables + integer :: ncid, varid, dimid, status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. present(dim1name)) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid)) + + CALL nccheck (nf90_redef(ncid)) + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, start = (/itime/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_0d_time + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_1d_time ( & + filename, dataname, itime, wdata, & + dim1name, dim2name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata(:) + + character(len=*), intent(in), optional :: dim1name, dim2name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(2), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, & + (/1,itime/), (/size(wdata,1),1/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_1d_time + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_2d_time ( & + filename, dataname, itime, wdata, & + dim1name, dim2name, dim3name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata(:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(3), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) .and. present(dim3name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, & + (/1,1,itime/), (/size(wdata,1),size(wdata,2),1/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_2d_time + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_3d_time ( & + filename, dataname, itime, wdata, & + dim1name, dim2name, dim3name, dim4name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata(:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name, dim4name + integer, intent(in), optional :: compress + ! Local variables + integer :: ncid, varid, dimid(4), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) & + .and. present(dim3name) .and. present(dim4name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim4name), dimid(4))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, & + (/1,1,1,itime/), (/size(wdata,1),size(wdata,2),size(wdata,3),1/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_3d_time + + !---------------------------------------------------------------------------- + SUBROUTINE ncio_write_serial_real8_4d_time ( & + filename, dataname, itime, wdata, & + dim1name, dim2name, dim3name, dim4name, dim5name, compress) + + USE netcdf + USE MOD_Precision + IMPLICIT NONE + + character (len=*), intent(in) :: filename + character (len=*), intent(in) :: dataname + integer, intent(in) :: itime + real(r8), intent(in) :: wdata(:,:,:,:) + + character(len=*), intent(in), optional :: dim1name, dim2name, dim3name + character(len=*), intent(in), optional :: dim4name, dim5name + integer, intent(in), optional :: compress + + ! Local variables + integer :: ncid, varid, dimid(5), status + + CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) ) + status = nf90_inq_varid(ncid, trim(dataname), varid) + IF (status /= NF90_NOERR) THEN + IF (.not. (present(dim1name) .and. present(dim2name) & + .and. present(dim3name) .and. present(dim4name) .and. present(dim5name))) THEN + write(*,*) 'Warning: no dimension name for ', trim(dataname) + CALL nccheck( nf90_close(ncid) ) + RETURN + ENDIF + + CALL nccheck (nf90_inq_dimid(ncid, trim(dim1name), dimid(1))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim2name), dimid(2))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim3name), dimid(3))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim4name), dimid(4))) + CALL nccheck (nf90_inq_dimid(ncid, trim(dim5name), dimid(5))) + + CALL nccheck (nf90_redef(ncid)) + IF (present(compress)) THEN + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid, & + deflate_level = compress)) + ELSE + CALL nccheck (nf90_def_var(ncid, trim(dataname), NF90_DOUBLE, dimid, varid)) + ENDIF + + CALL nccheck (nf90_enddef(ncid)) + ENDIF + + CALL nccheck( nf90_put_var(ncid, varid, wdata, & + (/1,1,1,1,itime/), (/size(wdata,1),size(wdata,2),size(wdata,3),size(wdata,4), 1/)) ) + + CALL nccheck( nf90_close(ncid) ) + + END SUBROUTINE ncio_write_serial_real8_4d_time + + !---------------------- + SUBROUTINE ncio_write_colm_dimension (filename) + + USE MOD_Vars_Global, only: nl_soil, maxsnl, nl_lake, nvegwcs + IMPLICIT NONE + + character(len=*), intent(in) :: filename + + ! Local Variables + integer :: soillayers(1:nl_soil) + integer :: soilinterfaces(0:nl_soil) + integer :: soilsnowlayers(-maxsnl+nl_soil) + integer :: lakelayers(1:nl_lake) + integer :: vegnodes(1:nvegwcs) + integer :: i + + + soillayers = (/(i, i = 1,nl_soil)/) + CALL ncio_define_dimension (filename, 'soil', nl_soil) + CALL ncio_write_serial (filename, 'soil', soillayers, 'soil') + CALL ncio_put_attr_str (filename, 'soil', 'long_name', 'soil layers') + + soilinterfaces = (/(i, i = 0,nl_soil)/) + CALL ncio_define_dimension (filename, 'soilinterface', nl_soil+1) + CALL ncio_write_serial (filename, 'soilinterface', soilinterfaces, 'soilinterface') + CALL ncio_put_attr_str (filename, 'soilinterface', 'long_name', 'soil layer interfaces') + + soilsnowlayers = (/(i, i = maxsnl+1,nl_soil)/) + CALL ncio_define_dimension (filename, 'soilsnow', -maxsnl+nl_soil) + CALL ncio_write_serial (filename, 'soilsnow', soilsnowlayers, 'soilsnow') + CALL ncio_put_attr_str (filename, 'soilsnow', 'long_name', 'snow(<= 0) and soil(>0) layers') + + lakelayers = (/(i, i = 1,nl_lake)/) + CALL ncio_define_dimension (filename, 'lake', nl_lake) + CALL ncio_write_serial (filename, 'lake', lakelayers, 'lake') + CALL ncio_put_attr_str (filename, 'lake', 'long_name', 'vertical lake layers') + + vegnodes = (/(i, i = 1,nvegwcs)/) + CALL ncio_define_dimension (filename, 'vegnodes', nvegwcs) + CALL ncio_write_serial (filename, 'vegnodes', vegnodes, 'vegnodes') + CALL ncio_put_attr_str (filename, 'vegnodes', 'long_name', 'vegetation water potential nodes') + + CALL ncio_define_dimension (filename, 'band', 2) + CALL ncio_write_serial (filename, 'band', (/1,2/), 'band') + CALL ncio_put_attr_str (filename, 'band', 'long_name', '1 = visible; 2 = near-infrared') + + CALL ncio_define_dimension (filename, 'rtyp', 2) + CALL ncio_write_serial (filename, 'rtyp', (/1,2/), 'rtyp') + CALL ncio_put_attr_str (filename, 'rtyp', 'long_name', '1 = direct; 2 = diffuse') + + END SUBROUTINE ncio_write_colm_dimension + +END MODULE MOD_NetCDFSerial diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 new file mode 100644 index 0000000000..3c8f419d0c --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90 @@ -0,0 +1,2556 @@ +#include + +!---------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! High-level Subroutines to read and write variables in files with netCDF format. +! +! CoLM read and write netCDF files mainly in three ways: +! 1. Serial: read and write data by a single process; +! 2. Vector: read/write data associated with CoLM pixelsets +! 3. Block : read blocked data by IO +! Notice: input file is a single file. +! +! This MODULE CONTAINS subroutines of "2. Vector". +! +! Two implementations can be used, +! 1) "MOD_NetCDFVectorBlk.F90": +! A vector is saved in separated files, each associated with a block. +! READ/WRITE are fast in this way and compression can be used. +! However, there may be too many files, especially when blocks are small. +! CHOOSE this implementation by "#undef VectorInOneFile" in include/define.h +! 2) "MOD_NetCDFVectorOne.F90": +! A vector is saved in one file. +! READ/WRITE may be slow in this way. +! CHOOSE this implementation by "#define VectorInOneFile" in include/define.h +! +! Created by Shupeng Zhang, May 2023 +!---------------------------------------------------------------------------------- + +MODULE MOD_NetCDFVector + + + USE MOD_DataType +#ifdef MPAS_EMBEDDED_COLM + USE mpi, only: MPI_Barrier + USE MOD_MPAS_MPI, only: CoLM_stop +#endif + IMPLICIT NONE + +#ifdef MPAS_EMBEDDED_COLM + type :: distributed_vector_map_type + character(len=512) :: filename = '' + integer :: iblk = 0 + integer :: jblk = 0 + integer :: istt = 0 + integer :: iend = -1 + integer*8, allocatable :: eindex(:) + integer, allocatable :: ipxstt(:) + integer, allocatable :: ipxend(:) + integer, allocatable :: settyp(:) + integer, allocatable :: source_rank(:) + integer, allocatable :: source_pos(:) + integer, allocatable :: source_ranks(:) + integer, allocatable :: source_lengths(:) + END type distributed_vector_map_type + + type(distributed_vector_map_type), allocatable, save :: distributed_vector_maps(:) + character(len=512), allocatable, save :: validated_distributed_markers(:) + integer, allocatable, save :: distributed_marker_ranks(:) +#endif + + ! PUBLIC subroutines + + INTERFACE ncio_read_vector + MODULE procedure ncio_read_vector_logical_1d + MODULE procedure ncio_read_vector_int32_1d + MODULE procedure ncio_read_vector_int64_1d + MODULE procedure ncio_read_vector_real8_1d + MODULE procedure ncio_read_vector_real8_2d + MODULE procedure ncio_read_vector_real8_3d + MODULE procedure ncio_read_vector_real8_4d + MODULE procedure ncio_read_vector_real8_5d + END INTERFACE ncio_read_vector + + PUBLIC :: ncio_create_file_vector + PUBLIC :: ncio_define_dimension_vector + PUBLIC :: ncio_begin_distributed_write + PUBLIC :: ncio_complete_distributed_write + PUBLIC :: ncio_reset_distributed_validation + + INTERFACE ncio_write_vector + MODULE procedure ncio_write_vector_logical_1d + MODULE procedure ncio_write_vector_int32_1d + MODULE procedure ncio_write_vector_int32_3d + MODULE procedure ncio_write_vector_int64_1d + MODULE procedure ncio_write_vector_real8_1d + MODULE procedure ncio_write_vector_real8_2d + MODULE procedure ncio_write_vector_real8_3d + MODULE procedure ncio_write_vector_real8_4d + MODULE procedure ncio_write_vector_real8_5d + END INTERFACE ncio_write_vector + +#ifdef MPAS_EMBEDDED_COLM + INTERFACE read_distributed_vector_block + MODULE procedure read_distributed_int32_1d + MODULE procedure read_distributed_int64_1d + MODULE procedure read_distributed_int8_1d + MODULE procedure read_distributed_real8_1d + MODULE procedure read_distributed_real8_2d + MODULE procedure read_distributed_real8_3d + MODULE procedure read_distributed_real8_4d + MODULE procedure read_distributed_real8_5d + END INTERFACE read_distributed_vector_block +#endif + +CONTAINS + + !--------------------------------------------------------- + SUBROUTINE get_filename_vector_block (filename, iblk, jblk, fileblock, for_write, use_srcpos, distributed_restart) + + USE MOD_Block, only: get_filename_block +#ifdef MPAS_EMBEDDED_COLM + USE MOD_MPAS_MPI, only: mpas_rank, CoLM_stop +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: filename + integer, intent(in) :: iblk, jblk + character(len=*), intent(out) :: fileblock + logical, intent(in), optional :: for_write + logical, intent(inout), optional :: use_srcpos + logical, intent(out), optional :: distributed_restart + +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: complete_marker + character(len=256) :: fileblock_rank + logical :: marker_exists, rank_file_exists, distributed_file +#endif + + CALL get_filename_block (filename, iblk, jblk, fileblock) + IF (present(distributed_restart)) distributed_restart = .false. + +#ifdef MPAS_EMBEDDED_COLM + CALL add_rank_suffix(fileblock, mpas_rank, fileblock_rank) + + distributed_file = .false. + IF (present(for_write)) distributed_file = for_write + IF ((.not. distributed_file) .and. present(use_srcpos)) THEN + complete_marker = trim(filename)//'.mpas_complete' + inquire(file=trim(complete_marker), exist=marker_exists) + IF (marker_exists) THEN + distributed_file = .true. + ELSE + inquire(file=trim(fileblock_rank), exist=rank_file_exists) + IF (rank_file_exists) THEN + CALL CoLM_stop('MPAS embedded CoLM found an incomplete distributed restart without its completion marker: '// & + trim(fileblock_rank)) + ENDIF + ENDIF + ENDIF + IF (present(for_write)) THEN + IF (distributed_file) fileblock = fileblock_rank + ELSEIF (distributed_file) THEN + ! A distributed restart can be repartitioned. The caller selects the + ! old rank shards through the stable pixelset identity map below. + fileblock = fileblock_rank + IF (present(use_srcpos)) use_srcpos = .false. + ENDIF + IF (present(distributed_restart)) distributed_restart = distributed_file +#endif + + END SUBROUTINE get_filename_vector_block + + !--------------------------------------------------------- + SUBROUTINE add_rank_suffix(fileblock, rank, fileblock_rank) + + IMPLICIT NONE + + character(len=*), intent(in) :: fileblock + integer, intent(in) :: rank + character(len=*), intent(out) :: fileblock_rank + + character(len=32) :: rank_suffix + integer :: idot + + write(rank_suffix,'("_mpasr",I8.8)') rank + idot = len_trim(fileblock) + DO WHILE (idot > 0) + IF (fileblock(idot:idot) == '.') EXIT + idot = idot - 1 + ENDDO + + IF (idot > 0) THEN + fileblock_rank = fileblock(1:idot-1) // trim(rank_suffix) // fileblock(idot:len_trim(fileblock)) + ELSE + fileblock_rank = trim(fileblock) // trim(rank_suffix) + ENDIF + + END SUBROUTINE add_rank_suffix + + !--------------------------------------------------------- + SUBROUTINE read_distributed_marker(complete_marker, marker_ranks) + +#ifdef MPAS_EMBEDDED_COLM + USE MOD_MPAS_MPI, only: CoLM_stop +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: complete_marker + integer, intent(out) :: marker_ranks + +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: line + character(len=512), allocatable :: markers_new(:) + integer, allocatable :: marker_ranks_new(:) + integer :: i, iunit, ios, nvalidated, separator + + IF (allocated(validated_distributed_markers)) THEN + DO i = 1, size(validated_distributed_markers) + IF (trim(validated_distributed_markers(i)) == trim(complete_marker)) THEN + marker_ranks = distributed_marker_ranks(i) + RETURN + ENDIF + ENDDO + ENDIF + + open(newunit=iunit, file=trim(complete_marker), status='old', action='read', iostat=ios) + IF (ios /= 0) CALL CoLM_stop('Cannot read MPAS embedded CoLM restart marker: '//trim(complete_marker)) + read(iunit,'(A)',iostat=ios) line + close(iunit) + separator = index(line, ':') + IF (ios /= 0 .or. separator < 1 .or. separator >= len_trim(line)) THEN + CALL CoLM_stop('Invalid MPAS embedded CoLM restart marker: '//trim(complete_marker)) + ENDIF + read(line(separator+1:),*,iostat=ios) marker_ranks + IF (ios /= 0 .or. marker_ranks < 1) THEN + CALL CoLM_stop('Invalid MPI rank count in MPAS embedded CoLM restart marker: '//trim(complete_marker)) + ENDIF + IF (allocated(validated_distributed_markers)) THEN + nvalidated = size(validated_distributed_markers) + allocate(markers_new(nvalidated + 1)) + allocate(marker_ranks_new(nvalidated + 1)) + markers_new(1:nvalidated) = validated_distributed_markers + marker_ranks_new(1:nvalidated) = distributed_marker_ranks + markers_new(nvalidated + 1) = complete_marker + marker_ranks_new(nvalidated + 1) = marker_ranks + CALL move_alloc(markers_new, validated_distributed_markers) + CALL move_alloc(marker_ranks_new, distributed_marker_ranks) + ELSE + allocate(validated_distributed_markers(1)) + allocate(distributed_marker_ranks(1)) + validated_distributed_markers(1) = complete_marker + distributed_marker_ranks(1) = marker_ranks + ENDIF +#endif + + END SUBROUTINE read_distributed_marker + + !--------------------------------------------------------- + SUBROUTINE remove_rank_distributed_shards(filename) + +#ifdef MPAS_EMBEDDED_COLM + USE MOD_Block, only: gblock, get_filename_block + USE MOD_MPAS_MPI, only: mpas_rank, CoLM_stop +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: filename + +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: fileblock, fileblock_rank + integer :: iblk, jblk, iunit, iostat_open, iostat_close + logical :: shard_exists + + IF (gblock%nxblk < 1 .or. gblock%nyblk < 1) THEN + CALL CoLM_stop('Cannot clean distributed CoLM restart shards before block metadata is initialized.') + ENDIF + + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + CALL get_filename_block(filename, iblk, jblk, fileblock) + CALL add_rank_suffix(fileblock, mpas_rank, fileblock_rank) + inquire(file=trim(fileblock_rank), exist=shard_exists) + IF (.not. shard_exists) CYCLE + + open(newunit=iunit, file=trim(fileblock_rank), status='old', action='readwrite', iostat=iostat_open) + IF (iostat_open /= 0) THEN + CALL CoLM_stop('Cannot open stale MPAS embedded CoLM restart shard for removal: '// & + trim(fileblock_rank)) + ENDIF + close(iunit, status='delete', iostat=iostat_close) + IF (iostat_close /= 0) THEN + CALL CoLM_stop('Cannot remove stale MPAS embedded CoLM restart shard: '//trim(fileblock_rank)) + ENDIF + ENDDO + ENDDO +#endif + + END SUBROUTINE remove_rank_distributed_shards + + !--------------------------------------------------------- + SUBROUTINE ncio_begin_distributed_write(filename) + +#ifdef MPAS_EMBEDDED_COLM + USE MOD_MPAS_MPI, only: mpas_is_root, mpas_comm, mpas_mpi_ierr, CoLM_stop, mpas_mpi_check +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: filename + +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: complete_marker + integer :: iunit, iostat_open, iostat_close + logical :: marker_exists + + complete_marker = trim(filename)//'.mpas_complete' + IF (mpas_is_root) THEN + inquire(file=trim(complete_marker), exist=marker_exists) + IF (marker_exists) THEN + open(newunit=iunit, file=trim(complete_marker), status='old', action='readwrite', iostat=iostat_open) + IF (iostat_open /= 0) CALL CoLM_stop('Cannot replace MPAS embedded CoLM restart marker: '// & + trim(complete_marker)) + close(iunit, status='delete', iostat=iostat_close) + IF (iostat_close /= 0) CALL CoLM_stop('Cannot remove stale MPAS embedded CoLM restart marker: '// & + trim(complete_marker)) + ENDIF + ENDIF + CALL mpi_barrier(mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('distributed restart marker removal') + CALL remove_rank_distributed_shards(filename) + CALL mpi_barrier(mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('distributed restart shard cleanup') +#endif + + END SUBROUTINE ncio_begin_distributed_write + + !--------------------------------------------------------- + SUBROUTINE ncio_complete_distributed_write(filename) + +#ifdef MPAS_EMBEDDED_COLM + USE MOD_MPAS_MPI, only: mpas_is_root, mpas_comm, mpas_mpi_ierr, mpas_size, CoLM_stop, mpas_mpi_check +#endif + IMPLICIT NONE + + character(len=*), intent(in) :: filename + +#ifdef MPAS_EMBEDDED_COLM + character(len=512) :: complete_marker + integer :: iunit, iostat_open, iostat_close + + CALL mpi_barrier(mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('distributed restart shard completion') + complete_marker = trim(filename)//'.mpas_complete' + IF (mpas_is_root) THEN + open(newunit=iunit, file=trim(complete_marker), status='replace', action='write', iostat=iostat_open) + IF (iostat_open /= 0) CALL CoLM_stop('Cannot create MPAS embedded CoLM restart marker: '// & + trim(complete_marker)) + write(iunit,'(A,I0)') 'MPAS ranks: ', mpas_size + write(iunit,'(A)') 'Format: distributed-pixelset-v1' + close(iunit, iostat=iostat_close) + IF (iostat_close /= 0) CALL CoLM_stop('Cannot close MPAS embedded CoLM restart marker: '// & + trim(complete_marker)) + ENDIF + CALL mpi_barrier(mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('distributed restart marker publication') +#endif + + END SUBROUTINE ncio_complete_distributed_write + + !--------------------------------------------------------- + SUBROUTINE ncio_reset_distributed_validation() + + IF (allocated(distributed_vector_maps)) deallocate(distributed_vector_maps) + IF (allocated(validated_distributed_markers)) deallocate(validated_distributed_markers) + IF (allocated(distributed_marker_ranks)) deallocate(distributed_marker_ranks) + + END SUBROUTINE ncio_reset_distributed_validation + + !--------------------------------------------------------- + SUBROUTINE prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + + USE MOD_NetCDFSerial + USE MOD_Block, only: get_filename_block + USE MOD_Pixelset + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + character(len=*), intent(in) :: filename + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + integer, intent(out) :: map_index + +#ifdef MPAS_EMBEDDED_COLM + type(distributed_vector_map_type), allocatable :: maps_new(:) + character(len=256) :: fileblock, source_file + character(len=512) :: complete_marker + integer :: istt, iend, nlocal, marker_ranks, irank, isource, ilocal + integer :: imap, nmaps, nused, iused + integer*8, allocatable :: file_eindex(:) + integer, allocatable :: file_ipxstt(:), file_ipxend(:), file_settyp(:) + integer, allocatable :: rank_lengths(:) + logical, allocatable :: used_rank(:) + logical :: source_exists + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + nlocal = iend - istt + 1 + IF (nlocal < 1 .or. istt < 1 .or. iend > pixelset%nset) THEN + CALL CoLM_stop('Invalid local pixelset block while preparing distributed restart mapping.') + ENDIF + IF (.not. allocated(pixelset%eindex) .or. .not. allocated(pixelset%ipxstt) .or. & + .not. allocated(pixelset%ipxend) .or. .not. allocated(pixelset%settyp)) THEN + CALL CoLM_stop('Current MPAS embedded CoLM pixelset lacks restart identity metadata.') + ENDIF + IF (size(pixelset%eindex) /= pixelset%nset .or. size(pixelset%ipxstt) /= pixelset%nset .or. & + size(pixelset%ipxend) /= pixelset%nset .or. size(pixelset%settyp) /= pixelset%nset) THEN + CALL CoLM_stop('Current MPAS embedded CoLM pixelset restart identity lengths are inconsistent.') + ENDIF + CALL validate_identity_vector(pixelset%eindex(istt:iend), pixelset%ipxstt(istt:iend), & + pixelset%ipxend(istt:iend), pixelset%settyp(istt:iend), & + 'current MPAS decomposition') + + IF (allocated(distributed_vector_maps)) THEN + DO imap = 1, size(distributed_vector_maps) + IF (trim(distributed_vector_maps(imap)%filename) /= trim(filename) .or. & + distributed_vector_maps(imap)%iblk /= iblk .or. & + distributed_vector_maps(imap)%jblk /= jblk .or. & + distributed_vector_maps(imap)%istt /= istt .or. & + distributed_vector_maps(imap)%iend /= iend) CYCLE + IF (all(distributed_vector_maps(imap)%eindex == pixelset%eindex(istt:iend)) .and. & + all(distributed_vector_maps(imap)%ipxstt == pixelset%ipxstt(istt:iend)) .and. & + all(distributed_vector_maps(imap)%ipxend == pixelset%ipxend(istt:iend)) .and. & + all(distributed_vector_maps(imap)%settyp == pixelset%settyp(istt:iend))) THEN + map_index = imap + RETURN + ENDIF + ENDDO + ENDIF + + complete_marker = trim(filename)//'.mpas_complete' + CALL read_distributed_marker(complete_marker, marker_ranks) + CALL get_filename_block(filename, iblk, jblk, fileblock) + allocate(rank_lengths(marker_ranks), used_rank(marker_ranks)) + rank_lengths = 0 + used_rank = .false. + + IF (allocated(distributed_vector_maps)) THEN + nmaps = size(distributed_vector_maps) + ELSE + nmaps = 0 + ENDIF + allocate(maps_new(nmaps + 1)) + IF (nmaps > 0) maps_new(1:nmaps) = distributed_vector_maps + map_index = nmaps + 1 + maps_new(map_index)%filename = filename + maps_new(map_index)%iblk = iblk + maps_new(map_index)%jblk = jblk + maps_new(map_index)%istt = istt + maps_new(map_index)%iend = iend + maps_new(map_index)%eindex = pixelset%eindex(istt:iend) + maps_new(map_index)%ipxstt = pixelset%ipxstt(istt:iend) + maps_new(map_index)%ipxend = pixelset%ipxend(istt:iend) + maps_new(map_index)%settyp = pixelset%settyp(istt:iend) + allocate(maps_new(map_index)%source_rank(nlocal)) + allocate(maps_new(map_index)%source_pos(nlocal)) + maps_new(map_index)%source_rank = -1 + maps_new(map_index)%source_pos = -1 + + DO irank = 0, marker_ranks - 1 + CALL add_rank_suffix(fileblock, irank, source_file) + inquire(file=trim(source_file), exist=source_exists) + IF (.not. source_exists) CYCLE + IF (.not. ncio_var_exist(source_file, 'mpas_eindex', readflag=.false.) .or. & + .not. ncio_var_exist(source_file, 'mpas_ipxstt', readflag=.false.) .or. & + .not. ncio_var_exist(source_file, 'mpas_ipxend', readflag=.false.) .or. & + .not. ncio_var_exist(source_file, 'mpas_settyp', readflag=.false.)) THEN + CALL CoLM_stop('Distributed MPAS-CoLM restart shard lacks pixelset identity metadata: '// & + trim(source_file)) + ENDIF + CALL ncio_read_serial(source_file, 'mpas_eindex', file_eindex) + CALL ncio_read_serial(source_file, 'mpas_ipxstt', file_ipxstt) + CALL ncio_read_serial(source_file, 'mpas_ipxend', file_ipxend) + CALL ncio_read_serial(source_file, 'mpas_settyp', file_settyp) + IF (size(file_eindex) < 1 .or. size(file_ipxstt) /= size(file_eindex) .or. & + size(file_ipxend) /= size(file_eindex) .or. size(file_settyp) /= size(file_eindex)) THEN + CALL CoLM_stop('Distributed MPAS-CoLM restart shard has inconsistent identity metadata: '// & + trim(source_file)) + ENDIF + CALL validate_identity_vector(file_eindex, file_ipxstt, file_ipxend, file_settyp, source_file) + rank_lengths(irank + 1) = size(file_eindex) + + DO isource = 1, size(file_eindex) + ilocal = find_identity(pixelset%eindex(istt:iend), pixelset%ipxstt(istt:iend), & + pixelset%ipxend(istt:iend), pixelset%settyp(istt:iend), & + file_eindex(isource), file_ipxstt(isource), & + file_ipxend(isource), file_settyp(isource)) + IF (ilocal > 0) THEN + IF (maps_new(map_index)%source_rank(ilocal) >= 0) THEN + CALL CoLM_stop('Duplicate pixelset identity across distributed MPAS-CoLM restart shards.') + ENDIF + maps_new(map_index)%source_rank(ilocal) = irank + maps_new(map_index)%source_pos(ilocal) = isource + used_rank(irank + 1) = .true. + ENDIF + ENDDO + + deallocate(file_eindex, file_ipxstt, file_ipxend, file_settyp) + ENDDO + + IF (any(maps_new(map_index)%source_rank < 0)) THEN + ilocal = minloc(maps_new(map_index)%source_rank, dim=1) + write(*,'(A,I0,A,I0,A,I0,A,I0)') 'Missing distributed restart identity: element=', & + maps_new(map_index)%eindex(ilocal), ', ipxstt=', maps_new(map_index)%ipxstt(ilocal), & + ', ipxend=', maps_new(map_index)%ipxend(ilocal), ', settyp=', maps_new(map_index)%settyp(ilocal) + CALL CoLM_stop('Distributed MPAS-CoLM restart does not cover the current pixelset decomposition.') + ENDIF + + nused = count(used_rank) + allocate(maps_new(map_index)%source_ranks(nused)) + allocate(maps_new(map_index)%source_lengths(nused)) + iused = 0 + DO irank = 0, marker_ranks - 1 + IF (.not. used_rank(irank + 1)) CYCLE + iused = iused + 1 + maps_new(map_index)%source_ranks(iused) = irank + maps_new(map_index)%source_lengths(iused) = rank_lengths(irank + 1) + ENDDO + + deallocate(rank_lengths, used_rank) + CALL move_alloc(maps_new, distributed_vector_maps) +#else + map_index = 0 +#endif + + END SUBROUTINE prepare_distributed_vector_map + + !--------------------------------------------------------- + SUBROUTINE validate_identity_vector(eindex, ipxstt, ipxend, settyp, source_name) + + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer*8, intent(in) :: eindex(:) + integer, intent(in) :: ipxstt(:), ipxend(:), settyp(:) + character(len=*), intent(in) :: source_name + integer :: istart, iend, i, j + + IF (size(ipxstt) /= size(eindex) .or. size(ipxend) /= size(eindex) .or. & + size(settyp) /= size(eindex)) THEN + CALL CoLM_stop('Inconsistent pixelset identity vector lengths in '//trim(source_name)//'.') + ENDIF + IF (size(eindex) > 1) THEN + IF (any(eindex(2:) < eindex(:size(eindex)-1))) THEN + CALL CoLM_stop('Pixelset identities are not ordered by element in '//trim(source_name)//'.') + ENDIF + ENDIF + + istart = 1 + DO WHILE (istart <= size(eindex)) + iend = istart + DO WHILE (iend < size(eindex)) + IF (eindex(iend + 1) /= eindex(istart)) EXIT + iend = iend + 1 + ENDDO + DO i = istart, iend - 1 + DO j = i + 1, iend + IF (ipxstt(i) == ipxstt(j) .and. ipxend(i) == ipxend(j) .and. & + settyp(i) == settyp(j)) THEN + CALL CoLM_stop('Duplicate pixelset identity in '//trim(source_name)//'.') + ENDIF + ENDDO + ENDDO + istart = iend + 1 + ENDDO + + END SUBROUTINE validate_identity_vector + + !--------------------------------------------------------- + INTEGER FUNCTION find_identity(eindex, ipxstt, ipxend, settyp, target_eindex, & + target_ipxstt, target_ipxend, target_settyp) + + IMPLICIT NONE + + integer*8, intent(in) :: eindex(:), target_eindex + integer, intent(in) :: ipxstt(:), ipxend(:), settyp(:) + integer, intent(in) :: target_ipxstt, target_ipxend, target_settyp + integer :: lo, hi, mid, ifirst, ilast, i + + find_identity = 0 + lo = 1 + hi = size(eindex) + DO WHILE (lo <= hi) + mid = lo + (hi - lo) / 2 + IF (eindex(mid) < target_eindex) THEN + lo = mid + 1 + ELSEIF (eindex(mid) > target_eindex) THEN + hi = mid - 1 + ELSE + ifirst = mid + ilast = mid + DO WHILE (ifirst > 1) + IF (eindex(ifirst - 1) /= target_eindex) EXIT + ifirst = ifirst - 1 + ENDDO + DO WHILE (ilast < size(eindex)) + IF (eindex(ilast + 1) /= target_eindex) EXIT + ilast = ilast + 1 + ENDDO + DO i = ifirst, ilast + IF (ipxstt(i) == target_ipxstt .and. ipxend(i) == target_ipxend .and. & + settyp(i) == target_settyp) THEN + find_identity = i + RETURN + ENDIF + ENDDO + RETURN + ENDIF + ENDDO + + END FUNCTION find_identity + + !--------------------------------------------------------- + SUBROUTINE get_distributed_source(map_index, source_index, source_file, source_rank, source_length) + + USE MOD_Block, only: get_filename_block + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer, intent(in) :: map_index, source_index + character(len=*), intent(out) :: source_file + integer, intent(out) :: source_rank, source_length + +#ifdef MPAS_EMBEDDED_COLM + character(len=256) :: fileblock + + IF (.not. allocated(distributed_vector_maps) .or. map_index < 1 .or. & + map_index > size(distributed_vector_maps)) THEN + CALL CoLM_stop('Invalid distributed MPAS-CoLM restart map index.') + ENDIF + IF (source_index < 1 .or. source_index > size(distributed_vector_maps(map_index)%source_ranks)) THEN + CALL CoLM_stop('Invalid distributed MPAS-CoLM restart source index.') + ENDIF + source_rank = distributed_vector_maps(map_index)%source_ranks(source_index) + source_length = distributed_vector_maps(map_index)%source_lengths(source_index) + CALL get_filename_block(distributed_vector_maps(map_index)%filename, & + distributed_vector_maps(map_index)%iblk, & + distributed_vector_maps(map_index)%jblk, fileblock) + CALL add_rank_suffix(fileblock, source_rank, source_file) +#else + source_file = '' + source_rank = -1 + source_length = 0 +#endif + + END SUBROUTINE get_distributed_source + +#ifdef MPAS_EMBEDDED_COLM + !--------------------------------------------------------- + SUBROUTINE read_distributed_int32_1d(filename, dataname, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + integer, allocatable, intent(out) :: rdata(:) + logical, intent(out) :: found + integer, intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + integer, allocatable :: source_data(:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + IF (size(source_data) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(ilocal) = source_data(distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_int32_1d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_int64_1d(filename, dataname, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + integer*8, allocatable, intent(out) :: rdata(:) + logical, intent(out) :: found + integer*8, intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + integer*8, allocatable :: source_data(:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + IF (size(source_data) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(ilocal) = source_data(distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_int64_1d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_int8_1d(filename, dataname, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + integer(1), allocatable, intent(out) :: rdata(:) + logical, intent(out) :: found + logical, intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + integer(1), allocatable :: source_data(:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) THEN + IF (defval) THEN + rdata = 1 + ELSE + rdata = 0 + ENDIF + ENDIF + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + IF (size(source_data) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + IF (any((source_data /= int(0,kind=kind(source_data))) .and. & + (source_data /= int(1,kind=kind(source_data))))) THEN + CALL CoLM_stop('Invalid logical vector value in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(ilocal) = source_data(distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_int8_1d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_1d(filename, dataname, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: iblk, jblk + real(r8), allocatable, intent(out) :: rdata(:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + IF (size(source_data) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(ilocal) = source_data(distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_1d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_2d(filename, dataname, ndim1, pixelset, iblk, jblk, rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndim1, iblk, jblk + type(pixelset_type), intent(in) :: pixelset + real(r8), allocatable, intent(out) :: rdata(:,:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:,:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(ndim1,size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + CALL validate_vector_fixed_dimensions((/size(source_data,1)/), (/ndim1/), source_file, dataname) + IF (size(source_data,2) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata,2) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(:,ilocal) = source_data(:,distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_2d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_3d(filename, dataname, ndim1, ndim2, pixelset, iblk, jblk, & + rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndim1, ndim2, iblk, jblk + type(pixelset_type), intent(in) :: pixelset + real(r8), allocatable, intent(out) :: rdata(:,:,:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:,:,:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(ndim1,ndim2,size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + CALL validate_vector_fixed_dimensions((/size(source_data,1),size(source_data,2)/), & + (/ndim1,ndim2/), source_file, dataname) + IF (size(source_data,3) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata,3) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(:,:,ilocal) = source_data(:,:,distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_3d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_4d(filename, dataname, ndim1, ndim2, ndim3, pixelset, iblk, jblk, & + rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndim1, ndim2, ndim3, iblk, jblk + type(pixelset_type), intent(in) :: pixelset + real(r8), allocatable, intent(out) :: rdata(:,:,:,:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:,:,:,:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(ndim1,ndim2,ndim3,size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + CALL validate_vector_fixed_dimensions((/size(source_data,1),size(source_data,2), & + size(source_data,3)/), & + (/ndim1,ndim2,ndim3/), source_file, dataname) + IF (size(source_data,4) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata,4) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(:,:,:,ilocal) = source_data(:,:,:,distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_4d + + !--------------------------------------------------------- + SUBROUTINE read_distributed_real8_5d(filename, dataname, ndim1, ndim2, ndim3, ndim4, pixelset, iblk, jblk, & + rdata, found, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_Pixelset, only: pixelset_type + IMPLICIT NONE + + character(len=*), intent(in) :: filename, dataname + integer, intent(in) :: ndim1, ndim2, ndim3, ndim4, iblk, jblk + type(pixelset_type), intent(in) :: pixelset + real(r8), allocatable, intent(out) :: rdata(:,:,:,:,:) + logical, intent(out) :: found + real(r8), intent(in), optional :: defval + + integer :: map_index, isource, source_rank, source_length, ilocal + character(len=256) :: source_file + real(r8), allocatable :: source_data(:,:,:,:,:) + + CALL prepare_distributed_vector_map(filename, pixelset, iblk, jblk, map_index) + allocate(rdata(ndim1,ndim2,ndim3,ndim4,size(distributed_vector_maps(map_index)%source_rank))) + IF (present(defval)) rdata = defval + found = .false. + DO isource = 1, size(distributed_vector_maps(map_index)%source_ranks) + CALL get_distributed_source(map_index, isource, source_file, source_rank, source_length) + IF (ncio_var_exist(source_file, dataname, readflag=.false.)) THEN + CALL ncio_read_serial(source_file, dataname, source_data) + CALL validate_vector_fixed_dimensions((/size(source_data,1),size(source_data,2), & + size(source_data,3),size(source_data,4)/), & + (/ndim1,ndim2,ndim3,ndim4/), source_file, dataname) + IF (size(source_data,5) /= source_length) THEN + CALL CoLM_stop('Distributed vector length mismatch for '//trim(dataname)//' in '//trim(source_file)//'.') + ENDIF + found = .true. + DO ilocal = 1, size(rdata,5) + IF (distributed_vector_maps(map_index)%source_rank(ilocal) == source_rank) THEN + rdata(:,:,:,:,ilocal) = source_data(:,:,:,:,distributed_vector_maps(map_index)%source_pos(ilocal)) + ENDIF + ENDDO + deallocate(source_data) + ELSEIF (.not. present(defval)) THEN + CALL ncio_vector_stop_missing_block(filename, dataname, source_file) + ENDIF + ENDDO + + END SUBROUTINE read_distributed_real8_5d +#endif + + !--------------------------------------------------------- + SUBROUTINE ncio_vector_stop_missing_block (filename, dataname, fileblock) + + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: fileblock + + write(*,*) 'Error : required vector data '//trim(dataname) & + //' in '//trim(filename)//' is missing from block file '//trim(fileblock)//'.' + CALL CoLM_stop () + + END SUBROUTINE ncio_vector_stop_missing_block + + !--------------------------------------------------------- + SUBROUTINE validate_vector_block_data(pixelset, istt, iend, source_length, & + use_srcpos, fileblock, dataname) + + USE MOD_Pixelset, only: pixelset_type + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: istt, iend, source_length + logical, intent(in) :: use_srcpos + character(len=*), intent(in) :: fileblock, dataname + + integer :: expected_length + + IF (istt < 1 .or. iend < istt .or. iend > pixelset%nset) THEN + CALL CoLM_stop('Invalid local vector bounds while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + + expected_length = iend - istt + 1 + IF (use_srcpos) THEN + IF (.not. allocated(pixelset%srcpos)) THEN + CALL CoLM_stop('Missing source-position map while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + IF (size(pixelset%srcpos) /= pixelset%nset) THEN + CALL CoLM_stop('Invalid source-position map length while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + IF (source_length < 1 .or. minval(pixelset%srcpos(istt:iend)) < 1 .or. & + maxval(pixelset%srcpos(istt:iend)) > source_length) THEN + CALL CoLM_stop('Source-position map exceeds vector data while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + ELSEIF (source_length /= expected_length) THEN + CALL CoLM_stop('Rank-local vector length mismatch while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + + END SUBROUTINE validate_vector_block_data + + !--------------------------------------------------------- + SUBROUTINE validate_vector_fixed_dimensions(actual, expected, fileblock, dataname) + + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer, intent(in) :: actual(:), expected(:) + character(len=*), intent(in) :: fileblock, dataname + + IF (size(actual) /= size(expected)) THEN + CALL CoLM_stop('Non-vector rank mismatch while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + IF (any(actual /= expected)) THEN + CALL CoLM_stop('Non-vector dimension mismatch while reading '//trim(dataname)// & + ' from '//trim(fileblock)//'.') + ENDIF + + END SUBROUTINE validate_vector_fixed_dimensions + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_int32_1d ( & + filename, dataname, pixelset, rdata, defval) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + type(pixelset_type), intent(in) :: pixelset + + integer, allocatable, intent(inout) :: rdata (:) + integer, intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + integer, allocatable :: sbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart + + IF (.true.) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (.true.) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (block_has_data .and. .not. distributed_restart) & + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff), & + use_srcpos, fileblock, dataname) + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN + DO iset = istt, iend + rdata(iset) = sbuff(pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(istt:iend) = sbuff + ENDIF + + deallocate (sbuff) + + ENDDO + + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE ncio_read_vector_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_int64_1d ( & + filename, dataname, pixelset, rdata, defval) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + type(pixelset_type), intent(in) :: pixelset + + integer*8, allocatable, intent(inout) :: rdata (:) + integer*8, intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + integer*8, allocatable :: sbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart + + IF (.true.) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (.true.) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (block_has_data .and. .not. distributed_restart) & + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff), & + use_srcpos, fileblock, dataname) + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN + DO iset = istt, iend + rdata(iset) = sbuff(pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(istt:iend) = sbuff + ENDIF + + deallocate (sbuff) + + ENDDO + + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE ncio_read_vector_int64_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_logical_1d (filename, dataname, pixelset, rdata, & + defval) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + type(pixelset_type), intent(in) :: pixelset + + logical, allocatable, intent(inout) :: rdata (:) + logical, intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + integer(1), allocatable :: sbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart + + IF (.true.) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (.true.) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + IF (defval) THEN + sbuff(:) = 1 + ELSE + sbuff(:) = 0 + ENDIF + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (block_has_data .and. .not. distributed_restart) & + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff), & + use_srcpos, fileblock, dataname) + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN + DO iset = istt, iend + rdata(iset) = (sbuff(pixelset%srcpos(iset)) == int(1, kind=kind(sbuff))) + ENDDO + ELSE + rdata(istt:iend) = (sbuff == int(1, kind=kind(sbuff))) + ENDIF + + deallocate (sbuff) + + ENDDO + + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE ncio_read_vector_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_1d (filename, dataname, pixelset, rdata, & + defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart + + IF (.true.) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (.true.) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (block_has_data .and. .not. distributed_restart) & + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff), & + use_srcpos, fileblock, dataname) + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN + DO iset = istt, iend + rdata(iset) = sbuff(pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(istt:iend) = sbuff + ENDIF + + deallocate (sbuff) + + ENDDO + + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE ncio_read_vector_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_2d ( & + filename, dataname, ndim1, pixelset, rdata, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: ndim1 + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:,:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart + + IF (.true.) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1, pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (.true.) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, ndim1, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (block_has_data .and. .not. distributed_restart) THEN + CALL validate_vector_fixed_dimensions((/size(sbuff,1)/), (/ndim1/), fileblock, dataname) + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff,2), & + use_srcpos, fileblock, dataname) + ENDIF + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN + DO iset = istt, iend + rdata(:,iset) = sbuff(:,pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(:,istt:iend) = sbuff + ENDIF + + deallocate (sbuff) + + ENDDO + + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE ncio_read_vector_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_3d ( & + filename, dataname, ndim1, ndim2, pixelset, rdata, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: ndim1, ndim2 + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:,:,:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:,:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart + + IF (.true.) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1,ndim2, pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (.true.) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, ndim1, ndim2, pixelset, iblk, jblk, & + sbuff, block_has_data, defval) + ELSE + allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (block_has_data .and. .not. distributed_restart) THEN + CALL validate_vector_fixed_dimensions((/size(sbuff,1),size(sbuff,2)/), & + (/ndim1,ndim2/), fileblock, dataname) + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff,3), & + use_srcpos, fileblock, dataname) + ENDIF + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN + DO iset = istt, iend + rdata(:,:,iset) = sbuff(:,:,pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(:,:,istt:iend) = sbuff + ENDIF + + deallocate (sbuff) + + ENDDO + + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE ncio_read_vector_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_4d ( & + filename, dataname, ndim1, ndim2, ndim3, pixelset, rdata, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: ndim1, ndim2, ndim3 + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:,:,:,:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:,:,:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart + + IF (.true.) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1,ndim2,ndim3, pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (.true.) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, ndim1, ndim2, ndim3, & + pixelset, iblk, jblk, sbuff, block_has_data, defval) + ELSE + allocate (sbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (block_has_data .and. .not. distributed_restart) THEN + CALL validate_vector_fixed_dimensions((/size(sbuff,1),size(sbuff,2),size(sbuff,3)/), & + (/ndim1,ndim2,ndim3/), fileblock, dataname) + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff,4), & + use_srcpos, fileblock, dataname) + ENDIF + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN + DO iset = istt, iend + rdata(:,:,:,iset) = sbuff(:,:,:,pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(:,:,:,istt:iend) = sbuff + ENDIF + + deallocate (sbuff) + + ENDDO + + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE ncio_read_vector_real8_4d + + + !--------------------------------------------------------- + SUBROUTINE ncio_read_vector_real8_5d ( & + filename, dataname, ndim1, ndim2, ndim3, ndim4, pixelset, rdata, defval) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + integer, intent(in) :: ndim1, ndim2, ndim3, ndim4 + type(pixelset_type), intent(in) :: pixelset + + real(r8), allocatable, intent(inout) :: rdata (:,:,:,:,:) + real(r8), intent(in), optional :: defval + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, iset + character(len=256) :: fileblock + real(r8), allocatable :: sbuff(:,:,:,:,:) + logical :: any_data_exists, block_has_data, use_srcpos, distributed_restart + + IF (.true.) THEN + IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN + allocate (rdata (ndim1,ndim2,ndim3,ndim4, pixelset%nset)) + ENDIF + ENDIF + + any_data_exists = .false. + + IF (.true.) THEN + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + use_srcpos = allocated(pixelset%srcpos) + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos, & + distributed_restart = distributed_restart) + + IF (distributed_restart) THEN + CALL read_distributed_vector_block(filename, dataname, ndim1, ndim2, ndim3, ndim4, & + pixelset, iblk, jblk, sbuff, block_has_data, defval) + ELSE + allocate (sbuff (ndim1,ndim2,ndim3,ndim4, pixelset%vecgs%vlen(iblk,jblk))) + block_has_data = .false. + IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN + CALL ncio_read_serial (fileblock, dataname, sbuff) + block_has_data = .true. + ELSEIF (present(defval)) THEN + sbuff(:,:,:,:,:) = defval + ELSEIF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN + CALL ncio_vector_stop_missing_block (filename, dataname, fileblock) + ENDIF + ENDIF + any_data_exists = any_data_exists .or. block_has_data + + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (block_has_data .and. .not. distributed_restart) THEN + CALL validate_vector_fixed_dimensions((/size(sbuff,1),size(sbuff,2),size(sbuff,3), & + size(sbuff,4)/), & + (/ndim1,ndim2,ndim3,ndim4/), fileblock, dataname) + CALL validate_vector_block_data(pixelset, istt, iend, size(sbuff,5), & + use_srcpos, fileblock, dataname) + ENDIF + IF (use_srcpos .and. block_has_data .and. .not. distributed_restart) THEN + DO iset = istt, iend + rdata(:,:,:,:,iset) = sbuff(:,:,:,:,pixelset%srcpos(iset)) + ENDDO + ELSE + rdata(:,:,:,:,istt:iend) = sbuff + ENDIF + + deallocate (sbuff) + + ENDDO + + IF (pixelset%nset > 0 .and. .not. any_data_exists) THEN + IF (ncio_vector_report_missing(.not. present(defval))) THEN + IF (.not. present(defval)) THEN + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found.' + CALL CoLM_stop () + ELSE + write(*,*) 'Warning : restart data '//trim(dataname) & + //' in '//trim(filename)//' not found, default value is used.' + ENDIF + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE ncio_read_vector_real8_5d + + + !--------------------------------------------------------- + SUBROUTINE ncio_create_file_vector (filename, pixelset) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + type(pixelset_type), intent(in) :: pixelset + + ! Local variables + integer :: iblkgrp, iblk, jblk +#ifdef MPAS_EMBEDDED_COLM + integer :: istt, iend +#endif + character(len=256) :: fileblock + + IF (.true.) THEN + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + CALL ncio_create_file (fileblock) +#ifdef MPAS_EMBEDDED_COLM + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (iend >= istt) THEN + IF (.not. allocated(pixelset%eindex) .or. .not. allocated(pixelset%ipxstt) .or. & + .not. allocated(pixelset%ipxend) .or. .not. allocated(pixelset%settyp)) THEN + write(*,'(A)') 'Error: MPAS embedded CoLM cannot write vector state without pixelset identity metadata.' + CALL CoLM_stop() + ENDIF + CALL ncio_define_dimension(fileblock, 'mpas_local_set', iend - istt + 1) + CALL ncio_write_serial(fileblock, 'mpas_eindex', pixelset%eindex(istt:iend), 'mpas_local_set') + CALL ncio_write_serial(fileblock, 'mpas_ipxstt', pixelset%ipxstt(istt:iend), 'mpas_local_set') + CALL ncio_write_serial(fileblock, 'mpas_ipxend', pixelset%ipxend(istt:iend), 'mpas_local_set') + CALL ncio_write_serial(fileblock, 'mpas_settyp', pixelset%settyp(istt:iend), 'mpas_local_set') + ENDIF +#endif + + ENDDO + ENDIF + + END SUBROUTINE ncio_create_file_vector + + !--------------------------------------------------------- + SUBROUTINE ncio_define_dimension_vector (filename, pixelset, dimname, dimlen) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + type(pixelset_type), intent(in) :: pixelset + character(len=*), intent(in) :: dimname + integer, intent(in), optional :: dimlen + + ! Local variables + integer :: iblkgrp, iblk, jblk + character(len=256) :: fileblock + logical :: fexists + + IF (.true.) THEN + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + inquire (file=trim(fileblock), exist=fexists) + IF (.not. fexists) THEN + CALL ncio_create_file (fileblock) + ENDIF + + IF (present(dimlen)) THEN + CALL ncio_define_dimension (fileblock, trim(dimname), dimlen) + ELSE + CALL ncio_define_dimension (fileblock, trim(dimname), & + pixelset%vecgs%vlen(iblk,jblk)) + ENDIF + + ENDDO + ENDIF + + END SUBROUTINE ncio_define_dimension_vector + + !--------------------------------------------------------- + SUBROUTINE validate_vector_write_layout(pixelset, vector_size, dataname, actual_dims, expected_dims) + + USE MOD_Pixelset, only: pixelset_type + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: vector_size + character(len=*), intent(in) :: dataname + integer, intent(in), optional :: actual_dims(:) + integer, intent(in), optional :: expected_dims(:) + + integer :: iblkgrp + integer :: iblk + integer :: jblk + integer :: istt + integer :: iend + integer :: vlen + logical, allocatable :: covered(:) + + IF (pixelset%nset < 0 .or. vector_size /= pixelset%nset) THEN + CALL CoLM_stop('Invalid vector length while writing '//trim(dataname)//'.') + ENDIF + IF (present(actual_dims) .neqv. present(expected_dims)) THEN + CALL CoLM_stop('Incomplete fixed-dimension metadata while writing '//trim(dataname)//'.') + ENDIF + IF (present(actual_dims) .and. present(expected_dims)) THEN + IF (size(actual_dims) /= size(expected_dims) .or. any(actual_dims /= expected_dims) .or. & + any(actual_dims <= 0)) THEN + CALL CoLM_stop('Fixed dimensions do not match the data while writing '//trim(dataname)//'.') + ENDIF + ENDIF + + IF (pixelset%nblkgrp < 0) THEN + CALL CoLM_stop('Invalid block count while writing '//trim(dataname)//'.') + ENDIF + IF (pixelset%nset == 0) THEN + IF (pixelset%nblkgrp /= 0) CALL CoLM_stop('Empty vector has nonempty block layout while writing '//trim(dataname)//'.') + RETURN + ENDIF + IF (pixelset%nblkgrp < 1 .or. .not. allocated(pixelset%xblkgrp) .or. & + .not. allocated(pixelset%yblkgrp) .or. .not. allocated(pixelset%vecgs%vlen) .or. & + .not. allocated(pixelset%vecgs%vstt) .or. .not. allocated(pixelset%vecgs%vend)) THEN + CALL CoLM_stop('Missing vector block layout while writing '//trim(dataname)//'.') + ENDIF + IF (size(pixelset%xblkgrp) /= pixelset%nblkgrp .or. & + size(pixelset%yblkgrp) /= pixelset%nblkgrp) THEN + CALL CoLM_stop('Inconsistent vector block list while writing '//trim(dataname)//'.') + ENDIF + IF (any(shape(pixelset%vecgs%vlen) /= shape(pixelset%vecgs%vstt)) .or. & + any(shape(pixelset%vecgs%vlen) /= shape(pixelset%vecgs%vend))) THEN + CALL CoLM_stop('Inconsistent vector block arrays while writing '//trim(dataname)//'.') + ENDIF + + allocate(covered(pixelset%nset)) + covered = .false. + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + IF (iblk < lbound(pixelset%vecgs%vlen,1) .or. iblk > ubound(pixelset%vecgs%vlen,1) .or. & + jblk < lbound(pixelset%vecgs%vlen,2) .or. jblk > ubound(pixelset%vecgs%vlen,2)) THEN + CALL CoLM_stop('Vector block index is out of range while writing '//trim(dataname)//'.') + ENDIF + vlen = pixelset%vecgs%vlen(iblk,jblk) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + IF (vlen < 1 .or. istt < 1 .or. iend < istt .or. iend > pixelset%nset .or. & + iend - istt + 1 /= vlen) THEN + CALL CoLM_stop('Invalid vector block bounds while writing '//trim(dataname)//'.') + ENDIF + IF (any(covered(istt:iend))) THEN + CALL CoLM_stop('Overlapping vector blocks while writing '//trim(dataname)//'.') + ENDIF + covered(istt:iend) = .true. + ENDDO + IF (.not. all(covered)) CALL CoLM_stop('Vector block layout has gaps while writing '//trim(dataname)//'.') + deallocate(covered) + + END SUBROUTINE validate_vector_write_layout + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_int32_1d ( & + filename, dataname, dimname, pixelset, wdata, compress_level) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dimname + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: wdata (:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + integer, allocatable :: rbuff(:) + + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata), dataname) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname, & + compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + + + END SUBROUTINE ncio_write_vector_int32_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_logical_1d ( & + filename, dataname, dimname, pixelset, wdata, compress_level) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dimname + type(pixelset_type), intent(in) :: pixelset + logical, intent(in) :: wdata (:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend, i + character(len=256) :: fileblock + integer(1), allocatable :: rbuff(:) + + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata), dataname) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + DO i = istt, iend + IF(wdata(i))THEN + rbuff(i-istt+1) = 1 + ELSE + rbuff(i-istt+1) = 0 + ENDIF + ENDDO + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname, & + compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + + + END SUBROUTINE ncio_write_vector_logical_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_int32_3d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, & + dim3name, pixelset, wdata, compress_level) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name, dim3name + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: ndim1, ndim2 + integer, intent(in) :: wdata (:,:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + integer, allocatable :: rbuff(:,:,:) + + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,3), dataname, & + (/size(wdata,1), size(wdata,2)/), (/ndim1, ndim2/)) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1,ndim2,pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,istt:iend) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + + + END SUBROUTINE ncio_write_vector_int32_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_int64_1d ( & + filename, dataname, dimname, pixelset, wdata, compress_level) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dimname + type(pixelset_type), intent(in) :: pixelset + integer*8, intent(in) :: wdata (:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + integer*8, allocatable :: rbuff(:) + + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata), dataname) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname, & + compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + + + END SUBROUTINE ncio_write_vector_int64_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_1d ( & + filename, dataname, dimname, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dimname + type(pixelset_type), intent(in) :: pixelset + real(r8), intent(in) :: wdata (:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: rbuff(:) + + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata), dataname) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(istt:iend) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dimname, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, dimname) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + + + END SUBROUTINE ncio_write_vector_real8_1d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_2d ( & + filename, dataname, dim1name, ndim1, & + dim2name, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name + integer, intent(in) :: ndim1 + type(pixelset_type), intent(in) :: pixelset + real(r8), intent(in) :: wdata (:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: rbuff(:,:) + + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,2), dataname, & + (/size(wdata,1)/), (/ndim1/)) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,istt:iend) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + + + END SUBROUTINE ncio_write_vector_real8_2d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_3d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, & + dim3name, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name, dim3name + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: ndim1, ndim2 + real(r8), intent(in) :: wdata (:,:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: rbuff(:,:,:) + + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,3), dataname, & + (/size(wdata,1), size(wdata,2)/), (/ndim1, ndim2/)) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, ndim2, pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,istt:iend) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + + + END SUBROUTINE ncio_write_vector_real8_3d + + !--------------------------------------------------------- + SUBROUTINE ncio_write_vector_real8_4d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, dim3name, ndim3, & + dim4name, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name, dim3name, dim4name + integer, intent(in) :: ndim1, ndim2, ndim3 + type(pixelset_type), intent(in) :: pixelset + real(r8), intent(in) :: wdata (:,:,:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: rbuff(:,:,:,:) + + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,4), dataname, & + (/size(wdata,1), size(wdata,2), size(wdata,3)/), & + (/ndim1, ndim2, ndim3/)) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, ndim2, ndim3, pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,:,istt:iend) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, dim4name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, dim4name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + + + END SUBROUTINE ncio_write_vector_real8_4d + + + !------------------------------------------------ + SUBROUTINE ncio_write_vector_real8_5d ( & + filename, dataname, dim1name, ndim1, dim2name, ndim2, & + dim3name, ndim3, dim4name, ndim4, dim5name, pixelset, wdata, compress_level) + + USE MOD_Precision + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_Pixelset + IMPLICIT NONE + + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: dataname + character(len=*), intent(in) :: dim1name, dim2name, dim3name, dim4name, dim5name + type(pixelset_type), intent(in) :: pixelset + integer, intent(in) :: ndim1, ndim2, ndim3, ndim4 + real(r8), intent(in) :: wdata (:,:,:,:,:) + + integer, intent(in), optional :: compress_level + + ! Local variables + integer :: iblkgrp, iblk, jblk, istt, iend + character(len=256) :: fileblock + real(r8), allocatable :: rbuff(:,:,:,:,:) + + IF (.true.) THEN + CALL validate_vector_write_layout(pixelset, size(wdata,5), dataname, & + (/size(wdata,1), size(wdata,2), size(wdata,3), size(wdata,4)/), & + (/ndim1, ndim2, ndim3, ndim4/)) + + DO iblkgrp = 1, pixelset%nblkgrp + iblk = pixelset%xblkgrp(iblkgrp) + jblk = pixelset%yblkgrp(iblkgrp) + + allocate (rbuff (ndim1, ndim2, ndim3, ndim4, pixelset%vecgs%vlen(iblk,jblk))) + istt = pixelset%vecgs%vstt(iblk,jblk) + iend = pixelset%vecgs%vend(iblk,jblk) + rbuff = wdata(:,:,:,:,istt:iend) + + CALL get_filename_vector_block (filename, iblk, jblk, fileblock, for_write = .true.) + IF (present(compress_level)) THEN + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, dim4name, dim5name, compress = compress_level) + ELSE + CALL ncio_write_serial (fileblock, dataname, rbuff, & + dim1name, dim2name, dim3name, dim4name, dim5name) + ENDIF + + deallocate (rbuff) + + ENDDO + + ENDIF + + + END SUBROUTINE ncio_write_vector_real8_5d + !------------------------------------------------ + + LOGICAL FUNCTION ncio_vector_report_missing(mandatory) + + USE MOD_MPAS_MPI, only: mpas_rank, mpas_root + IMPLICIT NONE + + logical, intent(in) :: mandatory + +#ifdef MPAS_EMBEDDED_COLM + ncio_vector_report_missing = mandatory .or. (mpas_rank == mpas_root) +#else + ncio_vector_report_missing = (mpas_rank == mpas_root) +#endif + + END FUNCTION ncio_vector_report_missing + + +END MODULE MOD_NetCDFVector diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 new file mode 100644 index 0000000000..59bbc8bcfd --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90 @@ -0,0 +1,401 @@ +#include + +MODULE MOD_Pixel + +!------------------------------------------------------------------------------------ +! !DESCRIPTION: +! +! Pixels are rasterized points defined by fine-resolution data. +! +! CoLM USE multiple grids to construct pixels. Grids are assimilated into pixel +! coordinate one by one. One grid is assimilated by adding grid lines not present +! in pixel coordinate. In other words, pixel coordinate is the union of all grids. +! +! Pixels are used to carry out land surface tessellation. The grids used to +! construct pixels are associated with surface data such as land cover types, soil +! parameters, plant function types, leaf area index and forest height. +! By using pixels, these variables are downscaled to fine resolution. +! +! In pixel data type, region boundaries and each pixel boundaries are defined. +! Subroutines to assimilate grid and map pixel to grid are defined as methods. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------ + + USE MOD_Precision + IMPLICIT NONE + + ! ---- data types ---- + type :: pixel_type + + real(r8) :: edges ! southern edge (degrees) + real(r8) :: edgen ! northern edge (degrees) + real(r8) :: edgew ! western edge (degrees) + real(r8) :: edgee ! eastern edge (degrees) + + integer :: nlon, nlat + real(r8), allocatable :: lat_s (:) + real(r8), allocatable :: lat_n (:) + real(r8), allocatable :: lon_w (:) + real(r8), allocatable :: lon_e (:) + + CONTAINS + procedure, PUBLIC :: set_edges => pixel_set_edges + + procedure, PRIVATE :: assimilate_latlon => pixel_assimilate_latlon + procedure, PUBLIC :: assimilate_gblock => pixel_assimilate_gblock + procedure, PUBLIC :: assimilate_grid => pixel_assimilate_grid + + procedure, PUBLIC :: map_to_grid => pixel_map_to_grid + + procedure, PUBLIC :: load_from_file => pixel_load_from_file + + final :: pixel_free_mem + + END type pixel_type + + ! ---- Instance ---- + type(pixel_type) :: pixel + +CONTAINS + + ! -------------------------------- + SUBROUTINE pixel_set_edges (this, & + edges_in, edgen_in, edgew_in, edgee_in) + + USE MOD_Precision + USE MOD_MPAS_MPI + USE MOD_Utils + IMPLICIT NONE + + class(pixel_type) :: this + + real(r8), intent(in) :: edges_in, edgen_in + real(r8), intent(in) :: edgew_in, edgee_in + + this%nlon = 1 + this%nlat = 1 + + this%edges = edges_in + this%edgen = edgen_in + this%edgew = edgew_in + this%edgee = edgee_in + + CALL normalize_longitude (this%edgew) + CALL normalize_longitude (this%edgee) + + allocate (this%lat_s (1)) + allocate (this%lat_n (1)) + allocate (this%lon_w (1)) + allocate (this%lon_e (1)) + + this%lat_s(1) = this%edges + this%lat_n(1) = this%edgen + this%lon_w(1) = this%edgew + this%lon_e(1) = this%edgee + + IF (mpas_is_root) THEN + write(*,'(A)') '----- Region information -----' + write(*,'(A,F10.4,A,F10.4,A,F10.4,A,F10.4,A)') ' (south,north,west,east) = (', & + this%edges, ',', this%edgen, ',', this%edgew, ',', this%edgee, ')' + ENDIF + + END SUBROUTINE pixel_set_edges + + ! -------------------------------- + SUBROUTINE pixel_assimilate_latlon (this, & + nlat, lat_s, lat_n, nlon, lon_w, lon_e) + + USE MOD_Precision + USE MOD_Utils + IMPLICIT NONE + class(pixel_type) :: this + + integer, intent(in) :: nlat + real(r8), intent(in) :: lat_s(nlat), lat_n(nlat) + integer, intent(in) :: nlon + real(r8), intent(in) :: lon_w(nlon), lon_e(nlon) + + ! Local variables + real(r8) :: south, north, west, east + + integer :: ny, yinc + integer :: iy1, iy2, ys2, yn2 + real(r8), allocatable :: ytmp(:) + + integer :: nx, nlonc + integer :: ix1, ix2, xw2 + real(r8), allocatable :: xtmp(:), loncirc(:) + + IF (lat_s(1) <= lat_s(nlat)) THEN + yinc = 1 + south = lat_s(1) + north = lat_n(nlat) + ELSE + yinc = -1 + south = lat_s(nlat) + north = lat_n(1) + ENDIF + + allocate (ytmp (this%nlat+nlat+2)) + + ny = 0 + DO iy1 = 1, this%nlat + + ny = ny + 1 + ytmp(ny) = this%lat_s(iy1) + + IF ((this%lat_s(iy1) < north) .and. (this%lat_n(iy1) > south)) THEN + ys2 = find_nearest_south (this%lat_s(iy1), nlat, lat_s) + yn2 = find_nearest_north (this%lat_n(iy1), nlat, lat_n) + DO iy2 = ys2, yn2, yinc + IF (lat_s(iy2) > this%lat_s(iy1)) THEN + ny = ny + 1 + ytmp(ny) = lat_s(iy2) + ENDIF + ENDDO + IF (lat_n(yn2) < this%lat_n(iy1)) THEN + ny = ny + 1 + ytmp(ny) = lat_n(yn2) + ENDIF + ENDIF + ENDDO + + ny = ny + 1 + ytmp(ny) = this%lat_n(this%nlat) + + deallocate (this%lat_s) + deallocate (this%lat_n) + + this%nlat = ny - 1 + allocate (this%lat_s (this%nlat)) + allocate (this%lat_n (this%nlat)) + + this%lat_s = ytmp(1:ny-1) + this%lat_n = ytmp(2:ny) + + deallocate (ytmp) + + west = lon_w(1) + east = lon_e(nlon) + + IF (west == east) THEN + nlonc = nlon + allocate (loncirc (nlonc)) + loncirc = lon_w + ELSE + nlonc = nlon + 1 + allocate (loncirc (nlonc)) + loncirc(1:nlon) = lon_w + loncirc(nlon+1) = east + ENDIF + + allocate (xtmp (this%nlon+nlon+2)) + nx = 0 + DO ix1 = 1, this%nlon + + nx = nx + 1 + xtmp(nx) = this%lon_w(ix1) + + xw2 = find_nearest_west (this%lon_w(ix1), nlonc, loncirc) + ix2 = mod(xw2,nlonc) + 1 + DO WHILE (.true.) + IF (lon_between_floor(loncirc(ix2), this%lon_w(ix1), this%lon_e(ix1))) THEN + IF (loncirc(ix2) /= this%lon_w(ix1)) THEN + nx = nx + 1 + xtmp(nx) = loncirc(ix2) + ENDIF + + IF (ix2 /= xw2) THEN + ix2 = mod(ix2,nlonc) + 1 + ELSE + EXIT + ENDIF + ELSE + EXIT + ENDIF + ENDDO + + ENDDO + + nx = nx + 1 + xtmp(nx) = this%lon_e(this%nlon) + + deallocate (this%lon_w) + deallocate (this%lon_e) + + this%nlon = nx - 1 + allocate (this%lon_w (this%nlon)) + allocate (this%lon_e (this%nlon)) + + this%lon_w = xtmp(1:nx-1) + this%lon_e = xtmp(2:nx) + + deallocate (xtmp) + + END SUBROUTINE pixel_assimilate_latlon + + ! -------------------------------- + SUBROUTINE pixel_assimilate_gblock (this) + + USE MOD_Block, only: gblock + IMPLICIT NONE + class(pixel_type) :: this + + CALL this%assimilate_latlon ( & + gblock%nyblk, gblock%lat_s, gblock%lat_n, & + gblock%nxblk, gblock%lon_w, gblock%lon_e) + + END SUBROUTINE pixel_assimilate_gblock + + ! -------------------------------- + SUBROUTINE pixel_assimilate_grid (this, grid) + + USE MOD_Grid + IMPLICIT NONE + class(pixel_type) :: this + + type(grid_type), intent(in) :: grid + + CALL this%assimilate_latlon ( & + grid%nlat, grid%lat_s, grid%lat_n, & + grid%nlon, grid%lon_w, grid%lon_e) + + END SUBROUTINE pixel_assimilate_grid + + ! -------------------------------- + SUBROUTINE pixel_map_to_grid (this, grd) + + USE MOD_Grid + USE MOD_Utils + IMPLICIT NONE + class(pixel_type) :: this + + type(grid_type), intent(inout) :: grd + + ! Local variables + integer :: iy1, iy2, ix1, ix2 + real(r8) :: south, north, west, east + + IF (allocated (grd%xgrd)) deallocate (grd%xgrd) + IF (allocated (grd%ygrd)) deallocate (grd%ygrd) + + allocate (grd%ygrd (this%nlat)) + + IF (grd%yinc == 1) THEN + south = grd%lat_s(1) + north = grd%lat_n(grd%nlat) + ELSE + south = grd%lat_s(grd%nlat) + north = grd%lat_n(1) + ENDIF + + iy1 = 1 + DO WHILE (.true.) + IF ((this%lat_s(iy1) < north) .and. (this%lat_n(iy1) > south)) THEN + iy2 = find_nearest_south (this%lat_s(iy1), grd%nlat, grd%lat_s) + DO WHILE (this%lat_n(iy1) <= grd%lat_n(iy2)) + grd%ygrd(iy1) = iy2 + iy1 = iy1 + 1 + IF (iy1 > this%nlat) EXIT + ENDDO + ELSE + write(*,*) 'Warning: grid in latitude does not cover simulation region completely.', & + south, north, this%lat_s(iy1), this%lat_n(iy1) + grd%ygrd(iy1) = -1 + iy1 = iy1 + 1 + ENDIF + IF (iy1 > this%nlat) EXIT + ENDDO + + allocate (grd%xgrd (this%nlon)) + + west = grd%lon_w(1) + east = grd%lon_e(grd%nlon) + + ix1 = 1 + DO WHILE (.true.) + IF ( lon_between_floor(this%lon_w(ix1), west, east) & + .or. lon_between_ceil (this%lon_e(ix1), west, east) ) THEN + + ix2 = find_nearest_west (this%lon_w(ix1), grd%nlon, grd%lon_w) + DO WHILE (lon_between_ceil(this%lon_e(ix1), grd%lon_w(ix2), grd%lon_e(ix2))) + grd%xgrd(ix1) = ix2 + ix1 = ix1 + 1 + IF (ix1 > this%nlon) EXIT + ENDDO + + ELSE + write(*,*) 'Warning: grid in longitude does not cover simulation region completely.', & + west, east, this%lon_w(ix1), this%lon_e(ix1) + grd%xgrd(ix1) = -1 + ix1 = ix1 + 1 + ENDIF + IF (ix1 > this%nlon) EXIT + ENDDO + + END SUBROUTINE pixel_map_to_grid + + ! -------------------------------- + SUBROUTINE pixel_load_from_file (this, dir_landdata) + + USE MOD_NetCDFSerial + USE MOD_MPAS_MPI, only: CoLM_stop + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + class(pixel_type) :: this + + character(len=*), intent(in) :: dir_landdata + ! Local variables + character(len=256) :: filename + + filename = trim(dir_landdata) // '/pixel.nc' + + CALL ncio_read_bcast_serial (filename, 'edges', this%edges) + CALL ncio_read_bcast_serial (filename, 'edgen', this%edgen) + CALL ncio_read_bcast_serial (filename, 'edgew', this%edgew) + CALL ncio_read_bcast_serial (filename, 'edgee', this%edgee) + + CALL ncio_read_bcast_serial (filename, 'lat_s', this%lat_s) + CALL ncio_read_bcast_serial (filename, 'lat_n', this%lat_n) + CALL ncio_read_bcast_serial (filename, 'lon_w', this%lon_w) + CALL ncio_read_bcast_serial (filename, 'lon_e', this%lon_e) + + this%nlon = size(this%lon_w) + this%nlat = size(this%lat_s) + + IF (this%nlon < 1 .or. this%nlat < 1 .or. size(this%lon_e) /= this%nlon .or. & + size(this%lat_n) /= this%nlat) THEN + CALL CoLM_stop('CoLM pixel.nc contains inconsistent pixel-boundary dimensions.') + ENDIF + IF (.not. all(ieee_is_finite((/this%edges, this%edgen, this%edgew, this%edgee/))) .or. & + .not. all(ieee_is_finite(this%lat_s)) .or. .not. all(ieee_is_finite(this%lat_n)) .or. & + .not. all(ieee_is_finite(this%lon_w)) .or. .not. all(ieee_is_finite(this%lon_e))) THEN + CALL CoLM_stop('CoLM pixel.nc contains non-finite pixel boundaries.') + ENDIF + IF (any(this%lat_s < -90._r8) .or. any(this%lat_n > 90._r8) .or. & + any(this%lat_n <= this%lat_s)) THEN + CALL CoLM_stop('CoLM pixel.nc contains invalid latitude boundaries.') + ENDIF + IF (this%nlat > 1) THEN + IF (any(this%lat_s(2:) <= this%lat_s(:this%nlat-1))) & + CALL CoLM_stop('CoLM pixel.nc latitude pixels are not ordered south to north.') + ENDIF + + END SUBROUTINE pixel_load_from_file + + ! -------------------------------- + SUBROUTINE pixel_free_mem (this) + + IMPLICIT NONE + type (pixel_type) :: this + + IF (allocated(this%lat_s)) deallocate(this%lat_s) + IF (allocated(this%lat_n)) deallocate(this%lat_n) + IF (allocated(this%lon_w)) deallocate(this%lon_w) + IF (allocated(this%lon_e)) deallocate(this%lon_e) + + END SUBROUTINE pixel_free_mem + +END MODULE MOD_Pixel diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 new file mode 100644 index 0000000000..d8a52b15a9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90 @@ -0,0 +1,729 @@ +#include + +MODULE MOD_Pixelset + +!------------------------------------------------------------------------------------ +! !DESCRIPTION: +! +! Pixelset refers to a set of pixels in CoLM. +! +! In CoLM, the global/regional area is divided into a hierarchical structure: +! 1. If GRIDBASED or UNSTRUCTURED is defined, it is +! ELEMENT >>> PATCH +! 2. If CATCHMENT is defined, it is +! ELEMENT >>> HRU >>> PATCH +! If Plant FUNCTION Type classification is used, PATCH is further divided into PFT. +! If Plant Community classification is used, PATCH is further divided into PC. +! +! In CoLM, the land surface is first divided into pixels, which are rasterized +! points defined by fine-resolution data. Then ELEMENT, PATCH, HRU, PFT, PC +! are all consists of pixels, and hence they are all pixelsets. +! +! The highest level pixelset in CoLM is ELEMENT, all other pixelsets are subsets +! of ELEMENTs. +! In a pixelset, pixels are sorted to make pixels in its subsets consecutive. +! Thus a subset can be represented by starting pixel index and ending pixel index +! in an ELEMENT. +! +! Example of hierarchical pixelsets +! ************************************************ <-- pixels in an ELEMENT +! |<------------------- ELEMENT ---------------->| <-- level 1 +! | subset 1 | subset 2 | subset 3 | <-- level 2 +! |s11| s12 | s21 | s22 | s23 | s31 | <-- level 3 +! +! "Vector" is a collection of data when each pixelset in a given level is associated +! with a value, representing its averaged physical, chemical or biological state. +! +! MPAS-embedded CoLM keeps land vectors on MPAS-owned cell subsets. +! +! Created by Shupeng Zhang, May 2023 +!------------------------------------------------------------------------------------ + + USE MOD_Precision + USE MOD_DataType + IMPLICIT NONE + + ! ---- data types ---- + type :: vec_gather_scatter_type + + ! rank-local vector layout + integer, allocatable :: vlen(:,:) + + ! local vector offsets + integer, allocatable :: vstt(:,:) + integer, allocatable :: vend(:,:) + + CONTAINS + final :: vec_gather_scatter_free_mem + + END type vec_gather_scatter_type + + ! ---- data types ---- + type :: pixelset_type + + integer :: nset + + integer*8, allocatable :: eindex(:) ! global index of element to which pixelset belongs + + integer, allocatable :: ipxstt(:) ! start local index of pixel in the element + integer, allocatable :: ipxend(:) ! end local index of pixel in the element + integer, allocatable :: settyp(:) ! type of pixelset + + integer, allocatable :: ielm(:) ! local index of element to which pixelset belongs + integer, allocatable :: srcpos(:) ! original block-vector position for packed subsets + + integer :: nblkgrp ! number of blocks for this process's working group + integer, allocatable :: xblkgrp (:) ! block index in longitude for this process's group + integer, allocatable :: yblkgrp (:) ! block index in latitude for this process's group + + type(vec_gather_scatter_type) :: vecgs ! for vector gathering and scattering + + logical :: has_shared = .false. + real(r8), allocatable :: pctshared (:) + + CONTAINS + procedure, PUBLIC :: set_vecgs => vec_gather_scatter_set + procedure, PUBLIC :: get_lonlat_radian => pixelset_get_lonlat_radian + procedure, PUBLIC :: pset_pack => pixelset_pack + procedure, PUBLIC :: forc_free_mem => pixelset_forc_free_mem + final :: pixelset_free_mem + + END type pixelset_type + + ! ---- data types ---- + type :: subset_type + + integer, allocatable :: substt(:) + integer, allocatable :: subend(:) + real(r8), allocatable :: subfrc(:) + + CONTAINS + procedure, PUBLIC :: build => subset_build + final :: subset_free_mem + + END type subset_type + + ! ---- data types ---- + type :: superset_type + + integer, allocatable :: sup(:) + + CONTAINS + procedure, PUBLIC :: build => superset_build + final :: superset_free_mem + + END type superset_type + +CONTAINS + + ! -------------------------------- + SUBROUTINE pixelset_get_lonlat_radian (this, rlon, rlat) + + USE MOD_Precision + USE MOD_Utils + USE MOD_Pixel + USE MOD_Mesh + + IMPLICIT NONE + CLASS(pixelset_type) :: this + + real(r8), intent(inout) :: rlon(:), rlat(:) + + ! Local Variables + integer :: iset, ie, ipxstt, ipxend, npxl, ipxl + real(r8), allocatable :: area(:) + + DO iset = 1, this%nset + + ie = this%ielm(iset) + + ipxstt = this%ipxstt (iset) + ipxend = this%ipxend (iset) + + ! for 2m WMO patch, use all pixels + IF (ipxstt == -1) THEN + ipxstt = 1 + ipxend = mesh(ie)%npxl + ENDIF + + allocate (area (ipxstt:ipxend)) + DO ipxl = ipxstt, ipxend + area(ipxl) = areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), & + pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), & + pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + + npxl = ipxend - ipxstt + 1 + rlat(iset) = get_pixelset_rlat ( & + npxl, mesh(ie)%ilat(ipxstt:ipxend), area) + rlon(iset) = get_pixelset_rlon ( & + npxl, mesh(ie)%ilon(ipxstt:ipxend), area) + + deallocate (area) + + ENDDO + + END SUBROUTINE pixelset_get_lonlat_radian + + ! -------------------------------- + FUNCTION get_pixelset_rlat (npxl, ilat, area) result(rlat) + + USE MOD_Precision + USE MOD_Vars_Global, only: pi + USE MOD_Pixel + IMPLICIT NONE + + real(r8) :: rlat + + integer, intent(in) :: npxl + integer, intent(in) :: ilat(npxl) + real(r8), intent(in) :: area(npxl) + + ! Local variables + integer :: ipxl + + rlat = 0.0 + DO ipxl = 1, npxl + rlat = rlat + (pixel%lat_s(ilat(ipxl)) + pixel%lat_n(ilat(ipxl))) * 0.5 * area(ipxl) + ENDDO + rlat = rlat / sum(area) * pi/180.0 + + END FUNCTION get_pixelset_rlat + + ! -------------------------------- + FUNCTION get_pixelset_rlon (npxl, ilon, area) result(rlon) + + USE MOD_Precision + USE MOD_Utils + USE MOD_Vars_Global, only: pi + USE MOD_Pixel + IMPLICIT NONE + + real(r8) :: rlon + + integer, intent(in) :: npxl + integer, intent(in) :: ilon(npxl) + real(r8), intent(in) :: area(npxl) + + ! Local variables + integer :: ipxl + real(r8) :: lon, lon0, area_done + + lon = 0.0 + area_done = 0.0 + DO ipxl = 1, npxl + + IF (pixel%lon_w(ilon(ipxl)) > pixel%lon_e(ilon(ipxl))) THEN + lon0 = (pixel%lon_w(ilon(ipxl)) + pixel%lon_e(ilon(ipxl)) + 360.0) * 0.5 + ELSE + lon0 = (pixel%lon_w(ilon(ipxl)) + pixel%lon_e(ilon(ipxl))) * 0.5 + ENDIF + + CALL normalize_longitude (lon0) + + IF (lon - lon0 > 180._r8) THEN + lon = lon * area_done + (lon0 + 360._r8) * area(ipxl) + ELSEIF (lon - lon0 < -180._r8) THEN + lon = lon * area_done + (lon0 - 360._r8) * area(ipxl) + ELSE + lon = lon * area_done + lon0 * area(ipxl) + ENDIF + + area_done = area_done + area(ipxl) + lon = lon / area_done + + CALL normalize_longitude(lon) + + ENDDO + + rlon = lon * pi/180.0 + + END FUNCTION get_pixelset_rlon + + ! -------------------------------- + SUBROUTINE pixelset_free_mem (this) + + IMPLICIT NONE + type (pixelset_type) :: this + + IF (allocated(this%eindex)) deallocate(this%eindex) + IF (allocated(this%ipxstt)) deallocate(this%ipxstt) + IF (allocated(this%ipxend)) deallocate(this%ipxend) + IF (allocated(this%settyp)) deallocate(this%settyp) + + IF (allocated(this%ielm )) deallocate(this%ielm ) + IF (allocated(this%srcpos)) deallocate(this%srcpos) + + IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) + IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + + CALL vec_gather_scatter_free_mem(this%vecgs) + + IF (allocated(this%pctshared)) deallocate(this%pctshared) + + this%nset = 0 + this%nblkgrp = 0 + this%has_shared = .false. + + END SUBROUTINE pixelset_free_mem + + ! -------------------------------- + SUBROUTINE pixelset_forc_free_mem (this) + + IMPLICIT NONE + + class(pixelset_type) :: this + + IF (allocated(this%eindex )) deallocate(this%eindex ) + IF (allocated(this%ipxstt )) deallocate(this%ipxstt ) + IF (allocated(this%ipxend )) deallocate(this%ipxend ) + IF (allocated(this%settyp )) deallocate(this%settyp ) + + IF (allocated(this%ielm )) deallocate(this%ielm ) + IF (allocated(this%srcpos )) deallocate(this%srcpos ) + + IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) + IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + + CALL vec_gather_scatter_free_mem(this%vecgs) + + IF (allocated(this%pctshared)) deallocate(this%pctshared) + + this%nset = 0 + this%nblkgrp = 0 + this%has_shared = .false. + + END SUBROUTINE pixelset_forc_free_mem + + ! -------------------------------- + SUBROUTINE copy_pixelset(pixel_from, pixel_to) + + IMPLICIT NONE + + type(pixelset_type), intent(in) :: pixel_from + type(pixelset_type), intent(out) :: pixel_to + + pixel_to%nset = pixel_from%nset + pixel_to%eindex = pixel_from%eindex + pixel_to%ipxstt = pixel_from%ipxstt + pixel_to%ipxend = pixel_from%ipxend + pixel_to%settyp = pixel_from%settyp + pixel_to%ielm = pixel_from%ielm + IF (allocated(pixel_from%srcpos)) THEN + pixel_to%srcpos = pixel_from%srcpos + ENDIF + + pixel_to%nblkgrp = pixel_from%nblkgrp + pixel_to%xblkgrp = pixel_from%xblkgrp + pixel_to%yblkgrp = pixel_from%yblkgrp + + IF (pixel_from%has_shared) THEN + pixel_to%pctshared = pixel_from%pctshared + ENDIF + + END SUBROUTINE + + ! -------------------------------- + SUBROUTINE vec_gather_scatter_set (this) + + USE MOD_Block + USE MOD_MPAS_MPI + USE MOD_Mesh + IMPLICIT NONE + + class(pixelset_type) :: this + + ! Local variables + integer :: iset, ie, xblk, yblk, iblk, jblk, iblkgrp + logical, allocatable :: nonzero(:,:) + + + IF (.not. allocated (this%vecgs%vlen)) THEN + allocate (this%vecgs%vlen (gblock%nxblk, gblock%nyblk)) + this%vecgs%vlen(:,:) = 0 + ENDIF + + IF (.true.) THEN + + IF (this%nset > 0) THEN + IF (.not. allocated(this%eindex)) THEN + CALL CoLM_stop('Invalid pixelset element-index vector in set_vecgs.') + ENDIF + IF (size(this%eindex) /= this%nset) THEN + CALL CoLM_stop('Invalid pixelset element-index vector in set_vecgs.') + ENDIF + IF (.not. allocated(this%ielm)) THEN + CALL CoLM_stop('Pixelset element mapping must be established before set_vecgs.') + ENDIF + IF (size(this%ielm) /= this%nset) THEN + CALL CoLM_stop('Pixelset element mapping must be established before set_vecgs.') + ENDIF + IF (.not. allocated(mesh)) THEN + CALL CoLM_stop('Pixelset vector layout requires an allocated local element mesh.') + ENDIF + ENDIF + + IF (.not. allocated (this%vecgs%vstt)) THEN + allocate (this%vecgs%vstt (gblock%nxblk, gblock%nyblk)) + allocate (this%vecgs%vend (gblock%nxblk, gblock%nyblk)) + ENDIF + + this%vecgs%vstt(:,:) = 0 + this%vecgs%vend(:,:) = -1 + + xblk = 0 + yblk = 0 + DO iset = 1, this%nset + ie = this%ielm(iset) + IF (ie < 1 .or. ie > size(mesh)) THEN + CALL CoLM_stop('Pixelset contains an out-of-range local element index in set_vecgs.') + ENDIF + IF (this%eindex(iset) /= mesh(ie)%indx) THEN + CALL CoLM_stop('Pixelset element ID does not match its local CoLM element in set_vecgs.') + ENDIF + IF (mesh(ie)%xblk < 1 .or. mesh(ie)%xblk > gblock%nxblk .or. & + mesh(ie)%yblk < 1 .or. mesh(ie)%yblk > gblock%nyblk) THEN + CALL CoLM_stop('Pixelset references an element with an invalid CoLM block index.') + ENDIF + + IF ((mesh(ie)%xblk /= xblk) .or. (mesh(ie)%yblk /= yblk)) THEN + xblk = mesh(ie)%xblk + yblk = mesh(ie)%yblk + this%vecgs%vstt(xblk,yblk) = iset + ENDIF + + this%vecgs%vend(xblk,yblk) = iset + ENDDO + + this%vecgs%vlen = this%vecgs%vend - this%vecgs%vstt + 1 + + ENDIF + + + IF (.true.) THEN + allocate (nonzero (gblock%nxblk,gblock%nyblk)) + + nonzero = this%vecgs%vlen > 0 + + this%nblkgrp = count(nonzero) + IF (allocated(this%xblkgrp)) deallocate(this%xblkgrp) + IF (allocated(this%yblkgrp)) deallocate(this%yblkgrp) + allocate (this%xblkgrp (this%nblkgrp)) + allocate (this%yblkgrp (this%nblkgrp)) + + iblkgrp = 0 + DO jblk = 1, gblock%nyblk + DO iblk = 1, gblock%nxblk + IF (nonzero(iblk,jblk)) THEN + iblkgrp = iblkgrp + 1 + this%xblkgrp(iblkgrp) = iblk + this%yblkgrp(iblkgrp) = jblk + ENDIF + ENDDO + ENDDO + + deallocate(nonzero) + ENDIF + + END SUBROUTINE vec_gather_scatter_set + + ! -------------------------------- + SUBROUTINE pixelset_pack (this, mask, nset_packed) + + USE MOD_MPAS_MPI + IMPLICIT NONE + class(pixelset_type) :: this + logical, intent(in) :: mask(:) + integer, intent(out) :: nset_packed + + integer*8, allocatable :: eindex_(:) + integer, allocatable :: ipxstt_(:) + integer, allocatable :: ipxend_(:) + integer, allocatable :: settyp_(:) + integer, allocatable :: ielm_ (:) + integer, allocatable :: srcpos_(:) + + real(r8), allocatable :: pctshared_(:) + integer :: s, e + + IF (.true.) THEN + + IF (this%nset > 0) THEN + IF (count(mask) < this%nset) THEN + + allocate (eindex_(this%nset)) + allocate (ipxstt_(this%nset)) + allocate (ipxend_(this%nset)) + allocate (settyp_(this%nset)) + allocate (ielm_ (this%nset)) + IF (allocated(this%srcpos)) allocate (srcpos_(this%nset)) + + eindex_ = this%eindex + ipxstt_ = this%ipxstt + ipxend_ = this%ipxend + settyp_ = this%settyp + ielm_ = this%ielm + IF (allocated(this%srcpos)) srcpos_ = this%srcpos + + deallocate (this%eindex) + deallocate (this%ipxstt) + deallocate (this%ipxend) + deallocate (this%settyp) + deallocate (this%ielm ) + IF (allocated(this%srcpos)) deallocate (this%srcpos) + + IF (this%has_shared) THEN + allocate (pctshared_(this%nset)) + pctshared_ = this%pctshared + deallocate (this%pctshared) + ENDIF + + this%nset = count(mask) + + IF (this%nset > 0) THEN + + allocate (this%eindex(this%nset)) + allocate (this%ipxstt(this%nset)) + allocate (this%ipxend(this%nset)) + allocate (this%settyp(this%nset)) + allocate (this%ielm (this%nset)) + IF (allocated(srcpos_)) allocate (this%srcpos(this%nset)) + + this%eindex = pack(eindex_, mask) + this%ipxstt = pack(ipxstt_, mask) + this%ipxend = pack(ipxend_, mask) + this%settyp = pack(settyp_, mask) + this%ielm = pack(ielm_ , mask) + IF (allocated(srcpos_)) this%srcpos = pack(srcpos_, mask) + + IF (this%has_shared) THEN + + this%pctshared = pack(pctshared_, mask) + + s = 1 + DO WHILE (s < this%nset) + e = s + DO WHILE (e < this%nset) + IF ((this%ielm(e+1) == this%ielm(s)) & + .and. (this%ipxstt(e+1) == this%ipxstt(s))) THEN + e = e + 1 + ELSE + EXIT + ENDIF + ENDDO + + IF (e > s) THEN + this%pctshared(s:e) = this%pctshared(s:e)/sum(this%pctshared(s:e)) + ENDIF + + s = e + 1 + ENDDO + + ENDIF + + ENDIF + + deallocate (eindex_) + deallocate (ipxstt_) + deallocate (ipxend_) + deallocate (settyp_) + deallocate (ielm_ ) + IF (allocated(srcpos_)) deallocate (srcpos_) + + IF (this%has_shared) THEN + deallocate (pctshared_) + ENDIF + + ENDIF + ENDIF + + ENDIF + + CALL this%set_vecgs + + nset_packed = this%nset + + END SUBROUTINE pixelset_pack + + ! -------------------------------- + SUBROUTINE vec_gather_scatter_free_mem (this) + + IMPLICIT NONE + type (vec_gather_scatter_type) :: this + + IF (allocated(this%vlen)) deallocate (this%vlen) + IF (allocated(this%vstt)) deallocate (this%vstt) + IF (allocated(this%vend)) deallocate (this%vend) + END SUBROUTINE vec_gather_scatter_free_mem + + ! -------------------------------- + SUBROUTINE subset_build (this, superset, subset, use_frac) + + USE MOD_Mesh + USE MOD_Pixel + USE MOD_Utils + USE MOD_MPAS_MPI, only: CoLM_stop + USE, INTRINSIC :: ieee_arithmetic, only: ieee_is_finite + IMPLICIT NONE + + CLASS(subset_type) :: this + + type (pixelset_type), intent(in) :: superset + type (pixelset_type), intent(in) :: subset + logical, intent(in) :: use_frac + + ! Local Variables + integer :: isuperset, isubset, ielm, ipxl, istt, iend + real(r8) :: subset_area + + IF (superset%has_shared) THEN + write(*,*) 'Warning: superset has shared area.' + ENDIF + + IF (allocated(this%substt)) deallocate(this%substt) + IF (allocated(this%subend)) deallocate(this%subend) + + allocate (this%substt (superset%nset)) + allocate (this%subend (superset%nset)) + + this%substt = 0 + this%subend = -1 + + IF (use_frac) THEN + IF (allocated(this%subfrc)) deallocate(this%subfrc) + allocate (this%subfrc (subset%nset)) + ENDIF + + IF (superset%nset <= 0 .or. subset%nset <= 0) RETURN + + isuperset = 1 + isubset = 1 + DO WHILE (isubset <= subset%nset) + IF (isuperset > superset%nset) THEN + CALL CoLM_stop('A CoLM subset does not belong to any loaded element.') + ENDIF + IF ( (subset%eindex(isubset) == superset%eindex(isuperset)) & + .and. (subset%ipxstt(isubset) >= superset%ipxstt(isuperset) .or. & + subset%ipxstt(isubset) == -1 ) & + .and. (subset%ipxend(isubset) <= superset%ipxend(isuperset) .or. & + subset%ipxend(isubset) == -1 ) ) THEN + + IF (this%substt(isuperset) == 0) THEN + this%substt(isuperset) = isubset + ENDIF + + this%subend(isuperset) = isubset + + isubset = isubset + 1 + ELSE + isuperset = isuperset + 1 + ENDIF + ENDDO + + IF (use_frac) THEN + + DO isubset = 1, subset%nset + ielm = subset%ielm(isubset) + IF (ielm < 1 .or. ielm > size(mesh)) THEN + CALL CoLM_stop('A CoLM subset references an invalid local element.') + ENDIF + IF (subset%ipxstt(isubset) /= -1) THEN + IF (subset%ipxstt(isubset) < 1 .or. subset%ipxend(isubset) < subset%ipxstt(isubset) .or. & + subset%ipxend(isubset) > mesh(ielm)%npxl) THEN + CALL CoLM_stop('A CoLM subset references pixels outside its element.') + ENDIF + ELSEIF (subset%ipxend(isubset) /= -1) THEN + CALL CoLM_stop('A CoLM virtual subset has inconsistent pixel bounds.') + ENDIF + this%subfrc(isubset) = 0 + DO ipxl = subset%ipxstt(isubset), subset%ipxend(isubset) + IF (ipxl == -1) CYCLE + this%subfrc(isubset) = this%subfrc(isubset) & + + areaquad (& + pixel%lat_s(mesh(ielm)%ilat(ipxl)), & + pixel%lat_n(mesh(ielm)%ilat(ipxl)), & + pixel%lon_w(mesh(ielm)%ilon(ipxl)), & + pixel%lon_e(mesh(ielm)%ilon(ipxl)) ) + ENDDO + IF (subset%has_shared) THEN + this%subfrc(isubset) = this%subfrc(isubset) * subset%pctshared(isubset) + ENDIF + ENDDO + + DO isuperset = 1, superset%nset + IF (this%substt(isuperset) /= 0) THEN + istt = this%substt(isuperset) + iend = this%subend(isuperset) + subset_area = sum(this%subfrc(istt:iend)) + IF (.not. ieee_is_finite(subset_area) .or. subset_area <= 0._r8) THEN + CALL CoLM_stop('A CoLM element has no positive finite subset area.') + ENDIF + this%subfrc(istt:iend) = this%subfrc(istt:iend) / subset_area + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE subset_build + + ! -------------------------------- + SUBROUTINE subset_free_mem (this) + + IMPLICIT NONE + type (subset_type) :: this + + IF (allocated(this%substt)) deallocate (this%substt) + IF (allocated(this%subend)) deallocate (this%subend) + IF (allocated(this%subfrc)) deallocate (this%subfrc) + + END SUBROUTINE subset_free_mem + + ! -------------------------------- + SUBROUTINE superset_build (this, superset, subset) + + IMPLICIT NONE + + CLASS(superset_type) :: this + + type (pixelset_type), intent(in) :: superset + type (pixelset_type), intent(in) :: subset + + ! Local Variables + integer :: isuperset, isubset + + IF (subset%nset <= 0) RETURN + + IF (allocated(this%sup)) deallocate(this%sup) + + allocate (this%sup (subset%nset)) + + isuperset = 1 + isubset = 1 + DO WHILE (isubset <= subset%nset) + IF ( (subset%eindex(isubset) == superset%eindex(isuperset)) & + .and. (subset%ipxstt(isubset) >= superset%ipxstt(isuperset)) & + .and. (subset%ipxend(isubset) <= superset%ipxend(isuperset))) THEN + + this%sup(isubset) = isuperset + + isubset = isubset + 1 + ELSE + isuperset = isuperset + 1 + ENDIF + ENDDO + + END SUBROUTINE superset_build + + ! -------------------------------- + SUBROUTINE superset_free_mem (this) + + IMPLICIT NONE + type (superset_type) :: this + + IF (allocated(this%sup)) deallocate (this%sup) + + END SUBROUTINE superset_free_mem + +END MODULE MOD_Pixelset diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Precision.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Precision.F90 new file mode 100644 index 0000000000..d3c259200b --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Precision.F90 @@ -0,0 +1,12 @@ +MODULE MOD_Precision +!------------------------------------------------------------------------------- +! !Purpose: +! Define the precision to use for floating point and integer operations +! throughout the model. +!------------------------------------------------------------------------------- + integer, parameter :: r4 = selected_real_kind(5) + integer, parameter :: r8 = selected_real_kind(12) + integer, parameter :: r16 = selected_real_kind(24) !16 byte REAL + integer, parameter :: i8 = selected_int_kind(13) + +END MODULE MOD_Precision diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 new file mode 100644 index 0000000000..c5fe73c5e7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90 @@ -0,0 +1,2526 @@ +#include + +#ifdef MPAS_EMBEDDED_COLM +#define COLM_SPATIAL_LOCAL_RANK mpas_rank +#else +#define COLM_SPATIAL_LOCAL_RANK 0 +#endif + +MODULE MOD_SpatialMapping + +!-------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! Spatial Mapping module. +! +! Created by Shupeng Zhang, May 2024 +!-------------------------------------------------------------------------------- + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + ! ------ + type :: spatial_mapping_type + + type(grid_type) :: grid + + type(grid_list_type), allocatable :: glist (:) + + integer :: npset + integer, allocatable :: npart(:) + type(pointer_int32_2d), allocatable :: address (:) + + logical :: has_missing_value = .false. + real(r8) :: missing_value = spval + + type(pointer_real8_1d), allocatable :: areapart(:) ! intersection area + real(r8), allocatable :: areapset(:) + type(block_data_real8_2d) :: areagrid + + CONTAINS + + procedure, PUBLIC :: build_arealweighted => spatial_mapping_build_arealweighted + procedure, PUBLIC :: build_bilinear => spatial_mapping_build_bilinear + + procedure, PUBLIC :: set_missing_value => spatial_mapping_set_missing_value + + ! 1) from pixelset to grid + procedure, PRIVATE :: pset2grid_2d => spatial_mapping_pset2grid_2d + procedure, PRIVATE :: pset2grid_3d => spatial_mapping_pset2grid_3d + procedure, PRIVATE :: pset2grid_4d => spatial_mapping_pset2grid_4d + generic, PUBLIC :: pset2grid => pset2grid_2d, pset2grid_3d, pset2grid_4d + + procedure, PUBLIC :: pset2grid_max => spatial_mapping_pset2grid_max + procedure, PUBLIC :: pset2grid_split => spatial_mapping_pset2grid_split + + procedure, PUBLIC :: get_sumarea => spatial_mapping_get_sumarea + + ! 2) from grid to pixelset + procedure, PRIVATE :: grid2pset_2d => spatial_mapping_grid2pset_2d + procedure, PRIVATE :: grid2pset_3d => spatial_mapping_grid2pset_3d + generic, PUBLIC :: grid2pset => grid2pset_2d, grid2pset_3d + + procedure, PUBLIC :: grid2pset_dominant => spatial_mapping_dominant_2d + procedure, PUBLIC :: grid2pset_varvalue => spatial_mapping_varvalue_2d + + ! 3) between grid and intersections + procedure, PUBLIC :: grid2part => spatial_mapping_grid2part + procedure, PUBLIC :: part2grid => spatial_mapping_part2grid + procedure, PUBLIC :: normalize => spatial_mapping_normalize + + ! 4) intersections to pixelset + procedure, PUBLIC :: part2pset => spatial_mapping_part2pset + + procedure, PUBLIC :: allocate_part => spatial_mapping_allocate_part + procedure, PUBLIC :: deallocate_part => spatial_mapping_deallocate_part + procedure, PUBLIC :: forc_free_mem => forc_free_mem_spatial_mapping + + final :: spatial_mapping_free_mem + + END type spatial_mapping_type + +!----------------------- +CONTAINS + + !------------------------------------------ + SUBROUTINE spatial_mapping_build_arealweighted (this, fgrid, pixelset) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_Block + USE MOD_Pixel + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_Mesh + USE MOD_Utils + USE MOD_MPAS_MPI + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(grid_type), intent(in) :: fgrid + type(pixelset_type), intent(in) :: pixelset + + ! Local variables + type(pointer_real8_1d), allocatable :: afrac(:) + type(grid_list_type), allocatable :: gfrom(:) + type(pointer_int32_1d), allocatable :: list_lat(:) + integer, allocatable :: ng_lat(:) + integer, allocatable :: ys(:), yn(:), xw(:), xe(:) + integer, allocatable :: xlist(:), ylist(:) + integer, allocatable :: ipt(:) + logical, allocatable :: msk(:) + + integer :: ie, iset, iblkme + integer :: ng, ig, ng_all, iloc + integer :: npxl, ipxl, ilat, ilon + integer :: irank, iproc, idest, isrc, nrecv + integer :: rmesg(2), smesg(2) + integer :: iy, ix, xblk, yblk, xloc, yloc + integer :: ipxstt, ipxend + real(r8) :: lat_s, lat_n, lon_w, lon_e, area + logical :: skip, is_new + + + + IF (mpas_is_root) THEN + + write(*,"(A, I0, A, I0, A)") & + 'Making areal weighted mapping between pixel set and grid: ', & + fgrid%nlat, ' grids in latitude ', fgrid%nlon, ' grids in longitude.' + +#ifndef SinglePoint + IF (.not. (lon_between_floor(pixel%edgew, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)) & + .and. lon_between_ceil(pixel%edgee, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)))) THEN + write(*,'(A)') 'Warning: Grid does not cover longitude range of modeling region.' + ENDIF + + IF (fgrid%yinc == 1) THEN + IF (.not. ((pixel%edges >= fgrid%lat_s(1)) & + .and. (pixel%edgen <= fgrid%lat_n(fgrid%nlat)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ELSE + IF (.not. ((pixel%edges >= fgrid%lat_s(fgrid%nlat)) & + .and. (pixel%edgen <= fgrid%lat_n(1)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ENDIF +#endif + + ENDIF + + allocate (this%grid%xblk (size(fgrid%xblk))); this%grid%xblk = fgrid%xblk + allocate (this%grid%yblk (size(fgrid%yblk))); this%grid%yblk = fgrid%yblk + allocate (this%grid%xloc (size(fgrid%xloc))); this%grid%xloc = fgrid%xloc + allocate (this%grid%yloc (size(fgrid%yloc))); this%grid%yloc = fgrid%yloc + allocate (this%grid%xcnt (size(fgrid%xcnt))); this%grid%xcnt = fgrid%xcnt + allocate (this%grid%ycnt (size(fgrid%ycnt))); this%grid%ycnt = fgrid%ycnt + +#ifdef SinglePoint + allocate (this%glist (0:0)) + allocate (this%glist(0)%ilat (1)) + allocate (this%glist(0)%ilon (1)) + + allocate (this%npart (pixelset%nset)) + allocate (this%address (pixelset%nset)) + allocate (this%areapset(pixelset%nset)) + allocate (this%areapart(pixelset%nset)) + DO iset = 1, pixelset%nset + allocate (this%address(iset)%val (2,1)) + allocate (this%areapart(iset)%val (1)) + ENDDO + + this%glist(0)%ng = 1 + this%glist(0)%ilat(1) = find_nearest_south (SITE_lat_location, fgrid%nlat, fgrid%lat_s) + this%glist(0)%ilon(1) = find_nearest_west (SITE_lon_location, fgrid%nlon, fgrid%lon_w) + + this%npset = pixelset%nset + this%npart (:) = 1 + this%areapset(:) = 1. + + DO iset = 1, pixelset%nset + this%address(iset)%val = reshape((/0,1/), (/2,1/)) + this%areapart(iset)%val = 1. + ENDDO + + CALL allocate_block_data (fgrid, this%areagrid) + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + this%areagrid%blk(xblk,yblk)%val = 1. + ENDDO + + RETURN +#endif + + + IF (.true.) THEN + + this%npset = pixelset%nset + + allocate (afrac (pixelset%nset)) + allocate (gfrom (pixelset%nset)) + + allocate (ys (pixel%nlat)) + allocate (yn (pixel%nlat)) + allocate (xw (pixel%nlon)) + allocate (xe (pixel%nlon)) + + DO ilat = 1, pixel%nlat + ys(ilat) = find_nearest_south (pixel%lat_s(ilat), fgrid%nlat, fgrid%lat_s) + yn(ilat) = find_nearest_north (pixel%lat_n(ilat), fgrid%nlat, fgrid%lat_n) + ENDDO + + DO ilon = 1, pixel%nlon + xw(ilon) = find_nearest_west (pixel%lon_w(ilon), fgrid%nlon, fgrid%lon_w) + xe(ilon) = find_nearest_east (pixel%lon_e(ilon), fgrid%nlon, fgrid%lon_e) + ENDDO + + allocate (list_lat (fgrid%nlat)) + DO iy = 1, fgrid%nlat + allocate (list_lat(iy)%val (100)) + ENDDO + + allocate (ng_lat (fgrid%nlat)); ng_lat(:) = 0 + + DO iset = 1, pixelset%nset + + ie = pixelset%ielm(iset) + npxl = pixelset%ipxend(iset) - pixelset%ipxstt(iset) + 1 + + ipxstt = pixelset%ipxstt(iset) + ipxend = pixelset%ipxend(iset) + + ! deal with 2m WMO patch + IF (ipxstt==-1 .and. ipxend==-1) THEN + ipxstt = 1 + ipxend = mesh(ie)%npxl + npxl = mesh(ie)%npxl + ENDIF + + allocate (afrac(iset)%val (npxl)) + allocate (gfrom(iset)%ilat(npxl)) + allocate (gfrom(iset)%ilon(npxl)) + + gfrom(iset)%ng = 0 + + DO ipxl = ipxstt, ipxend + + ilat = mesh(ie)%ilat(ipxl) + ilon = mesh(ie)%ilon(ipxl) + + DO iy = ys(ilat), yn(ilat), fgrid%yinc + + lat_s = max(fgrid%lat_s(iy), pixel%lat_s(ilat)) + lat_n = min(fgrid%lat_n(iy), pixel%lat_n(ilat)) + + IF ((lat_n-lat_s) < 1.0e-6_r8) THEN + CYCLE + ENDIF + + ix = xw(ilon) + DO WHILE (.true.) + + IF (ix == xw(ilon)) THEN + lon_w = pixel%lon_w(ilon) + ELSE + lon_w = fgrid%lon_w(ix) + ENDIF + + IF (ix == xe(ilon)) THEN + lon_e = pixel%lon_e(ilon) + ELSE + lon_e = fgrid%lon_e(ix) + ENDIF + + skip = .false. + IF (.not. (lon_between_floor (lon_w, pixel%lon_w(ilon), lon_e) & + .and. lon_between_ceil (lon_e, lon_w, pixel%lon_e(ilon)))) THEN + skip = .true. + ELSE + IF (lon_e > lon_w) THEN + IF ((lon_e-lon_w) < 1.0e-6_r8) THEN + skip = .true. + ENDIF + ELSE + IF ((lon_e+360.0_r8-lon_w) < 1.0e-6_r8) THEN + skip = .true. + ENDIF + ENDIF + ENDIF + + IF (.not. skip) THEN + + area = areaquad (lat_s, lat_n, lon_w, lon_e) + + IF (gfrom(iset)%ng == size(gfrom(iset)%ilat)) THEN + CALL expand_list (gfrom(iset)%ilat, 0.2_r8) + CALL expand_list (gfrom(iset)%ilon, 0.2_r8) + CALL expand_list (afrac(iset)%val, 0.2_r8) + ENDIF + + CALL insert_into_sorted_list2 ( ix, iy, & + gfrom(iset)%ng, gfrom(iset)%ilon, gfrom(iset)%ilat, & + iloc, is_new) + + IF (is_new) THEN + IF (iloc < gfrom(iset)%ng) THEN + afrac(iset)%val(iloc+1:gfrom(iset)%ng) & + = afrac(iset)%val(iloc:gfrom(iset)%ng-1) + ENDIF + + afrac(iset)%val(iloc) = area + ELSE + afrac(iset)%val(iloc) = afrac(iset)%val(iloc) + area + ENDIF + + IF (ng_lat(iy) == size(list_lat(iy)%val)) THEN + CALL expand_list (list_lat(iy)%val, 0.2_r8) + ENDIF + CALL insert_into_sorted_list1 ( & + ix, ng_lat(iy), list_lat(iy)%val, iloc) + + ENDIF + + IF (ix == xe(ilon)) EXIT + ix = mod(ix,fgrid%nlon) + 1 + ENDDO + ENDDO + + ENDDO + ENDDO + + deallocate (ys) + deallocate (yn) + deallocate (xw) + deallocate (xe) + + ng_all = sum(ng_lat) + allocate (xlist(ng_all)) + allocate (ylist(ng_all)) + + ig = 0 + DO iy = 1, fgrid%nlat + DO ix = 1, ng_lat(iy) + ig = ig + 1 + xlist(ig) = list_lat(iy)%val(ix) + ylist(ig) = iy + ENDDO + ENDDO + + deallocate (ng_lat) + DO iy = 1, fgrid%nlat + deallocate (list_lat(iy)%val) + ENDDO + deallocate (list_lat) + + + allocate (this%glist (0:mpas_size-1)) + DO iproc = 0, mpas_size-1 + ng = 0 + IF (iproc == COLM_SPATIAL_LOCAL_RANK) ng = ng_all + + this%glist(iproc)%ng = ng + + IF (ng > 0) THEN + allocate (this%glist(iproc)%ilat (ng)) + allocate (this%glist(iproc)%ilon (ng)) + + this%glist(iproc)%ilon = xlist + this%glist(iproc)%ilat = ylist + ENDIF + ENDDO + + + allocate (this%address (pixelset%nset)) + allocate (this%areapart (pixelset%nset)) + + allocate (this%npart (pixelset%nset)) + + DO iset = 1, pixelset%nset + + ng = gfrom(iset)%ng + + this%npart(iset) = ng + + allocate (this%address(iset)%val (2,ng)) + allocate (this%areapart(iset)%val (ng)) + + this%areapart(iset)%val = afrac(iset)%val(1:ng) + + IF (pixelset%has_shared) THEN + this%areapart(iset)%val = this%areapart(iset)%val * pixelset%pctshared(iset) + ENDIF + + DO ig = 1, gfrom(iset)%ng + ilon = gfrom(iset)%ilon(ig) + ilat = gfrom(iset)%ilat(ig) + xblk = fgrid%xblk(ilon) + yblk = fgrid%yblk(ilat) + + iproc = COLM_SPATIAL_LOCAL_RANK + + this%address(iset)%val(1,ig) = iproc + this%address(iset)%val(2,ig) = find_in_sorted_list2 ( & + ilon, ilat, this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + ENDDO + ENDDO + + deallocate (xlist) + deallocate (ylist) + + DO iset = 1, pixelset%nset + deallocate (afrac(iset)%val ) + deallocate (gfrom(iset)%ilon) + deallocate (gfrom(iset)%ilat) + ENDDO + + deallocate (afrac) + deallocate (gfrom) + + ENDIF + + + IF (.true.) THEN + IF (this%npset > 0) THEN + allocate (this%areapset (this%npset)) + this%areapset(:) = 0. + ENDIF + DO iset = 1, this%npset + IF (this%npart(iset) > 0) THEN + this%areapset(iset) = sum(this%areapart(iset)%val) + ENDIF + ENDDO + ENDIF + +#ifndef MPAS_EMBEDDED_COLM + IF (.true.) CALL allocate_block_data (fgrid, this%areagrid) + IF (.true.) THEN + IF (this%npset > 0) THEN + allocate (msk (this%npset)) + msk = pixelset%ipxstt > 0 .and. pixelset%ipxend > 0 + ENDIF + ENDIF + CALL this%get_sumarea (this%areagrid, msk) + + IF (allocated(msk)) deallocate(msk) +#endif + + + + END SUBROUTINE spatial_mapping_build_arealweighted + + !------------------------------------------ + SUBROUTINE spatial_mapping_build_bilinear (this, fgrid, pixelset) + + USE MOD_Precision + USE MOD_Namelist + USE MOD_Block + USE MOD_Pixel + USE MOD_Grid + USE MOD_DataType + USE MOD_Mesh + USE MOD_Pixelset + USE MOD_Utils + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: pi + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(grid_type), intent(in) :: fgrid + type(pixelset_type), intent(in) :: pixelset + + ! Local variables + integer, allocatable :: ys(:), yn(:), xw(:), xe(:) + integer, allocatable :: xlist(:), ylist(:), ipt(:) + + real(r8), allocatable :: rlon_pset(:), rlat_pset(:) + real(r8), allocatable :: nwgt(:), swgt(:), wwgt(:), ewgt(:) + + logical, allocatable :: msk(:) + + integer :: iset, ilat, ilon, iwest, ieast, ie, ipxl + integer :: nglist, iloc, ng, ig + integer :: irank, iproc, iio, idest, isrc, nrecv + integer :: rmesg(2), smesg(2) + integer :: iy, ix, xblk, yblk, xloc, yloc + integer :: ipxstt, ipxend + + real(r8) :: lon, lonw, lone, latn, lats + real(r8) :: distn, dists, distw, diste, diffw, diffe, areathis + + + IF (mpas_is_root) THEN + + write(*,*) + write(*,"(A, I0, A, I0, A)") & + 'Building bilinear interpolation from grid to pixel set: ', & + fgrid%nlat, ' grids in latitude ', fgrid%nlon, ' grids in longitude.' + write(*,*) + + IF (.not. (lon_between_floor(pixel%edgew, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)) & + .and. lon_between_ceil(pixel%edgee, fgrid%lon_w(1), fgrid%lon_e(fgrid%nlon)))) THEN + write(*,'(A)') 'Warning: Grid does not cover longitude range of modeling region.' + ENDIF + + IF (fgrid%yinc == 1) THEN + IF (.not. ((pixel%edges >= fgrid%lat_s(1)) & + .and. (pixel%edgen <= fgrid%lat_n(fgrid%nlat)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ELSE + IF (.not. ((pixel%edges >= fgrid%lat_s(fgrid%nlat)) & + .and. (pixel%edgen <= fgrid%lat_n(1)))) THEN + write(*,'(A)') 'Warning: Grid does not cover latitude range of modeling region.' + ENDIF + ENDIF + + ENDIF + + this%grid%nlat = fgrid%nlat + this%grid%nlon = fgrid%nlon + + allocate (this%grid%xblk (size(fgrid%xblk))); this%grid%xblk = fgrid%xblk + allocate (this%grid%yblk (size(fgrid%yblk))); this%grid%yblk = fgrid%yblk + allocate (this%grid%xloc (size(fgrid%xloc))); this%grid%xloc = fgrid%xloc + allocate (this%grid%yloc (size(fgrid%yloc))); this%grid%yloc = fgrid%yloc + allocate (this%grid%xcnt (size(fgrid%xcnt))); this%grid%xcnt = fgrid%xcnt + allocate (this%grid%ycnt (size(fgrid%ycnt))); this%grid%ycnt = fgrid%ycnt + + IF (.true.) THEN + + allocate (this%grid%lat_s(this%grid%nlat)); this%grid%lat_s = fgrid%lat_s + allocate (this%grid%lat_n(this%grid%nlat)); this%grid%lat_n = fgrid%lat_n + allocate (this%grid%lon_w(this%grid%nlon)); this%grid%lon_w = fgrid%lon_w + allocate (this%grid%lon_e(this%grid%nlon)); this%grid%lon_e = fgrid%lon_e + allocate (this%grid%rlon (this%grid%nlon)); CALL this%grid%set_rlon () + allocate (this%grid%rlat (this%grid%nlat)); CALL this%grid%set_rlat () + + this%npset = pixelset%nset + + allocate (yn (this%npset)) + allocate (ys (this%npset)) + allocate (xw (this%npset)) + allocate (xe (this%npset)) + allocate (rlon_pset (this%npset)) + allocate (rlat_pset (this%npset)) + + CALL pixelset%get_lonlat_radian (rlon_pset, rlat_pset) + + allocate (xlist(4*this%npset)) + allocate (ylist(4*this%npset)) + + allocate (nwgt (this%npset)) + allocate (swgt (this%npset)) + allocate (wwgt (this%npset)) + allocate (ewgt (this%npset)) + + nglist = 0 + + DO iset = 1, this%npset + + IF (this%grid%rlat(1) > this%grid%rlat(this%grid%nlat)) THEN + ! from north to south + ilat = 1 + DO WHILE ((rlat_pset(iset) < this%grid%rlat(ilat)) .and. (ilat < this%grid%nlat)) + ilat = ilat + 1 + ENDDO + + IF (rlat_pset(iset) >= this%grid%rlat(ilat)) THEN + yn(iset) = max(ilat-1,1) + ys(iset) = ilat + ELSE + yn(iset) = this%grid%nlat + ys(iset) = this%grid%nlat + ENDIF + ELSE + ! from south to north + ilat = this%grid%nlat + DO WHILE ((rlat_pset(iset) < this%grid%rlat(ilat)) .and. (ilat > 1)) + ilat = ilat - 1 + ENDDO + + IF (rlat_pset(iset) >= this%grid%rlat(ilat)) THEN + yn(iset) = min(ilat+1,this%grid%nlat) + ys(iset) = ilat + ELSE + yn(iset) = 1 + ys(iset) = 1 + ENDIF + ENDIF + + IF (yn(iset) /= ys(iset)) THEN + latn = this%grid%rlat(yn(iset)) + lats = this%grid%rlat(ys(iset)) + distn = arclen(rlat_pset(iset), rlon_pset(iset), latn, rlon_pset(iset)) + dists = arclen(rlat_pset(iset), rlon_pset(iset), lats, rlon_pset(iset)) + nwgt(iset) = dists/(dists+distn) + swgt(iset) = distn/(dists+distn) + ELSE + nwgt(iset) = 1.0 + swgt(iset) = 0.0 + ENDIF + + + lon = rlon_pset(iset)*180.0/pi + CALL normalize_longitude (lon) + + DO iwest = 1, this%grid%nlon + lonw = this%grid%rlon(iwest) *180.0/pi + CALL normalize_longitude (lonw) + + ieast = mod(iwest,this%grid%nlon) + 1 + lone = this%grid%rlon(ieast)*180.0/pi + CALL normalize_longitude (lone) + + IF (lon_between_floor(lon, lonw, lone)) EXIT + ENDDO + + xw(iset) = iwest + xe(iset) = ieast + + ! for the case grid does not cover [-180,180) + IF ((iwest == this%grid%nlon) .and. (this%grid%nlon > 1)) THEN + IF (lon_between_floor( & + this%grid%lon_e(this%grid%nlon), lonw, this%grid%lon_w(1))) THEN + + diffw = lon - lonw; IF (diffw < 0) diffw = diffw + 360.0 + diffe = lone - lon; IF (diffe < 0) diffe = diffe + 360.0 + + IF (diffw > diffe) THEN + xw(iset) = ieast + xe(iset) = ieast + ELSE + xw(iset) = iwest + xe(iset) = iwest + ENDIF + + ENDIF + ENDIF + + IF (xw(iset) /= xe(iset)) THEN + lonw = this%grid%rlon(xw(iset)) + lone = this%grid%rlon(xe(iset)) + distw = arclen(rlat_pset(iset), rlon_pset(iset), rlat_pset(iset), lonw) + diste = arclen(rlat_pset(iset), rlon_pset(iset), rlat_pset(iset), lone) + wwgt(iset) = diste/(distw+diste) + ewgt(iset) = distw/(distw+diste) + ELSE + wwgt(iset) = 1.0 + ewgt(iset) = 0.0 + ENDIF + + CALL insert_into_sorted_list2 ( xw(iset), yn(iset), nglist, xlist, ylist, iloc) + CALL insert_into_sorted_list2 ( xe(iset), yn(iset), nglist, xlist, ylist, iloc) + CALL insert_into_sorted_list2 ( xw(iset), ys(iset), nglist, xlist, ylist, iloc) + CALL insert_into_sorted_list2 ( xe(iset), ys(iset), nglist, xlist, ylist, iloc) + + ENDDO + + + allocate (this%glist (0:mpas_size-1)) + DO iproc = 0, mpas_size-1 + ng = 0 + IF (iproc == COLM_SPATIAL_LOCAL_RANK) ng = nglist + + this%glist(iproc)%ng = ng + + IF (ng > 0) THEN + allocate (this%glist(iproc)%ilat (ng)) + allocate (this%glist(iproc)%ilon (ng)) + + this%glist(iproc)%ilon = xlist(1:nglist) + this%glist(iproc)%ilat = ylist(1:nglist) + ENDIF + + ENDDO + + deallocate (xlist) + deallocate (ylist) + + ENDIF + + + IF (.true.) THEN + + allocate (this%address (this%npset)) + allocate (this%npart (this%npset)) + allocate (this%areapart(this%npset)) + + DO iset = 1, pixelset%nset + + this%npart(iset) = 4 + + allocate (this%address (iset)%val(2,4)) + allocate (this%areapart(iset)%val(4)) + + areathis = 0. + + ie = pixelset%ielm(iset) + + ipxstt = pixelset%ipxstt(iset) + ipxend = pixelset%ipxend(iset) + + ! deal with 2m WMO patch + IF (ipxstt==-1 .and. ipxend==-1) THEN + ipxstt = 1 + ipxend = mesh(ie)%npxl + ENDIF + + DO ipxl = ipxstt, ipxend + areathis = areathis + areaquad (& + pixel%lat_s(mesh(ie)%ilat(ipxl)), pixel%lat_n(mesh(ie)%ilat(ipxl)), & + pixel%lon_w(mesh(ie)%ilon(ipxl)), pixel%lon_e(mesh(ie)%ilon(ipxl)) ) + ENDDO + + IF (pixelset%has_shared) THEN + areathis = areathis * pixelset%pctshared(iset) + ENDIF + + ! northwest grid + ix = xw(iset); iy = yn(iset); + iproc = COLM_SPATIAL_LOCAL_RANK + this%address(iset)%val(1,1) = iproc + this%address(iset)%val(2,1) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(1) = areathis * nwgt(iset) * wwgt(iset) + + ! northeast grid + ix = xe(iset); iy = yn(iset); + iproc = COLM_SPATIAL_LOCAL_RANK + this%address(iset)%val(1,2) = iproc + this%address(iset)%val(2,2) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(2) = areathis * nwgt(iset) * ewgt(iset) + + ! southwest + ix = xw(iset); iy = ys(iset); + iproc = COLM_SPATIAL_LOCAL_RANK + this%address(iset)%val(1,3) = iproc + this%address(iset)%val(2,3) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(3) = areathis * swgt(iset) * wwgt(iset) + + ! southeast + ix = xe(iset); iy = ys(iset); + iproc = COLM_SPATIAL_LOCAL_RANK + this%address(iset)%val(1,4) = iproc + this%address(iset)%val(2,4) = find_in_sorted_list2 ( ix, iy, & + this%glist(iproc)%ng, this%glist(iproc)%ilon, this%glist(iproc)%ilat) + + this%areapart(iset)%val(4) = areathis * swgt(iset) * ewgt(iset) + + ENDDO + + ENDIF + + IF (.true.) THEN + IF (this%npset > 0) THEN + allocate (this%areapset (this%npset)) + ENDIF + DO iset = 1, this%npset + this%areapset(iset) = sum(this%areapart(iset)%val) + ENDDO + ENDIF + +#ifndef MPAS_EMBEDDED_COLM + IF (.true.) CALL allocate_block_data (fgrid, this%areagrid) + IF (.true.) THEN + IF (this%npset > 0) THEN + allocate (msk (this%npset)) + msk = pixelset%ipxstt > 0 .and. pixelset%ipxend > 0 + ENDIF + ENDIF + CALL this%get_sumarea (this%areagrid, msk) +#endif + + + IF (allocated(this%grid%lat_s)) deallocate(this%grid%lat_s) + IF (allocated(this%grid%lat_n)) deallocate(this%grid%lat_n) + IF (allocated(this%grid%lon_w)) deallocate(this%grid%lon_w) + IF (allocated(this%grid%lon_e)) deallocate(this%grid%lon_e) + IF (allocated(this%grid%rlon )) deallocate(this%grid%rlon ) + IF (allocated(this%grid%rlat )) deallocate(this%grid%rlat ) + + IF (allocated(yn)) deallocate(yn) + IF (allocated(ys)) deallocate(ys) + IF (allocated(xw)) deallocate(xw) + IF (allocated(xe)) deallocate(xe) + + IF (allocated(rlon_pset)) deallocate(rlon_pset) + IF (allocated(rlat_pset)) deallocate(rlat_pset) + + IF (allocated(nwgt)) deallocate(nwgt) + IF (allocated(swgt)) deallocate(swgt) + IF (allocated(wwgt)) deallocate(wwgt) + IF (allocated(ewgt)) deallocate(ewgt) + + IF (allocated(msk)) deallocate(msk) + + + END SUBROUTINE spatial_mapping_build_bilinear + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_set_missing_value (this, gdata, missing_value, pmask) + + USE MOD_Precision + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + real(r8), intent(in) :: missing_value + + logical, intent(inout), optional :: pmask(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart, iblkme + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + this%has_missing_value = .true. + this%missing_value = missing_value + + IF (.true.) THEN + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + + ENDIF + ENDDO + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + WHERE (gdata%blk(xblk,yblk)%val == missing_value) + this%areagrid%blk(xblk,yblk)%val = 0. + ENDWHERE + ENDDO + + ENDIF + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff + deallocate (gbuff) + ENDIF + ENDDO + + + DO iset = 1, this%npset + + this%areapset(iset) = 0. + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (pbuff(iproc)%val(iloc) == missing_value) THEN + this%areapart(iset)%val(ipart) = 0. + ELSE + this%areapset(iset) = this%areapset(iset) + this%areapart(iset)%val(ipart) + ENDIF + ENDDO + + IF (present(pmask)) THEN + pmask(iset) = (this%areapset(iset) > 0.) + ENDIF + + ENDDO + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_set_missing_value + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_2d (this, pdata, gdata, spv, msk, input_mode) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:) + type(block_data_real8_2d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + character(len=*), intent(in), optional :: input_mode + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + character(len=256) :: inmode + real(r8) :: sumwt + + IF (.true.) THEN + + inmode = 'average' + IF (present(input_mode)) inmode = trim(input_mode) + + allocate (pbuff (0:mpas_size-1)) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + + IF (present(spv)) THEN + pbuff(iproc)%val(:) = spv + ELSE + pbuff(iproc)%val(:) = 0.0 + ENDIF + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (present(spv)) THEN + IF (pdata(iset) == spv) CYCLE + ENDIF + + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + IF ((this%npart(iset) > 0) .and. (trim(inmode) == 'total')) THEN + sumwt = sum(this%areapart(iset)%val) + ELSE + sumwt = 1. + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (present(spv)) THEN + IF (pbuff(iproc)%val(iloc) /= spv) THEN + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + pdata(iset)/sumwt * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(iloc) = & + pdata(iset)/sumwt * this%areapart(iset)%val(ipart) + ENDIF + ELSE + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + pdata(iset)/sumwt * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDDO + + + ENDIF + + IF (.true.) THEN + + IF (present(spv)) THEN + CALL flush_block_data (gdata, spv) + ELSE + CALL flush_block_data (gdata, 0.0_r8) + ENDIF + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val + + DO ig = 1, this%glist(iproc)%ng + IF (present(spv)) THEN + IF (gbuff(ig) /= spv) THEN + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + IF (gdata%blk(xblk,yblk)%val(xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ELSE + gdata%blk(xblk,yblk)%val(xloc,yloc) = gbuff(ig) + ENDIF + ENDIF + ELSE + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ENDIF + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + ENDIF + + IF (.true.) THEN + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + + END SUBROUTINE spatial_mapping_pset2grid_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_3d (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:,:) + type(block_data_real8_3d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, iloc, iset, ipart + integer :: xblk, yblk, xloc, yloc + integer :: lb1, ub1, i1 + + real(r8), allocatable :: gbuff(:,:) + type(pointer_real8_2d), allocatable :: pbuff(:) + + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + lb1 = lbound(pdata,1) + ub1 = ubound(pdata,1) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (lb1:ub1, this%glist(iproc)%ng)) + + IF (present(spv)) THEN + pbuff(iproc)%val(:,:) = spv + ELSE + pbuff(iproc)%val(:,:) = 0.0 + ENDIF + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + DO i1 = lb1, ub1 + IF (present(spv)) THEN + IF (pdata(i1,iset) /= spv) THEN + IF (pbuff(iproc)%val(i1,iloc) /= spv) THEN + pbuff(iproc)%val(i1,iloc) = pbuff(iproc)%val(i1,iloc) & + + pdata(i1,iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(i1,iloc) = & + pdata(i1,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDIF + ELSE + pbuff(iproc)%val(i1,iloc) = pbuff(iproc)%val(i1,iloc) & + + pdata(i1,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDDO + ENDDO + + + ENDIF + + IF (.true.) THEN + + lb1 = gdata%lb1 + ub1 = gdata%ub1 + + IF (present(spv)) THEN + CALL flush_block_data (gdata, spv) + ELSE + CALL flush_block_data (gdata, 0.0_r8) + ENDIF + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (lb1:ub1, this%glist(iproc)%ng)) + + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + DO i1 = lb1, ub1 + IF (present(spv)) THEN + IF (gbuff(i1,ig) /= spv) THEN + IF (gdata%blk(xblk,yblk)%val(i1,xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) + gbuff(i1,ig) + ELSE + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = gbuff(i1,ig) + ENDIF + ENDIF + ELSE + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,xloc,yloc) + gbuff(i1,ig) + ENDIF + ENDDO + ENDDO + + deallocate (gbuff) + ENDIF + + ENDDO + + ENDIF + + IF (.true.) THEN + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_3d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_4d (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:,:,:) + type(block_data_real8_4d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, iloc, iset, ipart + integer :: xblk, yblk, xloc, yloc + integer :: lb1, ub1, i1, ndim1, lb2, ub2, i2, ndim2 + + real(r8), allocatable :: gbuff(:,:,:) + type(pointer_real8_3d), allocatable :: pbuff(:) + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + lb1 = lbound(pdata,1) + ub1 = ubound(pdata,1) + ndim1 = ub1 - lb1 + 1 + + lb2 = lbound(pdata,2) + ub2 = ubound(pdata,2) + ndim2 = ub2 - lb2 + 1 + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) + + IF (present(spv)) THEN + pbuff(iproc)%val(:,:,:) = spv + ELSE + pbuff(iproc)%val(:,:,:) = 0.0 + ENDIF + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + DO i1 = lb1, ub1 + DO i2 = lb2, ub2 + IF (present(spv)) THEN + IF (pdata(i1,i2,iset) /= spv) THEN + IF (pbuff(iproc)%val(i1,i2,iloc) /= spv) THEN + pbuff(iproc)%val(i1,i2,iloc) = pbuff(iproc)%val(i1,i2,iloc) & + + pdata(i1,i2,iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(i1,i2,iloc) = & + pdata(i1,i2,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDIF + ELSE + pbuff(iproc)%val(i1,i2,iloc) = pbuff(iproc)%val(i1,i2,iloc) & + + pdata(i1,i2,iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + + + ENDIF + + IF (.true.) THEN + + lb1 = gdata%lb1 + ub1 = gdata%ub1 + ndim1 = ub1 - lb1 + 1 + + lb2 = gdata%lb2 + ub2 = gdata%ub2 + ndim2 = ub2 - lb2 + 1 + + IF (present(spv)) THEN + CALL flush_block_data (gdata, spv) + ELSE + CALL flush_block_data (gdata, 0.0_r8) + ENDIF + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (lb1:ub1, lb2:ub2, this%glist(iproc)%ng)) + + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + DO i1 = lb1, ub1 + DO i2 = lb2, ub2 + IF (present(spv)) THEN + IF (gbuff(i1,i2,ig) /= spv) THEN + IF (gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) + gbuff(i1,i2,ig) + ELSE + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = gbuff(i1,i2,ig) + ENDIF + ENDIF + ELSE + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(i1,i2,xloc,yloc) + gbuff(i1,i2,ig) + ENDIF + ENDDO + ENDDO + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + ENDIF + + IF (.true.) THEN + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_4d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_max (this, pdata, gdata, spv, msk) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata(:) + type(block_data_real8_2d), intent(inout) :: gdata + + real(r8), intent(in), optional :: spv + logical, intent(in), optional :: msk(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + pbuff(iproc)%val(:) = spval + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (present(spv)) THEN + IF (pdata(iset) == spv) CYCLE + ENDIF + + IF (present(msk)) THEN + IF (.not. msk(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (pbuff(iproc)%val(iloc) /= spval) THEN + pbuff(iproc)%val(iloc) = max(pdata(iset), pbuff(iproc)%val(iloc)) + ELSE + pbuff(iproc)%val(iloc) = pdata(iset) + ENDIF + ENDDO + ENDDO + + + ENDIF + + IF (.true.) THEN + + CALL flush_block_data (gdata, spval) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val + + DO ig = 1, this%glist(iproc)%ng + IF (gbuff(ig) /= spval) THEN + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + IF (gdata%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + max(gdata%blk(xblk,yblk)%val(xloc,yloc), gbuff(ig)) + ELSE + gdata%blk(xblk,yblk)%val(xloc,yloc) = gbuff(ig) + ENDIF + ENDIF + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + ENDIF + + IF (.true.) THEN + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_max + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_pset2grid_split (this, pdata, settyp, typidx, gdata, spv) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + real(r8), intent(in) :: pdata (:) + integer , intent(in) :: settyp(:) + integer , intent(in) :: typidx(:) + type(block_data_real8_3d), intent(inout) :: gdata + + real(r8), intent(in) :: spv + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, iloc, iset, ipart, ityp, ntyps + integer :: xblk, yblk, xloc, yloc + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff (:) + + IF (.true.) THEN + allocate (pbuff (0:mpas_size-1)) + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + ENDIF + ENDDO + ENDIF + + IF (.true.) THEN + CALL flush_block_data (gdata, spv) + ENDIF + + ntyps = size(typidx) + + DO ityp = 1, ntyps + + IF (.true.) THEN + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + pbuff(iproc)%val(:) = spv + ENDIF + ENDDO + + DO iset = 1, this%npset + IF ((settyp(iset) == typidx(ityp)) .and. (pdata(iset) /= spv)) THEN + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (pbuff(iproc)%val(iloc) /= spv) THEN + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + pdata(iset) * this%areapart(iset)%val(ipart) + ELSE + pbuff(iproc)%val(iloc) = & + pdata(iset) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + ENDIF + ENDDO + + + ENDIF + + IF (.true.) THEN + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val + + DO ig = 1, this%glist(iproc)%ng + IF (gbuff(ig) /= spv) THEN + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + IF (gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) /= spv) THEN + gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) = & + gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) + gbuff(ig) + ELSE + gdata%blk(xblk,yblk)%val(ityp,xloc,yloc) = gbuff(ig) + ENDIF + ENDIF + ENDDO + + deallocate (gbuff) + ENDIF + + ENDDO + + ENDIF + + ENDDO + + IF (.true.) THEN + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_pset2grid_split + + ! ------------------------------ + SUBROUTINE spatial_mapping_get_sumarea (this, sumarea, filter) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(inout) :: sumarea + logical, intent(in), optional :: filter(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + +#ifdef MPAS_EMBEDDED_COLM + IF (.true.) CALL flush_block_data (sumarea, 0.0_r8) + + IF (.true.) THEN + DO iset = 1, this%npset + + IF (present(filter)) THEN + IF (.not. filter(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + IF (iproc /= mpas_rank) CYCLE + + iloc = this%address(iset)%val(2,ipart) + ilon = this%glist(iproc)%ilon(iloc) + ilat = this%glist(iproc)%ilat(iloc) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + sumarea%blk(xblk,yblk)%val(xloc,yloc) = & + sumarea%blk(xblk,yblk)%val(xloc,yloc) + this%areapart(iset)%val(ipart) + ENDDO + ENDDO + ENDIF + + RETURN +#endif + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + pbuff(iproc)%val(:) = 0.0 + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (present(filter)) THEN + IF (.not. filter(iset)) CYCLE + ENDIF + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) + this%areapart(iset)%val(ipart) + ENDDO + ENDDO + + + ENDIF + + IF (.true.) THEN + + CALL flush_block_data (sumarea, 0.0_r8) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + sumarea%blk(xblk,yblk)%val(xloc,yloc) = & + sumarea%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + ENDIF + + IF (.true.) THEN + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_get_sumarea + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_grid2pset_2d (this, gdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + real(r8), intent(out) :: pdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (.true.) THEN + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + + ENDIF + ENDDO + + ENDIF + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff + deallocate (gbuff) + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (this%areapset(iset) > 0.) THEN + + pdata(iset) = 0. + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (this%areapart(iset)%val(ipart) > 0) THEN + pdata(iset) = pdata(iset) & + + pbuff(iproc)%val(iloc) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + + pdata(iset) = pdata(iset) / this%areapset(iset) + + ELSE + pdata(iset) = spval + ENDIF + + ENDDO + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_grid2pset_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_grid2pset_3d (this, gdata, ndim1, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_3d), intent(in) :: gdata + integer, intent(in) :: ndim1 + real(r8), intent(out) :: pdata(:,:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart, i + + real(r8), allocatable :: gbuff(:,:) + type(pointer_real8_2d), allocatable :: pbuff(:) + + + IF (.true.) THEN + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (ndim1, this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(:,ig) = gdata%blk(xblk,yblk)%val(:,xloc,yloc) + ENDDO + + ENDIF + ENDDO + + ENDIF + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (ndim1, this%glist(iproc)%ng)) + + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff + deallocate (gbuff) + ENDIF + ENDDO + + + DO iset = 1, this%npset + + IF (this%areapset(iset) > 0.) THEN + + pdata(:,iset) = 0. + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + IF (this%areapart(iset)%val(ipart) > 0) THEN + pdata(:,iset) = pdata(:,iset) & + + pbuff(iproc)%val(:,iloc) * this%areapart(iset)%val(ipart) + ENDIF + ENDDO + + pdata(:,iset) = pdata(:,iset) / this%areapset(iset) + + ELSE + pdata(:,iset) = spval + ENDIF + + ENDDO + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_grid2pset_3d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_dominant_2d (this, gdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_int32_2d), intent(in) :: gdata + integer, intent(out) :: pdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + integer, allocatable :: gbuff(:) + type(pointer_int32_1d), allocatable :: pbuff(:) + + IF (.true.) THEN + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + + ENDIF + ENDDO + + ENDIF + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff + deallocate (gbuff) + ENDIF + ENDDO + + DO iset = 1, this%npset + IF (this%areapset(iset) > 0.) THEN + ipart = maxloc(this%areapart(iset)%val, dim=1) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + pdata(iset) = pbuff(iproc)%val(iloc) + ELSE + pdata(iset) = -9999 + ENDIF + ENDDO + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_dominant_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_varvalue_2d (this, gdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + real(r8), intent(inout) :: pdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + real(r8), allocatable :: pdata_tem(:) + + IF (.true.) THEN + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + + ENDIF + ENDDO + + ENDIF + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + allocate (pdata_tem (size(pdata))) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff + deallocate (gbuff) + ENDIF + ENDDO + + DO iset = 1, this%npset + + IF (this%areapset(iset) > 0.) THEN + + pdata_tem(iset) = 0._r8 + + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + pdata_tem(iset) = pdata_tem(iset) & + + pdata(iset) * pbuff(iproc)%val(iloc) * this%areapart(iset)%val(ipart) + ENDDO + + pdata_tem(iset) = pdata_tem(iset) / this%areapset(iset) + + ELSE + pdata_tem(iset) = 0._r8 + ENDIF + + ENDDO + + pdata = pdata_tem + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + deallocate (pdata_tem) + + ENDIF + + END SUBROUTINE spatial_mapping_varvalue_2d + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_grid2part (this, gdata, sdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + type(pointer_real8_1d), intent(inout) :: sdata(:) + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (.true.) THEN + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gbuff(ig) = gdata%blk(xblk,yblk)%val(xloc,yloc) + + ENDDO + + ENDIF + ENDDO + + ENDIF + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + + pbuff(COLM_SPATIAL_LOCAL_RANK)%val = gbuff + deallocate (gbuff) + ENDIF + ENDDO + + DO iset = 1, this%npset + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + sdata(iset)%val(ipart) = pbuff(iproc)%val(iloc) + ENDDO + ENDDO + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + + ENDIF + + END SUBROUTINE spatial_mapping_grid2part + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_part2grid (this, sdata, gdata) + + USE MOD_Precision + USE MOD_Block + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), intent(in) :: sdata(:) + type(block_data_real8_2d), intent(inout) :: gdata + + ! Local variables + integer :: iproc, idest, isrc + integer :: ig, ilon, ilat, xblk, yblk, xloc, yloc, iloc, iset, ipart + integer :: iblkme + + real(r8), allocatable :: gbuff(:) + type(pointer_real8_1d), allocatable :: pbuff(:) + + IF (.true.) THEN + + allocate (pbuff (0:mpas_size-1)) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + allocate (pbuff(iproc)%val (this%glist(iproc)%ng)) + pbuff(iproc)%val(:) = 0.0 + ENDIF + ENDDO + + DO iset = 1, this%npset + DO ipart = 1, this%npart(iset) + iproc = this%address(iset)%val(1,ipart) + iloc = this%address(iset)%val(2,ipart) + + pbuff(iproc)%val(iloc) = pbuff(iproc)%val(iloc) & + + sdata(iset)%val(ipart) * this%areapart(iset)%val(ipart) + ENDDO + ENDDO + + + ENDIF + + IF (.true.) THEN + + CALL flush_block_data (gdata, 0.0_r8) + + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + + allocate (gbuff (this%glist(iproc)%ng)) + + gbuff = pbuff(COLM_SPATIAL_LOCAL_RANK)%val + + DO ig = 1, this%glist(iproc)%ng + ilon = this%glist(iproc)%ilon(ig) + ilat = this%glist(iproc)%ilat(ig) + xblk = this%grid%xblk (ilon) + yblk = this%grid%yblk (ilat) + xloc = this%grid%xloc (ilon) + yloc = this%grid%yloc (ilat) + + gdata%blk(xblk,yblk)%val(xloc,yloc) = & + gdata%blk(xblk,yblk)%val(xloc,yloc) + gbuff(ig) + ENDDO + + deallocate (gbuff) + ENDIF + ENDDO + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + WHERE (this%areagrid%blk(xblk,yblk)%val > 0) + gdata%blk(xblk,yblk)%val = & + gdata%blk(xblk,yblk)%val / this%areagrid%blk(xblk,yblk)%val + ELSEWHERE + gdata%blk(xblk,yblk)%val = this%missing_value + ENDWHERE + ENDDO + + ENDIF + + IF (.true.) THEN + DO iproc = 0, mpas_size-1 + IF (this%glist(iproc)%ng > 0) THEN + deallocate (pbuff(iproc)%val) + ENDIF + ENDDO + deallocate (pbuff) + ENDIF + + END SUBROUTINE spatial_mapping_part2grid + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_normalize (this, gdata, sdata) + + USE MOD_Precision + USE MOD_Block + USE MOD_Grid + USE MOD_Pixelset + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(block_data_real8_2d), intent(in) :: gdata + type(pointer_real8_1d), intent(inout) :: sdata(:) + + ! Local variables + integer :: iblkme, xblk, yblk, iset, ipart + + type(block_data_real8_2d) :: sumdata + type(pointer_real8_1d), allocatable :: scaldata(:) + + + IF (.true.) CALL allocate_block_data (this%grid, sumdata) + IF (.true.) CALL this%allocate_part (scaldata) + + CALL this%part2grid (sdata, sumdata) + + IF (.true.) THEN + + DO iblkme = 1, gblock%nblkme + xblk = gblock%xblkme(iblkme) + yblk = gblock%yblkme(iblkme) + + WHERE (sumdata%blk(xblk,yblk)%val /= this%missing_value) + sumdata%blk(xblk,yblk)%val = gdata%blk(xblk,yblk)%val / sumdata%blk(xblk,yblk)%val + ENDWHERE + ENDDO + + ENDIF + + CALL this%grid2part (sumdata, scaldata) + + IF (.true.) THEN + + DO iset = 1, this%npset + DO ipart = 1, this%npart(iset) + IF (this%areapart(iset)%val(ipart) > 0.) THEN + sdata(iset)%val(ipart) = sdata(iset)%val(ipart) * scaldata(iset)%val(ipart) + ELSE + sdata(iset)%val(ipart) = this%missing_value + ENDIF + ENDDO + ENDDO + + ENDIF + + IF (.true.) deallocate(scaldata) + + END SUBROUTINE spatial_mapping_normalize + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_part2pset (this, sdata, pdata) + + USE MOD_Precision + USE MOD_Grid + USE MOD_DataType + USE MOD_MPAS_MPI + USE MOD_Vars_Global, only: spval + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), intent(in) :: sdata(:) + real(r8), intent(out) :: pdata(:) + + ! Local variables + integer :: iset + + IF (.true.) THEN + + pdata(:) = spval + + DO iset = 1, this%npset + IF (this%areapset(iset) > 0) THEN + pdata(iset) = sum(sdata(iset)%val * this%areapart(iset)%val) / this%areapset(iset) + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE spatial_mapping_part2pset + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_allocate_part (this, datapart) + + USE MOD_MPAS_MPI + USE MOD_DataType + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), allocatable :: datapart (:) + + ! Local variables + integer :: iset + + IF (.true.) THEN + + IF (this%npset > 0) THEN + allocate (datapart (this%npset)) + ENDIF + + DO iset = 1, this%npset + IF (this%npart(iset) > 0) THEN + allocate (datapart(iset)%val (this%npart(iset))) + ENDIF + ENDDO + + ENDIF + + END SUBROUTINE spatial_mapping_allocate_part + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_deallocate_part (this, datapart) + + USE MOD_MPAS_MPI + USE MOD_DataType + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + type(pointer_real8_1d), allocatable :: datapart (:) + + ! Local variables + integer :: iset + + IF (.true.) THEN + + DO iset = 1, this%npset + IF (this%npart(iset) > 0) THEN + deallocate (datapart(iset)%val) + ENDIF + ENDDO + + IF (this%npset > 0) THEN + deallocate (datapart) + ENDIF + + ENDIF + + END SUBROUTINE spatial_mapping_deallocate_part + + !----------------------------------------------------- + SUBROUTINE spatial_mapping_free_mem (this) + + USE MOD_MPAS_MPI + IMPLICIT NONE + + type (spatial_mapping_type) :: this + + ! Local variables + integer :: iproc, iset + + IF (allocated (this%grid%xblk)) deallocate (this%grid%xblk) + IF (allocated (this%grid%yblk)) deallocate (this%grid%yblk) + + IF (allocated (this%grid%xloc)) deallocate (this%grid%xloc) + IF (allocated (this%grid%yloc)) deallocate (this%grid%yloc) + + IF (allocated (this%grid%xcnt)) deallocate (this%grid%xcnt) + IF (allocated (this%grid%ycnt)) deallocate (this%grid%ycnt) + + IF (allocated(this%glist)) THEN + DO iproc = lbound(this%glist,1), ubound(this%glist,1) + IF (allocated(this%glist(iproc)%ilat)) deallocate (this%glist(iproc)%ilat) + IF (allocated(this%glist(iproc)%ilon)) deallocate (this%glist(iproc)%ilon) + ENDDO + + deallocate (this%glist) + ENDIF + + IF (.true.) THEN + + IF (allocated(this%npart)) deallocate(this%npart) + + IF (allocated(this%address)) THEN + DO iset = lbound(this%address,1), ubound(this%address,1) + IF (allocated(this%address(iset)%val)) THEN + deallocate (this%address(iset)%val) + ENDIF + ENDDO + + deallocate (this%address) + ENDIF + + IF (allocated(this%areapart)) THEN + DO iset = lbound(this%areapart,1), ubound(this%areapart,1) + IF (allocated(this%areapart(iset)%val)) THEN + deallocate (this%areapart(iset)%val) + ENDIF + ENDDO + + deallocate (this%areapart) + ENDIF + + IF (allocated(this%areapset)) deallocate(this%areapset) + + ENDIF + + END SUBROUTINE spatial_mapping_free_mem + + SUBROUTINE forc_free_mem_spatial_mapping(this) + + USE MOD_MPAS_MPI + IMPLICIT NONE + + class (spatial_mapping_type) :: this + + ! Local variables + integer :: iproc, iset + + IF (allocated (this%grid%xblk)) deallocate (this%grid%xblk) + IF (allocated (this%grid%yblk)) deallocate (this%grid%yblk) + + IF (allocated (this%grid%xloc)) deallocate (this%grid%xloc) + IF (allocated (this%grid%yloc)) deallocate (this%grid%yloc) + + IF (allocated (this%grid%xcnt)) deallocate (this%grid%xcnt) + IF (allocated (this%grid%ycnt)) deallocate (this%grid%ycnt) + + IF (allocated(this%glist)) THEN + DO iproc = lbound(this%glist,1), ubound(this%glist,1) + IF (allocated(this%glist(iproc)%ilat)) deallocate (this%glist(iproc)%ilat) + IF (allocated(this%glist(iproc)%ilon)) deallocate (this%glist(iproc)%ilon) + ENDDO + + deallocate (this%glist) + ENDIF + + IF (.true.) THEN + + IF (allocated(this%npart)) deallocate(this%npart) + + IF (allocated(this%address)) THEN + DO iset = lbound(this%address,1), ubound(this%address,1) + IF (allocated(this%address(iset)%val)) THEN + deallocate (this%address(iset)%val) + ENDIF + ENDDO + + deallocate (this%address) + ENDIF + + IF (allocated(this%areapart)) THEN + DO iset = lbound(this%areapart,1), ubound(this%areapart,1) + IF (allocated(this%areapart(iset)%val)) THEN + deallocate (this%areapart(iset)%val) + ENDIF + ENDDO + + deallocate (this%areapart) + ENDIF + + IF (allocated(this%areapset)) deallocate(this%areapset) + + ENDIF + + END SUBROUTINE forc_free_mem_spatial_mapping + +END MODULE MOD_SpatialMapping diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 new file mode 100644 index 0000000000..632e4afb78 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90 @@ -0,0 +1,578 @@ +#include + +MODULE MOD_SrfdataRestart +!----------------------------------------------------------------------- +! !DESCRIPTION: +! +! This module includes subroutines to read/write data of mesh and pixelsets. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------- + + IMPLICIT NONE + + ! ----- subroutines ----- + PUBLIC :: mesh_load_from_file + + PUBLIC :: pixelset_load_from_file + +CONTAINS + + !------------------------------------ + SUBROUTINE prepare_subset_eindex(subset_eindex, sorted_subset) + + USE MOD_Utils, only: quicksort + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + integer*8, intent(in) :: subset_eindex(:) + integer*8, allocatable, intent(out) :: sorted_subset(:) + + integer, allocatable :: order(:) + integer :: i + + allocate(sorted_subset(size(subset_eindex))) + sorted_subset = subset_eindex + + IF (size(sorted_subset) > 1) THEN + allocate(order(size(sorted_subset))) + order = (/ (i, i = 1, size(sorted_subset)) /) + CALL quicksort(size(sorted_subset), sorted_subset, order) + deallocate(order) + + IF (any(sorted_subset(2:) == sorted_subset(:size(sorted_subset)-1))) THEN + CALL CoLM_stop('MPAS supplied duplicate owned cell IDs to embedded CoLM.') + ENDIF + ENDIF + + END SUBROUTINE prepare_subset_eindex + + !------------------------------------ + logical FUNCTION eindex_in_subset(eindex, sorted_subset) result(keep) + + USE MOD_Utils, only: find_in_sorted_list1 + IMPLICIT NONE + + integer*8, intent(in) :: eindex + integer*8, allocatable, intent(in) :: sorted_subset(:) + + IF (.not. allocated(sorted_subset)) THEN + keep = .true. + ELSEIF (size(sorted_subset) < 1) THEN + keep = .false. + ELSE + keep = find_in_sorted_list1(eindex, size(sorted_subset), sorted_subset) > 0 + ENDIF + + END FUNCTION eindex_in_subset + + !------------------------------------ + integer FUNCTION count_subset_eindex(eindex, sorted_subset) result(nkeep) + + IMPLICIT NONE + + integer*8, intent(in) :: eindex(:) + integer*8, allocatable, intent(in) :: sorted_subset(:) + + integer :: i + + nkeep = 0 + DO i = 1, size(eindex) + IF (eindex_in_subset(eindex(i), sorted_subset)) nkeep = nkeep + 1 + ENDDO + + END FUNCTION count_subset_eindex + + !------------------------------------ + SUBROUTINE mesh_load_from_file (dir_landdata, lc_year, subset_eindex) + + USE MOD_MPAS_MPI + USE MOD_Namelist + USE MOD_Block + USE MOD_NetCDFSerial + USE MOD_Mesh + IMPLICIT NONE + + integer , intent(in) :: lc_year + character(len=*), intent(in) :: dir_landdata + integer*8, optional, intent(in) :: subset_eindex(:) + + ! Local variables + character(len=256) :: filename, fileblock, cyear + integer :: iblkme, iblk, jblk, ie, nelm, ndsp, pdsp + integer*8, allocatable :: elmindx(:) + integer*8, allocatable :: subset_sorted(:) + integer, allocatable :: datasize(:) + integer, allocatable :: npxl(:), pixels(:,:), pixels2d(:,:,:) + logical, allocatable :: keep_elm(:) + logical :: use_subset + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('mesh-load entry synchronization') +#endif + + IF (mpas_is_root) THEN + write(*,*) 'Loading land elements ...' + ENDIF + + ! add parameter input for time year + write(cyear,'(i4.4)') lc_year + filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc' + IF (.true.) CALL mesh_free_mem() + CALL ncio_read_bcast_serial (filename, 'nelm_blk', nelm_blk) + use_subset = present(subset_eindex) + IF (use_subset) CALL prepare_subset_eindex(subset_eindex, subset_sorted) + + IF (.true.) THEN + IF (use_subset) THEN + numelm = size(subset_eindex) + ELSE + numelm = sum(nelm_blk, mask = gblock%owner_rank == mpas_rank) + ENDIF + + IF (numelm > 0) THEN + + IF (allocated(mesh)) deallocate(mesh) + allocate (mesh (numelm)) + + ndsp = 0 + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + + nelm = nelm_blk(iblk,jblk) + + IF (nelm > 0) THEN + + CALL get_filename_block (filename, iblk, jblk, fileblock) + CALL ncio_read_serial (fileblock, 'elmindex', elmindx) + CALL ncio_read_serial (fileblock, 'elmnpxl', npxl ) + + IF (size(elmindx) /= nelm .or. size(npxl) /= nelm) THEN + CALL CoLM_stop('CoLM mesh block metadata lengths disagree with nelm_blk: '//trim(fileblock)) + ENDIF + IF (any(npxl < 1)) THEN + CALL CoLM_stop('CoLM mesh block contains an element with no pixels: '//trim(fileblock)) + ENDIF + + IF (use_subset) THEN + allocate (keep_elm(nelm)) + DO ie = 1, nelm + keep_elm(ie) = eindex_in_subset(elmindx(ie), subset_sorted) + ENDDO + IF (count(keep_elm) < 1) THEN + deallocate(keep_elm) + IF (allocated(elmindx)) deallocate(elmindx) + IF (allocated(npxl)) deallocate(npxl) + CYCLE + ENDIF + ENDIF + + CALL ncio_inquire_varsize (fileblock, 'elmpixels', datasize) + IF (size(datasize) == 3) THEN + CALL ncio_read_serial (fileblock, 'elmpixels', pixels2d) + IF (size(pixels2d,1) < 2 .or. size(pixels2d,3) < nelm .or. & + size(pixels2d,2) < maxval(npxl)) THEN + CALL CoLM_stop('CoLM mesh block has inconsistent 3-D elmpixels dimensions: '//trim(fileblock)) + ENDIF + ELSEIF (size(datasize) == 2) THEN + CALL ncio_read_serial (fileblock, 'elmpixels', pixels) + IF (size(pixels,1) < 2 .or. size(pixels,2) < sum(npxl)) THEN + CALL CoLM_stop('CoLM mesh block has inconsistent 2-D elmpixels dimensions: '//trim(fileblock)) + ENDIF + ELSE + CALL CoLM_stop('CoLM mesh elmpixels must be a two- or three-dimensional variable: '//trim(fileblock)) + ENDIF + + pdsp = 0 + DO ie = 1, nelm + IF (use_subset) THEN + IF (.not. keep_elm(ie)) THEN + IF (size(datasize) /= 3) pdsp = pdsp + npxl(ie) + CYCLE + ENDIF + ENDIF + + ndsp = ndsp + 1 + IF (ndsp > size(mesh)) THEN + CALL CoLM_stop('MPAS embedded CoLM mesh contains duplicate element IDs for an owned cell subset.') + ENDIF + mesh(ndsp)%indx = elmindx(ie) + mesh(ndsp)%npxl = npxl(ie) + mesh(ndsp)%xblk = iblk + mesh(ndsp)%yblk = jblk + + allocate (mesh(ndsp)%ilon (npxl(ie))) + allocate (mesh(ndsp)%ilat (npxl(ie))) + + IF (size(datasize) == 3) THEN + mesh(ndsp)%ilon = pixels2d(1,1:npxl(ie),ie) + mesh(ndsp)%ilat = pixels2d(2,1:npxl(ie),ie) + ELSE + mesh(ndsp)%ilon = pixels(1,pdsp+1:pdsp+npxl(ie)) + mesh(ndsp)%ilat = pixels(2,pdsp+1:pdsp+npxl(ie)) + pdsp = pdsp + npxl(ie) + ENDIF + ENDDO + + IF (allocated(keep_elm)) deallocate(keep_elm) + IF (allocated(elmindx)) deallocate(elmindx) + IF (allocated(npxl)) deallocate(npxl) + IF (allocated(datasize)) deallocate(datasize) + IF (allocated(pixels)) deallocate(pixels) + IF (allocated(pixels2d)) deallocate(pixels2d) + ENDIF + ENDDO + + IF (ndsp /= size(mesh)) THEN + CALL CoLM_stop('MPAS embedded CoLM mesh does not contain exactly one element per owned MPAS cell.') + ENDIF + numelm = ndsp + IF (numelm == 0) CALL mesh_free_mem() + ENDIF + + IF (use_subset .and. allocated(nelm_blk)) THEN + nelm_blk(:,:) = 0 + DO ie = 1, numelm + nelm_blk(mesh(ie)%xblk, mesh(ie)%yblk) = & + nelm_blk(mesh(ie)%xblk, mesh(ie)%yblk) + 1 + ENDDO + ENDIF + + IF (allocated(elmindx )) deallocate(elmindx ) + IF (allocated(npxl )) deallocate(npxl ) + IF (allocated(datasize)) deallocate(datasize) + IF (allocated(pixels )) deallocate(pixels ) + IF (allocated(pixels2d)) deallocate(pixels2d) + IF (allocated(subset_sorted)) deallocate(subset_sorted) + + ENDIF + +#ifdef CoLMDEBUG + IF (.true.) write(*,'(I10,A,I4)') numelm, ' elements on group ', mpas_rank +#endif + +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('mesh-load completion synchronization') +#endif + + IF (mpas_is_root) THEN + write(*,*) 'Loading land elements done.' + ENDIF + + END SUBROUTINE mesh_load_from_file + + !--------------------------- + SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc_year, subset_eindex) + + USE MOD_MPAS_MPI + USE MOD_Block + USE MOD_NetCDFSerial + USE MOD_NetCDFVector + USE MOD_Mesh + USE MOD_Pixelset + USE MOD_Utils, only: quicksort, find_in_sorted_list1 + IMPLICIT NONE + + integer , intent(in) :: lc_year + character(len=*), intent(in) :: dir_landdata + character(len=*), intent(in) :: psetname + type(pixelset_type), intent(inout) :: pixelset + integer, intent(out) :: numset + integer*8, optional, intent(in) :: subset_eindex(:) + + ! Local variables + character(len=256) :: filename, fileblock, cyear +#if (defined VectorInOneFileS || defined VectorInOneFileP) + character(len=256) :: blockname +#endif + integer :: iset, nset, nset_file, ndsp, iblkme, iblk, jblk, ie, ipos + integer :: match + integer*8, allocatable :: rbuff(:), mesh_sorted(:) + integer*8, allocatable :: subset_sorted(:) + integer, allocatable :: mesh_order(:) + logical, allocatable :: keep_set(:) + logical :: fexists, fexists_any + logical :: use_subset + + write(cyear,'(i4.4)') lc_year +#ifdef MPAS_MPI + CALL mpi_barrier (mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('pixelset-load entry synchronization') +#endif + + use_subset = present(subset_eindex) + IF (use_subset) CALL prepare_subset_eindex(subset_eindex, subset_sorted) + + IF (mpas_is_root) THEN + write(*,*) 'Loading Pixel Sets ' // trim(psetname) // ' ...' + ENDIF + + filename = trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear) // '/' // trim(psetname) // '.nc' + + CALL pixelset%forc_free_mem() + + IF (.true.) THEN + + pixelset%nset = 0 + + fexists_any = .false. + + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + +#if (defined VectorInOneFileS || defined VectorInOneFileP) + CALL get_blockname (iblk, jblk, blockname) + CALL ncio_inquire_length_grp (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), nset) + IF (use_subset .and. nset > 0) THEN + CALL ncio_read_serial_grp_int64_1d (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), rbuff) + nset = count_subset_eindex(rbuff, subset_sorted) + deallocate(rbuff) + ENDIF + pixelset%nset = pixelset%nset + nset +#else + CALL get_filename_block (filename, iblk, jblk, fileblock) + + inquire (file=trim(fileblock), exist=fexists) + IF (fexists) THEN + IF (use_subset) THEN + CALL ncio_read_serial (fileblock, 'eindex', rbuff) + nset = count_subset_eindex(rbuff, subset_sorted) + deallocate(rbuff) + ELSE + CALL ncio_inquire_length (fileblock, 'eindex', nset) + ENDIF + pixelset%nset = pixelset%nset + nset + ENDIF + + fexists_any = fexists_any .or. fexists +#endif + ENDDO + +#if (defined VectorInOneFileS || defined VectorInOneFileP) + inquire(file=trim(filename), exist=fexists_any) +#endif + +#ifdef MPAS_MPI + CALL mpi_allreduce (MPI_IN_PLACE, fexists_any, 1, MPI_LOGICAL, MPI_LOR, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('pixelset file-presence reduction') +#endif + IF (.not. fexists_any) THEN + write(*,*) 'Warning : restart file ' //trim(filename)// ' not found.' + CALL CoLM_stop () + ENDIF + + IF (pixelset%nset > 0) THEN + + allocate (pixelset%eindex (pixelset%nset)) + allocate (pixelset%srcpos (pixelset%nset)) + + ndsp = 0 + DO iblkme = 1, gblock%nblkme + iblk = gblock%xblkme(iblkme) + jblk = gblock%yblkme(iblkme) + +#if (defined VectorInOneFileS || defined VectorInOneFileP) + CALL get_blockname (iblk, jblk, blockname) + CALL ncio_inquire_length_grp (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), nset) + + IF (nset > 0) THEN + + CALL ncio_read_serial_grp_int64_1d (filename, 'eindex', & + trim(psetname)//'_'//trim(blockname), rbuff) + + nset_file = size(rbuff) + IF (use_subset) THEN + allocate(keep_set(nset_file)) + DO iset = 1, nset_file + keep_set(iset) = eindex_in_subset(rbuff(iset), subset_sorted) + ENDDO + nset = count(keep_set) + ELSE + nset = nset_file + ENDIF + + IF (nset > 0) THEN + IF (ndsp + nset > pixelset%nset) THEN + CALL CoLM_stop('CoLM pixelset count changed while loading '//trim(psetname)//'.') + ENDIF + IF (use_subset) THEN + pixelset%eindex(ndsp+1:ndsp+nset) = pack(rbuff, keep_set) + pixelset%srcpos(ndsp+1:ndsp+nset) = & + pack((/ (ipos, ipos = 1, nset_file) /), keep_set) + ELSE + pixelset%eindex(ndsp+1:ndsp+nset) = rbuff + pixelset%srcpos(ndsp+1:ndsp+nset) = (/ (ipos, ipos = 1, nset) /) + ENDIF + + ndsp = ndsp + nset + ENDIF + + IF (allocated(keep_set)) deallocate(keep_set) + deallocate(rbuff) + ENDIF +#else + CALL get_filename_block (filename, iblk, jblk, fileblock) + inquire (file=trim(fileblock), exist=fexists) + IF (fexists) THEN + + CALL ncio_read_serial (fileblock, 'eindex', rbuff) + + nset_file = size(rbuff) + IF (use_subset) THEN + allocate(keep_set(nset_file)) + DO iset = 1, nset_file + keep_set(iset) = eindex_in_subset(rbuff(iset), subset_sorted) + ENDDO + nset = count(keep_set) + ELSE + nset = nset_file + ENDIF + + IF (nset > 0) THEN + IF (ndsp + nset > pixelset%nset) THEN + CALL CoLM_stop('CoLM pixelset count changed while loading '//trim(psetname)//'.') + ENDIF + IF (use_subset) THEN + pixelset%eindex(ndsp+1:ndsp+nset) = pack(rbuff, keep_set) + pixelset%srcpos(ndsp+1:ndsp+nset) = & + pack((/ (ipos, ipos = 1, nset_file) /), keep_set) + ELSE + pixelset%eindex(ndsp+1:ndsp+nset) = rbuff + pixelset%srcpos(ndsp+1:ndsp+nset) = (/ (ipos, ipos = 1, nset) /) + ENDIF + + ndsp = ndsp + nset + ENDIF + + IF (allocated(keep_set)) deallocate(keep_set) + deallocate(rbuff) + ENDIF +#endif + + ENDDO + + IF (ndsp /= pixelset%nset) THEN + CALL CoLM_stop('CoLM pixelset count changed between metadata and data reads for '//trim(psetname)//'.') + ENDIF + ENDIF + ENDIF + + + IF (.true. .and. pixelset%nset > 0) THEN + IF (.not. allocated(mesh)) THEN + CALL CoLM_stop('Cannot map '//trim(psetname)//' because the local CoLM element mesh is empty or inconsistent.') + ENDIF + IF (numelm < 1 .or. size(mesh) /= numelm) THEN + CALL CoLM_stop('Cannot map '//trim(psetname)//' because the local CoLM element mesh is empty or inconsistent.') + ENDIF + IF (.not. allocated(pixelset%eindex)) THEN + CALL CoLM_stop('Invalid element-index vector while loading '//trim(psetname)//'.') + ENDIF + IF (size(pixelset%eindex) /= pixelset%nset) THEN + CALL CoLM_stop('Invalid element-index vector while loading '//trim(psetname)//'.') + ENDIF + + allocate (mesh_sorted(numelm)) + allocate (mesh_order (numelm)) + DO ie = 1, numelm + mesh_sorted(ie) = mesh(ie)%indx + mesh_order(ie) = ie + ENDDO + IF (numelm > 1) CALL quicksort(numelm, mesh_sorted, mesh_order) + IF (numelm > 1) THEN + IF (any(mesh_sorted(2:numelm) == mesh_sorted(1:numelm-1))) THEN + CALL CoLM_stop('The local CoLM mesh contains duplicate element IDs while loading '//trim(psetname)//'.') + ENDIF + ENDIF + + allocate (pixelset%ielm(pixelset%nset)) + DO iset = 1, pixelset%nset + match = find_in_sorted_list1(pixelset%eindex(iset), numelm, mesh_sorted) + IF (match < 1) THEN + write(*,'(A,A,A,I0,A,I0)') 'CoLM ', trim(psetname), ' entry ', iset, & + ' references missing element ', pixelset%eindex(iset) + CALL CoLM_stop('CoLM pixelset and MPAS-owned element mesh are inconsistent.') + ENDIF + pixelset%ielm(iset) = mesh_order(match) + ENDDO + + deallocate (mesh_sorted) + deallocate (mesh_order) + ENDIF + + CALL pixelset%set_vecgs + + CALL ncio_read_vector (filename, 'ipxstt', pixelset, pixelset%ipxstt) + CALL ncio_read_vector (filename, 'ipxend', pixelset, pixelset%ipxend) + CALL ncio_read_vector (filename, 'settyp', pixelset, pixelset%settyp) + + IF (.true. .and. pixelset%nset > 0) THEN + IF (.not. allocated(pixelset%ipxstt) .or. .not. allocated(pixelset%ipxend) .or. & + .not. allocated(pixelset%settyp)) THEN + CALL CoLM_stop('CoLM pixelset identity vectors are incomplete for '//trim(psetname)//'.') + ENDIF + IF (size(pixelset%ipxstt) /= pixelset%nset .or. size(pixelset%ipxend) /= pixelset%nset .or. & + size(pixelset%settyp) /= pixelset%nset) THEN + CALL CoLM_stop('CoLM pixelset identity vector lengths are inconsistent for '//trim(psetname)//'.') + ENDIF + DO iset = 1, pixelset%nset + ie = pixelset%ielm(iset) + IF (ie < 1 .or. ie > numelm) THEN + CALL CoLM_stop('CoLM pixelset references an invalid local element for '//trim(psetname)//'.') + ENDIF + IF (pixelset%ipxstt(iset) == -1) THEN + IF (pixelset%ipxend(iset) /= -1) THEN + CALL CoLM_stop('CoLM virtual pixelset has inconsistent pixel bounds for '//trim(psetname)//'.') + ENDIF + ELSEIF (pixelset%ipxstt(iset) < 1 .or. pixelset%ipxend(iset) < pixelset%ipxstt(iset) .or. & + pixelset%ipxend(iset) > mesh(ie)%npxl) THEN + CALL CoLM_stop('CoLM pixelset references pixels outside its element for '//trim(psetname)//'.') + ENDIF + ENDDO + ENDIF + + IF (.true.) THEN + IF (pixelset%nset == 0) THEN + write(*,*) 'Warning: 0 ',trim(psetname), ' on rank :', mpas_rank + ENDIF + ENDIF + + numset = pixelset%nset + + pixelset%has_shared = .false. + IF (.true.) THEN + DO iset = 1, pixelset%nset-1 + IF ((pixelset%ielm(iset) == pixelset%ielm(iset+1)) & + .and. (pixelset%ipxstt(iset) == pixelset%ipxstt(iset+1))) THEN + pixelset%has_shared = .true. + exit + ENDIF + ENDDO + ENDIF + +#ifdef MPAS_MPI + CALL mpi_allreduce (MPI_IN_PLACE, pixelset%has_shared, 1, MPI_LOGICAL, & + MPI_LOR, mpas_comm, mpas_mpi_ierr) + CALL mpas_mpi_check('shared-pixelset presence reduction') +#endif + + IF (pixelset%has_shared) THEN + CALL ncio_read_vector (filename, 'pctshared', pixelset, pixelset%pctshared) + ENDIF + +#ifdef CoLMDEBUG + IF (.true.) write(*,*) numset, trim(psetname), ' on group', mpas_rank +#endif + + IF (allocated(subset_sorted)) deallocate(subset_sorted) + + END SUBROUTINE pixelset_load_from_file + +END MODULE MOD_SrfdataRestart diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 new file mode 100644 index 0000000000..5ffb9a1288 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90 @@ -0,0 +1,709 @@ +#include + +MODULE MOD_TimeManager + +! -------------------------------------------------------- +! +! !DESCRIPTION: +! Time manager module: to provide some basic operations for time stamp +! +! Created by Hua Yuan, 04/2014 +! +! !REVISIONS: +! 06/28/2017, Hua Yuan: added issame() and monthday2julian() +! TODO... +! -------------------------------------------------------- + + USE MOD_Precision + IMPLICIT NONE + + integer, dimension(0:12), parameter :: & + daysofmonth_leap = (/0,31,29,31,30,31,30,31,31,30,31,30,31/) ,& + daysofmonth_noleap = (/0,31,28,31,30,31,30,31,31,30,31,30,31/) ,& + accdaysofmonth_leap = (/0,31,60,91,121,152,182,213,244,274,305,335,366/) ,& + accdaysofmonth_noleap = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) + + type :: timestamp + integer :: year, day, sec + END type timestamp + + INTERFACE ASSIGNMENT (=) + MODULE procedure assignidate + MODULE procedure assigntstamp + END INTERFACE + + INTERFACE OPERATOR (+) + MODULE procedure addsec + END INTERFACE + + INTERFACE OPERATOR (-) + MODULE procedure subtstamp + END INTERFACE + + INTERFACE OPERATOR (<=) + MODULE procedure lessequal + END INTERFACE + + INTERFACE OPERATOR (<) + MODULE procedure lessthan + END INTERFACE + + INTERFACE OPERATOR (==) + MODULE procedure isnull + MODULE procedure besame + END INTERFACE + + INTERFACE calendarday + MODULE procedure calendarday_date + MODULE procedure calendarday_stamp + END INTERFACE + + logical, SAVE :: isgreenwich + real(r8),SAVE :: LocalLongitude = 0. + PUBLIC get_calday + +CONTAINS + + SUBROUTINE initimetype(greenwich) + + IMPLICIT NONE + logical, intent(in) :: greenwich + + isgreenwich = greenwich + +#ifndef SinglePoint + IF (.not. isgreenwich) THEN + write(*,*) 'Warning: Please USE Greenwich time for non-SinglePoint case.' + isgreenwich = .true. + ENDIF +#endif + + END SUBROUTINE initimetype + + SUBROUTINE assignidate(tstamp, idate) + + IMPLICIT NONE + type(timestamp), intent(inout) :: tstamp + integer, intent(in) :: idate(3) + + tstamp%year = idate(1) + tstamp%day = idate(2) + tstamp%sec = idate(3) + + END SUBROUTINE assignidate + + SUBROUTINE assigntstamp(tstamp1, tstamp2) + + IMPLICIT NONE + type(timestamp), intent(out) :: tstamp1 + type(timestamp), intent(in) :: tstamp2 + + tstamp1%year = tstamp2%year + tstamp1%day = tstamp2%day + tstamp1%sec = tstamp2%sec + + END SUBROUTINE assigntstamp + + FUNCTION addsec(tstamp, sec) + + IMPLICIT NONE + type(timestamp), intent(in) :: tstamp + integer, intent(in) :: sec + type(timestamp) :: addsec + integer :: maxday + + addsec = tstamp + addsec%sec = addsec%sec + sec + DO WHILE (addsec%sec > 86400) + addsec%sec = addsec%sec - 86400 + IF( isleapyear(addsec%year) ) THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + addsec%day = addsec%day + 1 + IF(addsec%day > maxday) THEN + addsec%year = addsec%year + 1 + addsec%day = 1 + ENDIF + ENDDO + DO WHILE (addsec%sec <= 0) + addsec%sec = addsec%sec + 86400 + IF( isleapyear(addsec%year-1) )THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + addsec%day = addsec%day - 1 + IF(addsec%day <= 0) THEN + addsec%year = addsec%year - 1 + addsec%day = maxday + ENDIF + ENDDO + RETURN + + END FUNCTION addsec + + FUNCTION subtstamp(tstamp1, tstamp2) + + IMPLICIT NONE + type(timestamp), intent(in) :: tstamp1 + type(timestamp), intent(in) :: tstamp2 + integer :: subtstamp + + subtstamp = tstamp1%sec - tstamp2%sec + IF (subtstamp < 0) THEN + subtstamp = subtstamp + 86400 + ENDIF + RETURN + + END FUNCTION subtstamp + + logical FUNCTION lessequal(tstamp1, tstamp2) + + IMPLICIT NONE + type(timestamp), intent(in) :: tstamp1 + type(timestamp), intent(in) :: tstamp2 + + integer(kind=4) :: idate1(3), idate2(3) + integer(kind=4) :: ts1, ts2 + + idate1 = (/tstamp1%year, tstamp1%day, tstamp1%sec/) + idate2 = (/tstamp2%year, tstamp2%day, tstamp2%sec/) + + CALL adj2end(idate1) + CALL adj2end(idate2) + + ts1 = idate1(1)*1000 + idate1(2) + ts2 = idate2(1)*1000 + idate2(2) + + lessequal = .false. + + IF (ts1 < ts2) lessequal = .true. + + IF (ts1==ts2 .and. idate1(3)<=idate2(3)) THEN + lessequal = .true. + ENDIF + + RETURN + + END FUNCTION lessequal + + logical FUNCTION lessthan(tstamp1, tstamp2) + + IMPLICIT NONE + type(timestamp), intent(in) :: tstamp1 + type(timestamp), intent(in) :: tstamp2 + + integer(kind=4) :: idate1(3), idate2(3) + integer(kind=4) :: ts1, ts2 + + idate1 = (/tstamp1%year, tstamp1%day, tstamp1%sec/) + idate2 = (/tstamp2%year, tstamp2%day, tstamp2%sec/) + + CALL adj2end(idate1) + CALL adj2end(idate2) + + ts1 = idate1(1)*1000 + idate1(2) + ts2 = idate2(1)*1000 + idate2(2) + + lessthan = .false. + + IF (ts1 < ts2) lessthan = .true. + + IF (ts1==ts2 .and. idate1(3) 86400) + idate(3) = idate(3) - 86400 + idate(2) = idate(2) + 1 + + IF ( isleapyear(idate(1)) ) THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + + IF(idate(2) > maxday) THEN + idate(1) = idate(1) + 1 + idate(2) = 1 + ENDIF + ENDDO + + END SUBROUTINE localtime2gmt + + SUBROUTINE ticktime(deltim, idate) + + IMPLICIT NONE + + real(r8),intent(in) :: deltim + integer, intent(inout) :: idate(3) + integer maxday + + idate(3) = idate(3) + nint(deltim) + DO WHILE (idate(3) > 86400) + idate(3) = idate(3) - 86400 + idate(2) = idate(2) + 1 + + IF ( isleapyear(idate(1)) ) THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + + IF(idate(2) > maxday) THEN + idate(1) = idate(1) + 1 + idate(2) = 1 + ENDIF + ENDDO + + END SUBROUTINE ticktime + + real(r8) FUNCTION calendarday_date(date) + + IMPLICIT NONE + integer, intent(in) :: date(3) + + integer idate(3) + + idate(:) = date(:) + + IF ( .not. isgreenwich ) THEN + CALL localtime2gmt(idate) + ENDIF + + calendarday_date = float(idate(2)) + float(idate(3))/86400. + RETURN + + END FUNCTION calendarday_date + + real(r8) FUNCTION calendarday_stamp(stamp) + + IMPLICIT NONE + type(timestamp), intent(in) :: stamp + + integer idate(3) + + idate(1) = stamp%year + idate(2) = stamp%day + idate(3) = stamp%sec + + IF ( .not. isgreenwich ) THEN + CALL localtime2gmt(idate) + ENDIF + + calendarday_stamp = float(idate(2)) + float(idate(3))/86400. + RETURN + + END FUNCTION calendarday_stamp + + integer FUNCTION get_calday(mmdd,isleap) + + IMPLICIT NONE + integer, intent(in) :: mmdd + logical, intent(in) :: isleap + + integer imonth, iday + + imonth = mmdd / 100 + iday = mod(mmdd,100) + IF(isleap)THEN + get_calday = sum(daysofmonth_leap(0:imonth-1)) + iday + ELSE + get_calday = sum(daysofmonth_noleap(0:imonth-1)) + iday + ENDIF + RETURN + END FUNCTION get_calday + + integer FUNCTION minutes_since_1900 (year, julianday, second) + + USE MOD_UserDefFun + IMPLICIT NONE + integer, intent(in) :: year, julianday, second + + integer :: refyear(10) = (/1, 1900, 1950, 1980, 1990, 2000, 2005, 2010, 2015, 2020/) + integer :: refval (10) = (/-998776800,0,26297280,42075360,47335680,52594560,55225440,& + 57854880,60484320,63113760/) + integer :: iref, iyear + + iref = findloc_ud(refyear <= year, back=.true.) + minutes_since_1900 = refval(iref) + DO iyear = refyear(iref), year-1 + IF (isleapyear(iyear)) THEN + minutes_since_1900 = minutes_since_1900 + 527040 + ELSE + minutes_since_1900 = minutes_since_1900 + 525600 + ENDIF + ENDDO + + minutes_since_1900 = minutes_since_1900 + (julianday-1) * 1440 + minutes_since_1900 = minutes_since_1900 + second/60 + + END FUNCTION minutes_since_1900 + + ! ----------------------------------------------------------------------- + SUBROUTINE gmt2local(idate, long, ldate) + + ! !DESCRIPTION: + ! A SUBROUTINE to calculate local time + ! !PURPOSE + ! Convert GMT time to local time in global run + ! ----------------------------------------------------------------------- + + IMPLICIT NONE + + integer , intent(in ) :: idate(3) + real(r8), intent(in ) :: long + real(r8), intent(out) :: ldate(3) + + integer :: maxday + real(r8) :: tdiff + + tdiff = long/15.*3600 + + ldate(3) = idate(3) + tdiff + ldate(1) = idate(1) + + IF (ldate(3) < 0) THEN + + ldate(3) = 86400 + ldate(3) + ldate(2) = idate(2) - 1 + + IF (ldate(2) < 1) THEN + ldate(1) = idate(1) - 1 + IF ( isleapyear(int(ldate(1))) ) THEN + ldate(2) = 366 + ELSE + ldate(2) = 365 + ENDIF + ENDIF + + ELSEIF (ldate(3) > 86400) THEN + + ldate(3) = ldate(3) - 86400 + ldate(2) = idate(2) + 1 + + IF ( isleapyear(int(ldate(1))) ) THEN + maxday = 366 + ELSE + maxday = 365 + ENDIF + + IF(ldate(2) > maxday) THEN + ldate(1) = idate(1) + 1 + ldate(2) = 1 + ENDIF + ELSE + ldate(2) = idate(2) + ldate(1) = idate(1) + ENDIF + + END SUBROUTINE gmt2local + + ! ----------------------------------------------------------------------- + SUBROUTINE timeweek(year, month, day, iweek) + + ! !DESCRIPTION: + ! A subroutine to calculate day of week + ! !PURPOSE + ! Calculate day of week to determine IF the day is week holiday + ! ----------------------------------------------------------------------- + + IMPLICIT NONE + + integer, intent(in ) :: year, month + integer, intent(out) :: iweek, day + + integer :: myear, mmonth + integer :: yy, mm, dd, y12, y34 + integer :: A, B, C, D, i + + integer :: monthday(0:12) + + IF ( isleapyear(year) ) THEN + monthday(:) = daysofmonth_leap(:) + ELSE + monthday(:) = daysofmonth_noleap(:) + ENDIF + + IF (month==1 .or. month==2) THEN + mmonth = month + 12 + myear = year - 1 + ELSE + mmonth = month + myear = year + ENDIF + + y12 = myear/100 + y34 = myear - y12*100 + + A = int(y34/4.) + B = int(y12/4.) + C = y12*2 + D = int(26*(mmonth+1)/10.) + + iweek = abs(mod((y34+A+B-C+D+day-1), 7)) + + DO i=1, month-1 + day = day + monthday(i) + ENDDO + + IF (iweek == 0) THEN + iweek = 7 + ENDIF + + END SUBROUTINE timeweek + +END MODULE MOD_TimeManager diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_UserDefFun.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_UserDefFun.F90 new file mode 100644 index 0000000000..cb44a3e2b2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_UserDefFun.F90 @@ -0,0 +1,70 @@ +MODULE MOD_UserDefFun + +!----------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! This MODULE contains user defined functions to replace non-standard functions. +! +! Created by Shupeng Zhang, April 2024 +!----------------------------------------------------------------------------------------- + + ! ---- PUBLIC subroutines ---- + + INTERFACE isnan_ud + MODULE procedure isnan_ud_r8 + END INTERFACE isnan_ud + +CONTAINS + + ! ---------- + elemental logical FUNCTION isnan_ud_r8 (a) + + USE MOD_Precision, only: r8 + + IMPLICIT NONE + real(r8), intent(in) :: a + + isnan_ud_r8 = (a /= a) + + END FUNCTION isnan_ud_r8 + + ! ---------- + integer FUNCTION findloc_ud (array, back) + + IMPLICIT NONE + logical, intent(in) :: array(:) + logical, intent(in), optional :: back + + ! Local Variables + logical :: bb + integer :: n, i, i0, i1, ii + + n = size(array) + IF (n <= 0) THEN + findloc_ud = 0 + ELSE + + bb = .false. + IF (present(back)) THEN + bb = back + ENDIF + + IF (.not. bb) THEN + i0 = 1; i1 = n; ii = 1 + ELSE + i0 = n; i1 = 1; ii = -1 + ENDIF + + findloc_ud = 0 + DO i = i0, i1, ii + IF (array(i)) THEN + findloc_ud = i + EXIT + ENDIF + ENDDO + + ENDIF + + END FUNCTION findloc_ud + +END MODULE MOD_UserDefFun diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 new file mode 100644 index 0000000000..f7eb11bcc2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90 @@ -0,0 +1,2650 @@ +MODULE MOD_Utils + +!----------------------------------------------------------------------------------------- +! !DESCRIPTION: +! +! This MODULE CONTAINS utilities. +! +! !REVISIONS: +! Subroutines lmder, enorm, tridia and polint are moved from other files. +! +! Created by Shupeng Zhang, May 2023 +!----------------------------------------------------------------------------------------- + + ! ---- PUBLIC subroutines ---- + + PUBLIC :: normalize_longitude + PUBLIC :: make_directory + + INTERFACE expand_list + MODULE procedure expand_list_int32 + MODULE procedure expand_list_int64 + MODULE procedure expand_list_real8 + END INTERFACE expand_list + + PUBLIC :: append_to_list + + INTERFACE insert_into_sorted_list1 + MODULE procedure insert_into_sorted_list1_int32 + MODULE procedure insert_into_sorted_list1_int64 + END INTERFACE insert_into_sorted_list1 + + PUBLIC :: insert_into_sorted_list2 + + INTERFACE find_in_sorted_list1 + MODULE procedure find_in_sorted_list1_int32 + MODULE procedure find_in_sorted_list1_int64 + END INTERFACE find_in_sorted_list1 + + PUBLIC :: find_in_sorted_list2 + + PUBLIC :: find_nearest_south + PUBLIC :: find_nearest_north + PUBLIC :: find_nearest_west + PUBLIC :: find_nearest_east + + PUBLIC :: lon_between_floor + PUBLIC :: lon_between_ceil + + INTERFACE quicksort + MODULE procedure quicksort_int32 + MODULE procedure quicksort_int64 + MODULE procedure quicksort_real8 + END INTERFACE quicksort + + PUBLIC :: quickselect + PUBLIC :: median + + PUBLIC :: areaquad + PUBLIC :: arclen + + INTERFACE unpack_inplace + MODULE procedure unpack_inplace_int32 + MODULE procedure unpack_inplace_real8 + MODULE procedure unpack_inplace_lastdim_real8 + END INTERFACE unpack_inplace + + PUBLIC :: num_max_frequency + + PUBLIC :: lmder + PUBLIC :: lmpar + PUBLIC :: qrfac + PUBLIC :: qrsolv + + PUBLIC :: enorm + PUBLIC :: tridia + PUBLIC :: polint + +CONTAINS + + !--------------------------------- + SUBROUTINE make_directory (path) + + USE MOD_MPAS_MPI, only: CoLM_stop + IMPLICIT NONE + + character(len=*), intent(in) :: path + character(len=:), allocatable :: directory, command + integer :: cmdstat, exitstat + logical :: exists + + directory = trim(adjustl(path)) + IF (len(directory) == 0) CALL CoLM_stop('Cannot create an empty directory path.') + IF (verify(directory, 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_./+-') /= 0) THEN + CALL CoLM_stop('CoLM directory paths may contain only letters, digits, _, ., /, +, and -.') + ENDIF + + inquire(file=directory, exist=exists) + IF (exists) RETURN + + IF (directory(1:1) == '/') THEN + command = 'mkdir -p ' // directory + ELSE + command = 'mkdir -p ./' // directory + ENDIF + CALL execute_command_line(command, wait=.true., exitstat=exitstat, cmdstat=cmdstat) + IF (cmdstat /= 0 .or. exitstat /= 0) THEN + CALL CoLM_stop('Failed to create CoLM directory: '//directory) + ENDIF + inquire(file=directory, exist=exists) + IF (.not. exists) CALL CoLM_stop('CoLM directory creation did not produce: '//directory) + + END SUBROUTINE make_directory + + !--------------------------------- + SUBROUTINE normalize_longitude (lon) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(inout) :: lon + + DO WHILE (lon >= 180.0) + lon = lon - 360.0 + ENDDO + + DO WHILE (lon < -180.0) + lon = lon + 360.0 + ENDDO + + END SUBROUTINE normalize_longitude + + !-------------------------------------------------- + SUBROUTINE expand_list_int32 (list, percent) + + USE MOD_Precision + IMPLICIT NONE + + integer, allocatable, intent(inout) :: list (:) + real(r8), intent(in) :: percent + + ! Local variables + integer :: n0, n1 + integer, allocatable :: temp (:) + + n0 = size(list) + + allocate (temp(n0)) + temp = list + + n1 = ceiling(n0 * (1+percent)) + + deallocate(list) + allocate (list(n1)) + list(1:n0) = temp + + deallocate (temp) + + END SUBROUTINE expand_list_int32 + + !-------------------------------------------------- + SUBROUTINE expand_list_int64 (list, percent) + + USE MOD_Precision + IMPLICIT NONE + + integer*8, allocatable, intent(inout) :: list (:) + real(r8), intent(in) :: percent + + ! Local variables + integer :: n0, n1 + integer*8, allocatable :: temp (:) + + n0 = size(list) + + allocate (temp(n0)) + temp = list + + n1 = ceiling(n0 * (1+percent)) + + deallocate(list) + allocate (list(n1)) + list(1:n0) = temp + + deallocate (temp) + + END SUBROUTINE expand_list_int64 + + !-------------------------------------------------- + SUBROUTINE expand_list_real8 (list, percent) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), allocatable, intent(inout) :: list (:) + real(r8), intent(in) :: percent + + ! Local variables + integer :: n0, n1 + real(r8), allocatable :: temp (:) + + n0 = size(list) + + allocate (temp(n0)) + temp = list + + n1 = ceiling(n0 * (1+percent)) + + deallocate(list) + allocate (list(n1)) + list(1:n0) = temp + + deallocate (temp) + + END SUBROUTINE expand_list_real8 + + !-------------------------------------------------- + SUBROUTINE append_to_list (list1, list2) + + IMPLICIT NONE + + integer, allocatable, intent(inout) :: list1 (:) + integer, intent(in) :: list2 (:) + + ! Local variables + integer :: n1, n2 + integer, allocatable :: temp (:) + + IF (.not. allocated(list1)) THEN + n1 = 0 + ELSE + n1 = size(list1) + ENDIF + + n2 = size(list2) + + IF (n1 > 0) THEN + allocate (temp(n1)) + temp = list1 + + deallocate(list1) + allocate (list1(n1+n2)) + list1(1:n1) = temp + + deallocate (temp) + ELSE + IF (n2 > 0) allocate (list1(n2)) + ENDIF + + IF (n1 + n2 > 0) THEN + list1(n1+1:n1+n2) = list2 + ENDIF + + END SUBROUTINE append_to_list + + !-------------------------------------------------- + SUBROUTINE insert_into_sorted_list1_int32 (x, n, list, iloc, is_new_out) + + IMPLICIT NONE + + integer, intent(in) :: x + integer, intent(inout) :: n + integer, intent(inout) :: list(:) + integer, intent(out) :: iloc + logical, intent(out), optional :: is_new_out + + ! Local variables + logical :: is_new + integer :: ileft, iright + + IF (n == 0) THEN + iloc = 1 + is_new = .true. + ELSEIF (x <= list(1)) THEN + iloc = 1 + is_new = (x /= list(1)) + ELSEIF (x > list(n)) THEN + iloc = n + 1 + is_new = .true. + ELSEIF (x == list(n)) THEN + iloc = n + is_new = .false. + ELSE + ileft = 1 + iright = n + + DO WHILE (.true.) + IF (iright - ileft > 1) THEN + iloc = (ileft + iright) / 2 + IF (x > list(iloc)) THEN + ileft = iloc + ELSEIF (x < list(iloc)) THEN + iright = iloc + ELSE + is_new = .false. + EXIT + ENDIF + ELSE + iloc = iright + is_new = .true. + EXIT + ENDIF + ENDDO + ENDIF + + IF (is_new) THEN + IF (iloc <= n) THEN + list(iloc+1:n+1) = list(iloc:n) + ENDIF + + list(iloc) = x + n = n + 1 + ENDIF + + IF (present(is_new_out)) THEN + is_new_out = is_new + ENDIF + + END SUBROUTINE insert_into_sorted_list1_int32 + + !-------------------------------------------------- + SUBROUTINE insert_into_sorted_list1_int64 (x, n, list, iloc, is_new_out) + + IMPLICIT NONE + + integer*8, intent(in) :: x + integer, intent(inout) :: n + integer*8, intent(inout) :: list(:) + integer, intent(out) :: iloc + logical, intent(out), optional :: is_new_out + + ! Local variables + logical :: is_new + integer :: ileft, iright + + IF (n == 0) THEN + iloc = 1 + is_new = .true. + ELSEIF (x <= list(1)) THEN + iloc = 1 + is_new = (x /= list(1)) + ELSEIF (x > list(n)) THEN + iloc = n + 1 + is_new = .true. + ELSEIF (x == list(n)) THEN + iloc = n + is_new = .false. + ELSE + ileft = 1 + iright = n + + DO WHILE (.true.) + IF (iright - ileft > 1) THEN + iloc = (ileft + iright) / 2 + IF (x > list(iloc)) THEN + ileft = iloc + ELSEIF (x < list(iloc)) THEN + iright = iloc + ELSE + is_new = .false. + EXIT + ENDIF + ELSE + iloc = iright + is_new = .true. + EXIT + ENDIF + ENDDO + ENDIF + + IF (is_new) THEN + IF (iloc <= n) THEN + list(iloc+1:n+1) = list(iloc:n) + ENDIF + + list(iloc) = x + n = n + 1 + ENDIF + + IF (present(is_new_out)) THEN + is_new_out = is_new + ENDIF + + END SUBROUTINE insert_into_sorted_list1_int64 + + !-------------------------------------------------- + SUBROUTINE insert_into_sorted_list2 (x, y, n, xlist, ylist, iloc, is_new_out) + + IMPLICIT NONE + + integer, intent(in) :: x, y + integer, intent(inout) :: n + integer, intent(inout) :: xlist(:), ylist(:) + integer, intent(out) :: iloc + logical, intent(out), optional :: is_new_out + + ! Local variables + logical :: is_new + integer :: ileft, iright + + IF (n == 0) THEN + iloc = 1 + is_new = .true. + ELSEIF ((y < ylist(1)) .or. ((y == ylist(1)) .and. (x <= xlist(1)))) THEN + iloc = 1 + is_new = (x /= xlist(1)) .or. (y /= ylist(1)) + ELSEIF ((y > ylist(n)) .or. ((y == ylist(n)) .and. (x > xlist(n)))) THEN + iloc = n + 1 + is_new = .true. + ELSEIF ((x == xlist(n)) .and. (y == ylist(n))) THEN + iloc = n + is_new = .false. + ELSE + ileft = 1 + iright = n + + DO WHILE (.true.) + IF (iright - ileft > 1) THEN + iloc = (ileft + iright) / 2 + IF ((y > ylist(iloc)) .or. ((y == ylist(iloc)) .and. (x > xlist(iloc)))) THEN + ileft = iloc + ELSEIF ((y < ylist(iloc)) .or. ((y == ylist(iloc)) .and. (x < xlist(iloc)))) THEN + iright = iloc + ELSE + is_new = .false. + EXIT + ENDIF + ELSE + iloc = iright + is_new = .true. + EXIT + ENDIF + ENDDO + ENDIF + + IF (is_new) THEN + IF (iloc <= n) THEN + xlist(iloc+1:n+1) = xlist(iloc:n) + ylist(iloc+1:n+1) = ylist(iloc:n) + ENDIF + + xlist(iloc) = x + ylist(iloc) = y + n = n + 1 + ENDIF + + IF (present(is_new_out)) THEN + is_new_out = is_new + ENDIF + + END SUBROUTINE insert_into_sorted_list2 + + !-------------------------------------------------- + FUNCTION find_in_sorted_list1_int32 (x, n, list) result(iloc) + + IMPLICIT NONE + + integer :: iloc + + integer, intent(in) :: x + integer, intent(in) :: n + integer, intent(in) :: list (n) + + ! Local variables + integer :: i, ileft, iright + + iloc = 0 + IF (n > 0) THEN + IF ((x >= list(1)) .and. (x <= list(n))) THEN + IF (x == list(1)) THEN + iloc = 1 + ELSEIF (x == list(n)) THEN + iloc = n + ELSE + ileft = 1 + iright = n + + DO WHILE (iright - ileft > 1) + i = (ileft + iright) / 2 + IF (x == list(i)) THEN + iloc = i + EXIT + ELSEIF (x > list(i)) THEN + ileft = i + ELSEIF (x < list(i)) THEN + iright = i + ENDIF + ENDDO + ENDIF + ENDIF + ENDIF + + END FUNCTION find_in_sorted_list1_int32 + + !-------------------------------------------------- + FUNCTION find_in_sorted_list1_int64 (x, n, list) result(iloc) + + IMPLICIT NONE + + integer :: iloc + + integer*8, intent(in) :: x + integer, intent(in) :: n + integer*8, intent(in) :: list (n) + + ! Local variables + integer :: i, ileft, iright + + iloc = 0 + IF (n > 0) THEN + IF ((x >= list(1)) .and. (x <= list(n))) THEN + IF (x == list(1)) THEN + iloc = 1 + ELSEIF (x == list(n)) THEN + iloc = n + ELSE + ileft = 1 + iright = n + + DO WHILE (iright - ileft > 1) + i = (ileft + iright) / 2 + IF (x == list(i)) THEN + iloc = i + EXIT + ELSEIF (x > list(i)) THEN + ileft = i + ELSEIF (x < list(i)) THEN + iright = i + ENDIF + ENDDO + ENDIF + ENDIF + ENDIF + + END FUNCTION find_in_sorted_list1_int64 + + !-------------------------------------------------- + FUNCTION find_in_sorted_list2 (x, y, n, xlist, ylist) result(iloc) + + IMPLICIT NONE + + integer :: iloc + + integer, intent(in) :: x, y + integer, intent(in) :: n + integer, intent(in) :: xlist(:), ylist(:) + + ! Local variables + integer :: i, ileft, iright + + iloc = 0 + IF (n < 1) RETURN + + IF ((y < ylist(1)) .or. ((y == ylist(1)) .and. (x < xlist(1)))) THEN + iloc = 0 + ELSEIF ((y > ylist(n)) .or. ((y == ylist(n)) .and. (x > xlist(n)))) THEN + iloc = 0 + ELSEIF ((x == xlist(1)) .and. (y == ylist(1))) THEN + iloc = 1 + ELSEIF ((x == xlist(n)) .and. (y == ylist(n))) THEN + iloc = n + ELSE + ileft = 1 + iright = n + + DO WHILE (.true.) + IF (iright - ileft > 1) THEN + i = (ileft + iright) / 2 + IF ((y == ylist(i)) .and. (x == xlist(i))) THEN + iloc = i + EXIT + ELSEIF ((y > ylist(i)) .or. ((y == ylist(i)) .and. (x > xlist(i)))) THEN + ileft = i + ELSEIF ((y < ylist(i)) .or. ((y == ylist(i)) .and. (x < xlist(i)))) THEN + iright = i + ENDIF + ELSE + iloc = 0 + EXIT + ENDIF + ENDDO + ENDIF + + END FUNCTION find_in_sorted_list2 + + !----------------------------------------------------- + FUNCTION find_nearest_south (y, n, lat) result(iloc) + + USE MOD_Precision + IMPLICIT NONE + + integer :: iloc + + real(r8), intent(in) :: y + integer, intent(in) :: n + real(r8), intent(in) :: lat (n) + + ! Local variables + integer :: i, iright, ileft + + IF (lat(1) < lat(n)) THEN + IF (y <= lat(1)) THEN + iloc = 1 + ELSEIF (y >= lat(n)) THEN + iloc = n + ELSE + ileft = 1; iright = n + + DO WHILE (iright - ileft > 1) + i = (iright + ileft) / 2 + IF (y >= lat(i)) THEN + ileft = i + ELSE + iright = i + ENDIF + ENDDO + + iloc = ileft + ENDIF + ELSE + IF (y >= lat(1)) THEN + iloc = 1 + ELSEIF (y <= lat(n)) THEN + iloc = n + ELSE + ileft = 1; iright = n + + DO WHILE (iright - ileft > 1) + i = (iright + ileft) / 2 + IF (y >= lat(i)) THEN + iright = i + ELSE + ileft = i + ENDIF + ENDDO + + iloc = iright + ENDIF + ENDIF + + END FUNCTION find_nearest_south + + !----------------------------------------------------- + FUNCTION find_nearest_north (y, n, lat) result(iloc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: y + integer, intent(in) :: n + real(r8), intent(in) :: lat (n) + + integer :: iloc + + ! Local variables + integer :: i, iright, ileft + + IF (lat(1) < lat(n)) THEN + IF (y <= lat(1)) THEN + iloc = 1 + ELSEIF (y >= lat(n)) THEN + iloc = n + ELSE + ileft = 1; iright = n + + DO WHILE (iright - ileft > 1) + i = (iright + ileft) / 2 + IF (y > lat(i)) THEN + ileft = i + ELSE + iright = i + ENDIF + ENDDO + + iloc = iright + ENDIF + ELSE + IF (y >= lat(1)) THEN + iloc = 1 + ELSEIF (y <= lat(n)) THEN + iloc = n + ELSE + ileft = 1; iright = n + + DO WHILE (iright - ileft > 1) + i = (iright + ileft) / 2 + IF (y > lat(i)) THEN + iright = i + ELSE + ileft = i + ENDIF + ENDDO + + iloc = ileft + ENDIF + ENDIF + + END FUNCTION find_nearest_north + + !----------------------------------------- + logical FUNCTION lon_between_floor (lon, west, east) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: lon, west, east ! [-180, 180) + + IF (west >= east) THEN + lon_between_floor = (lon >= west) .or. (lon < east) + ELSE + lon_between_floor = (lon >= west) .and. (lon < east) + ENDIF + + END FUNCTION lon_between_floor + + !----------------------------------------- + logical FUNCTION lon_between_ceil (lon, west, east) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: lon, west, east ! [-180, 180) + + IF (west >= east) THEN + lon_between_ceil = (lon > west) .or. (lon <= east) + ELSE + lon_between_ceil = (lon > west) .and. (lon <= east) + ENDIF + + END FUNCTION lon_between_ceil + + !----------------------------------------------------- + FUNCTION find_nearest_west (x, n, lon) result(iloc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: x + integer, intent(in) :: n + real(r8), intent(in) :: lon (n) + + integer :: iloc + + ! Local variables + integer :: i, iright, ileft + + IF (n == 1) THEN + iloc = 1 + RETURN + ENDIF + + IF (lon_between_floor (x, lon(n), lon(1))) THEN + iloc = n + RETURN + ENDIF + + ileft = 1; iright = n + DO WHILE (iright - ileft > 1) + i = (iright + ileft)/2 + IF (lon_between_floor(x,lon(i),lon(iright))) THEN + ileft = i + ELSE + iright = i + ENDIF + ENDDO + + iloc = ileft + + END FUNCTION find_nearest_west + + !----------------------------------------------------- + FUNCTION find_nearest_east (x, n, lon) result(iloc) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: x + integer, intent(in) :: n + real(r8), intent(in) :: lon (n) + + integer :: iloc + + ! Local variables + integer :: i, iright, ileft + + IF (n == 1) THEN + iloc = 1 + RETURN + ENDIF + + IF (lon_between_ceil (x, lon(n), lon(1))) THEN + iloc = 1 + RETURN + ENDIF + + ileft = 1; iright = n + DO WHILE (iright - ileft > 1) + i = (iright + ileft)/2 + IF (lon_between_ceil(x,lon(i),lon(iright))) THEN + ileft = i + ELSE + iright = i + ENDIF + ENDDO + + iloc = iright + + END FUNCTION find_nearest_east + + + !----------------------------------------------------- + recursive SUBROUTINE quicksort_int32 (nA, A, order) + + USE MOD_Precision + IMPLICIT NONE + + integer, intent(in) :: nA + integer, intent(inout) :: A (nA) + integer, intent(inout) :: order (nA) + + ! Local variables + integer :: left, right + integer :: pivot + integer :: marker + integer :: itemp + + IF (nA > 1) THEN + + pivot = A (nA/2) + left = 0 + right = nA + 1 + + DO WHILE (left < right) + right = right - 1 + DO WHILE (A(right) > pivot) + right = right - 1 + ENDDO + + left = left + 1 + DO WHILE (A(left) < pivot) + left = left + 1 + ENDDO + + IF (left < right) THEN + itemp = A(left) + A(left) = A(right) + A(right) = itemp + + itemp = order(left) + order(left) = order(right) + order(right) = itemp + ENDIF + ENDDO + + marker = right + + CALL quicksort_int32 (marker, A(1:marker), order(1:marker)) + CALL quicksort_int32 (nA-marker, A(marker+1:nA), order(marker+1:nA)) + + ENDIF + + END SUBROUTINE quicksort_int32 + + !----------------------------------------------------- + recursive SUBROUTINE quicksort_int64 (nA, A, order) + + USE MOD_Precision + IMPLICIT NONE + + integer, intent(in) :: nA + integer*8, intent(inout) :: A (nA) + integer, intent(inout) :: order (nA) + + ! Local variables + integer*8 :: left, right, pivot, itemp + integer :: marker + + IF (nA > 1) THEN + + pivot = A (nA/2) + left = 0 + right = nA + 1 + + DO WHILE (left < right) + right = right - 1 + DO WHILE (A(right) > pivot) + right = right - 1 + ENDDO + + left = left + 1 + DO WHILE (A(left) < pivot) + left = left + 1 + ENDDO + + IF (left < right) THEN + itemp = A(left) + A(left) = A(right) + A(right) = itemp + + itemp = order(left) + order(left) = order(right) + order(right) = itemp + ENDIF + ENDDO + + marker = right + + CALL quicksort_int64 (marker, A(1:marker), order(1:marker)) + CALL quicksort_int64 (nA-marker, A(marker+1:nA), order(marker+1:nA)) + + ENDIF + + END SUBROUTINE quicksort_int64 + + !----------------------------------------------------- + recursive SUBROUTINE quicksort_real8 (nA, A, order) + + USE MOD_Precision + IMPLICIT NONE + + integer, intent(in) :: nA + real(r8), intent(inout) :: A (nA) + integer, intent(inout) :: order (nA) + + ! Local variables + real(r8) :: pivot, temp + integer :: left, right, marker, itemp + + IF (nA > 1) THEN + + pivot = A (nA/2) + left = 0 + right = nA + 1 + + DO WHILE (left < right) + right = right - 1 + DO WHILE (A(right) > pivot) + right = right - 1 + ENDDO + + left = left + 1 + DO WHILE (A(left) < pivot) + left = left + 1 + ENDDO + + IF (left < right) THEN + temp = A(left) + A(left) = A(right) + A(right) = temp + + itemp = order(left) + order(left) = order(right) + order(right) = itemp + ENDIF + ENDDO + + marker = right + + CALL quicksort_real8 (marker, A(1:marker), order(1:marker)) + CALL quicksort_real8 (nA-marker, A(marker+1:nA), order(marker+1:nA)) + + ENDIF + + END SUBROUTINE quicksort_real8 + + !----------------------------------------------------- + recursive FUNCTION quickselect (nA, A, k) result(selected) + + USE MOD_Precision + IMPLICIT NONE + + real(r8) :: selected + + integer , intent(in) :: nA + real(r8), intent(inout) :: A (nA) + integer, intent(in) :: k + + ! Local variables + integer :: left, right + real(r8) :: pivot + integer :: marker + real(r8) :: rtemp + + IF (nA > 1) THEN + + pivot = A (nA/2) + left = 0 + right = nA + 1 + + DO WHILE (left < right) + right = right - 1 + DO WHILE (A(right) > pivot) + right = right - 1 + ENDDO + + left = left + 1 + DO WHILE (A(left) < pivot) + left = left + 1 + ENDDO + + IF (left < right) THEN + rtemp = A(left) + A(left) = A(right) + A(right) = rtemp + ENDIF + ENDDO + + marker = right + + IF (k <= marker) THEN + selected = quickselect (marker, A(1:marker), k) + ELSE + selected = quickselect (nA-marker, A(marker+1:nA), k-marker) + ENDIF + + ELSE + selected = A(1) + ENDIF + + END FUNCTION quickselect + + + ! ------------------------ + FUNCTION median(x, n, spval) result(mval) + + USE MOD_Precision + IMPLICIT NONE + + real(r8) :: mval + + integer, intent(in) :: n + real(r8), intent(in) :: x(n) + real(r8), intent(in), optional :: spval + + ! Local variables + integer :: nc + real(r8), allocatable :: xtemp(:) + logical, allocatable :: msk (:) + real(r8) :: right, left + + IF (present(spval)) THEN + allocate (msk (n)) + msk = (x /= spval) + nc = count(msk) + IF (nc /= 0) THEN + + allocate (xtemp(nc)) + xtemp = pack(x, msk) + + deallocate (msk) + ELSE + + mval = spval + + deallocate(msk) + RETURN + ENDIF + ELSE + nc = n + allocate (xtemp(nc)) + xtemp = x + ENDIF + + IF (mod(nc,2) == 0) THEN + left = quickselect(nc,xtemp,nc/2) + right = quickselect(nc,xtemp,nc/2+1) + mval = (left + right) / 2.0_r8 + ELSE + mval = quickselect(nc,xtemp,nc/2+1) + ENDIF + + deallocate (xtemp) + + END FUNCTION median + + + !----------------------------------------------------- + FUNCTION areaquad (lats, latn, lonw, lone) result(area) + + USE MOD_Precision + IMPLICIT NONE + + real(r8) :: area ! in km^2 + real(r8), parameter :: re = 6.37122e3 ! kilometer + real(r8), parameter :: deg2rad = 1.745329251994330e-2_r8 + real(r8), intent(in) :: lats, latn, lonw, lone + + ! Local variables + real(r8) :: dx, dy + + IF (lone < lonw) THEN + dx = (lone + 360 - lonw) * deg2rad + ELSE + dx = (lone - lonw) * deg2rad + ENDIF + + dy = sin(latn * deg2rad) - sin(lats * deg2rad) + + area = dx * dy * re * re + + END FUNCTION areaquad + + ! --- spherical distance --- + FUNCTION arclen (lat1, lon1, lat2, lon2) + + USE MOD_Precision + IMPLICIT NONE + + real(r8) :: arclen ! in km + real(r8), intent(in) :: lat1, lon1, lat2, lon2 + + real(r8), parameter :: re = 6.37122e3 ! kilometer + real(r8) :: tmp + + tmp = sin(lat1)*sin(lat2) + cos(lat1)*cos(lat2) * cos(lon1-lon2) + tmp = min(max(tmp, -1.), 1.) + arclen = re * acos(tmp) + + END FUNCTION arclen + + !----------------------------------------------------- + SUBROUTINE unpack_inplace_int32 (din, msk, dout) + + IMPLICIT NONE + + integer, intent(in) :: din (:) + logical, intent(in) :: msk (:) + integer, intent(inout) :: dout (:) + + ! Local variables + integer :: n, i + + n = 0 + DO i = 1, size(msk) + IF (msk(i)) THEN + n = n + 1 + dout(i) = din(n) + ENDIF + ENDDO + + END SUBROUTINE unpack_inplace_int32 + + !----------------------------------------------------- + SUBROUTINE unpack_inplace_real8 (din, msk, dout) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: din (:) + logical, intent(in) :: msk (:) + real(r8), intent(inout) :: dout (:) + + ! Local variables + integer :: n, i + + n = 0 + DO i = 1, size(msk) + IF (msk(i)) THEN + n = n + 1 + dout(i) = din(n) + ENDIF + ENDDO + + END SUBROUTINE unpack_inplace_real8 + + !----------------------------------------------------- + SUBROUTINE unpack_inplace_lastdim_real8 (din, msk, dout) + + USE MOD_Precision + IMPLICIT NONE + + real(r8), intent(in) :: din (:,:) + logical, intent(in) :: msk (:) + real(r8), intent(inout) :: dout (:,:) + + ! Local variables + integer :: n, i + + n = 0 + DO i = 1, size(msk) + IF (msk(i)) THEN + n = n + 1 + dout(:,i) = din(:,n) + ENDIF + ENDDO + + END SUBROUTINE unpack_inplace_lastdim_real8 + + !--------------------------------------------------- + integer FUNCTION num_max_frequency (data_in) + + IMPLICIT NONE + + integer, intent(in) :: data_in(:) + + ! Local Variables + integer, allocatable :: data_(:), cnts(:) + integer :: ndata, i, n, iloc + logical :: is_new + + ndata = size(data_in) + allocate (data_(ndata)) + allocate (cnts (ndata)) + + n = 0 + cnts(:) = 0 + DO i = 1, ndata + CALL insert_into_sorted_list1 (data_in(i), n, data_, iloc, is_new) + IF (is_new) THEN + IF (iloc < n) cnts(iloc+1:ndata) = cnts(iloc:ndata-1) + cnts(iloc) = 1 + ELSE + cnts(iloc) = cnts(iloc) + 1 + ENDIF + ENDDO + + num_max_frequency = data_(maxloc(cnts,dim=1)) + + deallocate(data_) + deallocate(cnts ) + + END FUNCTION num_max_frequency + + !---------------------------------------------------- + SUBROUTINE lmder ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, & + diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf, xdat, npoint, ydat, & + ydatks, nptf, phi, k_s, isiter, L_vgm) + + !******************************************************************************* + ! + !! LMDER minimizes M functions in N variables by the Levenberg-Marquardt method + ! implemented for fitting the SW retention & hydraulic conductivity parameters + ! in the Campbell/van Genuchten models. + ! + ! Discussion: + ! + ! LMDER minimizes the sum of the squares of M nonlinear functions in + ! N variables by a modification of the Levenberg-Marquardt algorithm. + ! The user must provide a subroutine which calculates the functions + ! and the jacobian. + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 06 April 2010 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! Modified by Nan Wei, 2019/01 + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, external FCN, the name of the user-supplied subroutine which + ! calculates the functions and the jacobian. FCN should have the form: + ! subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ! integer ( kind = 4 ) ldfjac + ! integer ( kind = 4 ) n + ! real ( kind = 8 ) fjac(ldfjac,n) + ! real ( kind = 8 ) fvec(m) + ! integer ( kind = 4 ) iflag + ! real ( kind = 8 ) x(n) + ! xdat, npoint, ydat, ydatks, nptf, phi, k_s and isiter are transfered as the inputs of the fitting functions. + ! L_vgm are only used for vanGenuchten_Mualem soil model input. + ! + ! If IFLAG = 0 on input, then FCN is only being called to allow the user + ! to print out the current iterate. + ! If IFLAG = 1 on input, FCN should calculate the functions at X and + ! return this vector in FVEC. + ! If IFLAG = 2 on input, FCN should calculate the jacobian at X and + ! return this matrix in FJAC. + ! To terminate the algorithm, FCN may set IFLAG negative on return. + ! + ! Input, integer ( kind = 4 ) M, is the number of functions. + ! + ! Input, integer ( kind = 4 ) N, is the number of variables. + ! N must not exceed M. + ! + ! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial + ! estimate of the solution vector. On output X contains the final + ! estimate of the solution vector. + ! + ! Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X. + ! + ! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array. The upper + ! N by N submatrix of FJAC contains an upper triangular matrix R with + ! diagonal elements of nonincreasing magnitude such that + ! P' * ( JAC' * JAC ) * P = R' * R, + ! where P is a permutation matrix and JAC is the final calculated jacobian. + ! Column J of P is column IPVT(J) of the identity matrix. The lower + ! trapezoidal part of FJAC contains information generated during + ! the computation of R. + ! + ! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC. + ! LDFJAC must be at least M. + ! + ! Input, real ( kind = 8 ) FTOL. Termination occurs when both the actual + ! and predicted relative reductions in the sum of squares are at most FTOL. + ! Therefore, FTOL measures the relative error desired in the sum of + ! squares. FTOL should be nonnegative. + ! + ! Input, real ( kind = 8 ) XTOL. Termination occurs when the relative error + ! between two consecutive iterates is at most XTOL. XTOL should be + ! nonnegative. + ! + ! Input, real ( kind = 8 ) GTOL. Termination occurs when the cosine of the + ! angle between FVEC and any column of the jacobian is at most GTOL in + ! absolute value. Therefore, GTOL measures the orthogonality desired + ! between the function vector and the columns of the jacobian. GTOL should + ! be nonnegative. + ! + ! Input, integer ( kind = 4 ) MAXFEV. Termination occurs when the number of + ! calls to FCN with IFLAG = 1 is at least MAXFEV by the end of an iteration. + ! + ! Input/output, real ( kind = 8 ) DIAG(N). If MODE = 1, then DIAG is set + ! internally. If MODE = 2, then DIAG must contain positive entries that + ! serve as multiplicative scale factors for the variables. + ! + ! Input, integer ( kind = 4 ) MODE, scaling option. + ! 1, variables will be scaled internally. + ! 2, scaling is specified by the input DIAG vector. + ! + ! Input, real ( kind = 8 ) FACTOR, determines the initial step bound. This + ! bound is set to the product of FACTOR and the euclidean norm of DIAG*X if + ! nonzero, or else to FACTOR itself. In most cases, FACTOR should lie + ! in the interval (0.1, 100) with 100 the recommended value. + ! + ! Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates + ! if it is positive. In this case, FCN is called with IFLAG = 0 at the + ! beginning of the first iteration and every NPRINT iterations thereafter + ! and immediately prior to return, with X and FVEC available + ! for printing. If NPRINT is not positive, no special calls + ! of FCN with IFLAG = 0 are made. + ! + ! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated + ! execution, INFO is set to the (negative) value of IFLAG. See description + ! of FCN. Otherwise, INFO is set as follows: + ! 0, improper input parameters. + ! 1, both actual and predicted relative reductions in the sum of + ! squares are at most FTOL. + ! 2, relative error between two consecutive iterates is at most XTOL. + ! 3, conditions for INFO = 1 and INFO = 2 both hold. + ! 4, the cosine of the angle between FVEC and any column of the jacobian + ! is at most GTOL in absolute value. + ! 5, number of calls to FCN with IFLAG = 1 has reached MAXFEV. + ! 6, FTOL is too small. No further reduction in the sum of squares + ! is possible. + ! 7, XTOL is too small. No further improvement in the approximate + ! solution X is possible. + ! 8, GTOL is too small. FVEC is orthogonal to the columns of the + ! jacobian to machine precision. + ! + ! Output, integer ( kind = 4 ) NFEV, the number of calls to FCN with + ! IFLAG = 1. + ! + ! Output, integer ( kind = 4 ) NJEV, the number of calls to FCN with + ! IFLAG = 2. + ! + ! Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P + ! such that JAC*P = Q*R, where JAC is the final calculated jacobian, Q is + ! orthogonal (not stored), and R is upper triangular with diagonal + ! elements of nonincreasing magnitude. Column J of P is column + ! IPVT(J) of the identity matrix. + ! + ! Output, real ( kind = 8 ) QTF(N), contains the first N elements of Q'*FVEC. + ! + IMPLICIT NONE + + integer ( kind = 4 ) ldfjac + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + real ( kind = 8 ) actred + real ( kind = 8 ) delta + real ( kind = 8 ) diag(n) + real ( kind = 8 ) dirder + real ( kind = 8 ) epsmch + real ( kind = 8 ) factor + external fcn + real ( kind = 8 ) fjac(ldfjac,n) + real ( kind = 8 ) fnorm + real ( kind = 8 ) fnorm1 + real ( kind = 8 ) ftol + real ( kind = 8 ) fvec(m) + real ( kind = 8 ) gnorm + real ( kind = 8 ) gtol + integer ( kind = 4 ) i + integer ( kind = 4 ) iflag + integer ( kind = 4 ) info + integer ( kind = 4 ) ipvt(n) + integer ( kind = 4 ) iter + integer ( kind = 4 ) j + integer ( kind = 4 ) l + integer ( kind = 4 ) maxfev + integer ( kind = 4 ) mode + integer ( kind = 4 ) nfev + integer ( kind = 4 ) njev + integer ( kind = 4 ) nprint + real ( kind = 8 ) par + logical pivot + real ( kind = 8 ) pnorm + real ( kind = 8 ) prered + real ( kind = 8 ) qtf(n) + real ( kind = 8 ) ratio + real ( kind = 8 ) sum2 + real ( kind = 8 ) temp + real ( kind = 8 ) temp1 + real ( kind = 8 ) temp2 + real ( kind = 8 ) wa1(n) + real ( kind = 8 ) wa2(n) + real ( kind = 8 ) wa3(n) + real ( kind = 8 ) wa4(m) + real ( kind = 8 ) xnorm + real ( kind = 8 ) x(n) + real ( kind = 8 ) xtol + real ( kind = 8 ) phi,k_s + integer ( kind = 4 ) isiter + integer ( kind = 4 ) npoint + integer ( kind = 4 ) nptf + real ( kind = 8 ) xdat(npoint) + real ( kind = 8 ) ydat (nptf,npoint) + real ( kind = 8 ) ydatks(nptf,npoint) + real ( kind = 8 ), optional :: L_vgm + + epsmch = epsilon ( epsmch ) + + info = 0 + iflag = 0 + nfev = 0 + njev = 0 + ! + ! Check the input parameters for errors. + ! + IF ( n <= 0 ) THEN + go to 300 + ENDIF + + IF ( m < n ) THEN + go to 300 + ENDIF + + IF ( ldfjac < m & + .or. ftol < 0.0D+00 .or. xtol < 0.0D+00 .or. gtol < 0.0D+00 & + .or. maxfev <= 0 .or. factor <= 0.0D+00 ) THEN + go to 300 + ENDIF + + IF ( mode == 2 ) THEN + DO j = 1, n + IF ( diag(j) <= 0.0D+00 ) THEN + go to 300 + ENDIF + ENDDO + ENDIF + ! + ! Evaluate the function at the starting point and calculate its norm. + ! + iflag = 1 + IF (present(L_vgm)) THEN + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + nfev = 1 + IF ( iflag < 0 ) THEN + go to 300 + ENDIF + + fnorm = enorm ( m, fvec ) + ! + ! Initialize Levenberg-Marquardt parameter and iteration counter. + ! + par = 0.0D+00 + iter = 1 + ! + ! Beginning of the outer loop. + ! + DO + ! + ! Calculate the jacobian matrix. + ! + iflag = 2 + IF (present(L_vgm)) THEN + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + + njev = njev + 1 + + IF ( iflag < 0 ) THEN + go to 300 + ENDIF + ! + ! IF requested, call FCN to enable printing of iterates. + ! + IF ( 0 < nprint ) THEN + iflag = 0 + IF ( mod ( iter - 1, nprint ) == 0 ) THEN + IF (present(L_vgm)) THEN + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + ENDIF + IF ( iflag < 0 ) THEN + go to 300 + ENDIF + ENDIF + ! + ! Compute the QR factorization of the jacobian. + ! + pivot = .true. + CALL qrfac ( m, n, fjac, ldfjac, pivot, ipvt, n, wa1, wa2 ) + + ! On the first iteration and if mode is 1, scale according + ! to the norms of the columns of the initial jacobian. + ! + IF ( iter == 1 ) THEN + + IF ( mode /= 2 ) THEN + diag(1:n) = wa2(1:n) + DO j = 1, n + IF ( wa2(j) == 0.0D+00 ) THEN + diag(j) = 1.0D+00 + ENDIF + ENDDO + ENDIF + ! + ! On the first iteration, calculate the norm of the scaled X + ! and initialize the step bound DELTA. + ! + wa3(1:n) = diag(1:n) * x(1:n) + + xnorm = enorm ( n, wa3 ) + + IF ( xnorm == 0.0D+00 ) THEN + delta = factor + ELSE + delta = factor * xnorm + ENDIF + + ENDIF + ! + ! Form Q'*FVEC and store the first N components in QTF. + ! + wa4(1:m) = fvec(1:m) + + DO j = 1, n + + IF ( fjac(j,j) /= 0.0D+00 ) THEN + sum2 = dot_product ( wa4(j:m), fjac(j:m,j) ) + temp = - sum2 / fjac(j,j) + wa4(j:m) = wa4(j:m) + fjac(j:m,j) * temp + ENDIF + + fjac(j,j) = wa1(j) + qtf(j) = wa4(j) + + ENDDO + ! + ! Compute the norm of the scaled gradient. + ! + gnorm = 0.0D+00 + + IF ( fnorm /= 0.0D+00 ) THEN + + DO j = 1, n + l = ipvt(j) + IF ( wa2(l) /= 0.0D+00 ) THEN + sum2 = dot_product ( qtf(1:j), fjac(1:j,j) ) / fnorm + gnorm = max ( gnorm, abs ( sum2 / wa2(l) ) ) + ENDIF + ENDDO + + ENDIF + ! + ! Test for convergence of the gradient norm. + ! + IF ( gnorm <= gtol ) THEN + info = 4 + go to 300 + ENDIF + ! + ! Rescale if necessary. + ! + IF ( mode /= 2 ) THEN + DO j = 1, n + diag(j) = max ( diag(j), wa2(j) ) + ENDDO + ENDIF + ! + ! Beginning of the inner loop. + ! + DO + ! + ! Determine the Levenberg-Marquardt parameter. + + CALL lmpar ( n, fjac, ldfjac, ipvt, diag, qtf, delta, par, wa1, wa2 ) + + ! Store the direction p and x + p. calculate the norm of p. + ! + wa1(1:n) = - wa1(1:n) + wa2(1:n) = x(1:n) + wa1(1:n) + wa3(1:n) = diag(1:n) * wa1(1:n) + + pnorm = enorm ( n, wa3 ) + ! + ! On the first iteration, adjust the initial step bound. + ! + IF ( iter == 1 ) THEN + delta = min ( delta, pnorm ) + ENDIF + ! + ! Evaluate the function at x + p and calculate its norm. + ! + iflag = 1 + IF (present(L_vgm)) THEN + CALL fcn ( m, n, wa2, wa4, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, wa2, wa4, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + + nfev = nfev + 1 + + IF ( iflag < 0 ) THEN + go to 300 + ENDIF + + fnorm1 = enorm ( m, wa4 ) + ! + ! Compute the scaled actual reduction. + ! + IF ( 0.1D+00 * fnorm1 < fnorm ) THEN + actred = 1.0D+00 - ( fnorm1 / fnorm ) ** 2 + ELSE + actred = - 1.0D+00 + ENDIF + ! + ! Compute the scaled predicted reduction and + ! the scaled directional derivative. + ! + DO j = 1, n + wa3(j) = 0.0D+00 + l = ipvt(j) + temp = wa1(l) + wa3(1:j) = wa3(1:j) + fjac(1:j,j) * temp + ENDDO + + temp1 = enorm ( n, wa3 ) / fnorm + temp2 = ( sqrt ( par ) * pnorm ) / fnorm + prered = temp1 ** 2 + temp2 ** 2 / 0.5D+00 + dirder = - ( temp1 ** 2 + temp2 ** 2 ) + ! + ! Compute the ratio of the actual to the predicted reduction. + ! + IF ( prered /= 0.0D+00 ) THEN + ratio = actred / prered + ELSE + ratio = 0.0D+00 + ENDIF + ! + ! Update the step bound. + ! + IF ( ratio <= 0.25D+00 ) THEN + + IF ( 0.0D+00 <= actred ) THEN + temp = 0.5D+00 + ENDIF + + IF ( actred < 0.0D+00 ) THEN + temp = 0.5D+00 * dirder / ( dirder + 0.5D+00 * actred ) + ENDIF + + IF ( 0.1D+00 * fnorm1 >= fnorm .or. temp < 0.1D+00 ) THEN + temp = 0.1D+00 + ENDIF + + delta = temp * min ( delta, pnorm / 0.1D+00 ) + par = par / temp + + ELSE + + IF ( par == 0.0D+00 .or. ratio >= 0.75D+00 ) THEN + delta = 2.0D+00 * pnorm + par = 0.5D+00 * par + ENDIF + + ENDIF + ! + ! Successful iteration. + ! + ! Update X, FVEC, and their norms. + ! + IF ( 0.0001D+00 <= ratio ) THEN + x(1:n) = wa2(1:n) + wa2(1:n) = diag(1:n) * x(1:n) + fvec(1:m) = wa4(1:m) + xnorm = enorm ( n, wa2 ) + fnorm = fnorm1 + iter = iter + 1 + ENDIF + ! + ! Tests for convergence. + ! + IF ( abs ( actred) <= ftol .and. & + prered <= ftol .and. & + 0.5D+00 * ratio <= 1.0D+00 ) THEN + info = 1 + ENDIF + + IF ( delta <= xtol * xnorm ) THEN + info = 2 + ENDIF + + IF ( abs ( actred) <= ftol .and. prered <= ftol & + .and. 0.5D+00 * ratio <= 1.0D+00 .and. info == 2 ) THEN + info = 3 + ENDIF + + IF ( info /= 0 ) THEN + go to 300 + ENDIF + ! + ! Tests for termination and stringent tolerances. + ! + IF ( nfev >= maxfev ) THEN + info = 5 + ENDIF + + IF ( abs ( actred ) <= epsmch .and. prered <= epsmch & + .and. 0.5D+00 * ratio <= 1.0D+00 ) THEN + info = 6 + ENDIF + + IF ( delta <= epsmch * xnorm ) THEN + info = 7 + ENDIF + + IF ( gnorm <= epsmch ) THEN + info = 8 + ENDIF + + IF ( info /= 0 ) THEN + go to 300 + ENDIF + ! + ! End of the inner loop. repeat IF iteration unsuccessful. + ! + IF ( 0.0001D+00 <= ratio ) THEN + EXIT + ENDIF + + ENDDO + ! + ! End of the outer loop. + ! + ENDDO + + 300 continue + ! + ! Termination, either normal or user imposed. + ! + IF ( iflag < 0 ) THEN + info = iflag + ENDIF + + iflag = 0 + + IF ( 0 < nprint ) THEN + IF (present(L_vgm)) THEN + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter, L_vgm) + ELSE + CALL fcn ( m, n, x, fvec, fjac, ldfjac, iflag, xdat, npoint, ydat, ydatks, nptf, phi, k_s, isiter ) + ENDIF + ENDIF + + RETURN + END SUBROUTINE lmder + + SUBROUTINE lmpar ( n, r, ldr, ipvt, diag, qtb, delta, par, x, sdiag ) + + !*****************************************************************************80 + ! + !! LMPAR computes a parameter for the Levenberg-Marquardt method. + ! + ! Discussion: + ! + ! Given an M by N matrix A, an N by N nonsingular diagonal + ! matrix D, an M-vector B, and a positive number DELTA, + ! the problem is to determine a value for the parameter + ! PAR such that IF X solves the system + ! + ! A*X = B, + ! sqrt ( PAR ) * D * X = 0, + ! + ! in the least squares sense, and DXNORM is the euclidean + ! norm of D*X, THEN either PAR is zero and + ! + ! ( DXNORM - DELTA ) <= 0.1 * DELTA, + ! + ! or PAR is positive and + ! + ! abs ( DXNORM - DELTA) <= 0.1 * DELTA. + ! + ! This FUNCTION completes the solution of the problem + ! IF it is provided with the necessary information from the + ! QR factorization, with column pivoting, of A. That is, IF + ! A*P = Q*R, WHERE P is a permutation matrix, Q has orthogonal + ! columns, and R is an upper triangular matrix with diagonal + ! elements of nonincreasing magnitude, THEN LMPAR expects + ! the full upper triangle of R, the permutation matrix P, + ! and the first N components of Q'*B. On output + ! LMPAR also provides an upper triangular matrix S such that + ! + ! P' * ( A' * A + PAR * D * D ) * P = S'* S. + ! + ! S is employed within LMPAR and may be of separate interest. + ! + ! Only a few iterations are generally needed for convergence + ! of the algorithm. + ! + ! IF, however, the limit of 10 iterations is reached, THEN the output + ! PAR will contain the best value obtained so far. + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 24 January 2014 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, the order of R. + ! + ! Input/output, real ( kind = 8 ) R(LDR,N),the N by N matrix. The full + ! upper triangle must contain the full upper triangle of the matrix R. + ! On output the full upper triangle is unaltered, and the strict lower + ! triangle CONTAINS the strict upper triangle (transposed) of the upper + ! triangular matrix S. + ! + ! Input, integer ( kind = 4 ) LDR, the leading dimension of R. LDR must be + ! no less than N. + ! + ! Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P + ! such that A*P = Q*R. Column J of P is column IPVT(J) of the + ! identity matrix. + ! + ! Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D. + ! + ! Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B. + ! + ! Input, real ( kind = 8 ) DELTA, an upper bound on the euclidean norm + ! of D*X. DELTA should be positive. + ! + ! Input/output, real ( kind = 8 ) PAR. On input an initial estimate of the + ! Levenberg-Marquardt parameter. On output the final estimate. + ! PAR should be nonnegative. + ! + ! Output, real ( kind = 8 ) X(N), the least squares solution of the system + ! A*X = B, sqrt(PAR)*D*X = 0, for the output value of PAR. + ! + ! Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper + ! triangular matrix S. + ! + IMPLICIT NONE + + integer ( kind = 4 ) ldr + integer ( kind = 4 ) n + + real ( kind = 8 ) delta + real ( kind = 8 ) diag(n) + real ( kind = 8 ) dwarf + real ( kind = 8 ) dxnorm + real ( kind = 8 ) gnorm + real ( kind = 8 ) fp + integer ( kind = 4 ) i + integer ( kind = 4 ) ipvt(n) + integer ( kind = 4 ) iter + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) l + integer ( kind = 4 ) nsing + real ( kind = 8 ) par + real ( kind = 8 ) parc + real ( kind = 8 ) parl + real ( kind = 8 ) paru + real ( kind = 8 ) qnorm + real ( kind = 8 ) qtb(n) + real ( kind = 8 ) r(ldr,n) + real ( kind = 8 ) sdiag(n) + real ( kind = 8 ) sum2 + real ( kind = 8 ) temp + real ( kind = 8 ) wa1(n) + real ( kind = 8 ) wa2(n) + real ( kind = 8 ) x(n) + + ! + ! DWARF is the smallest positive magnitude. + ! + dwarf = tiny ( dwarf ) + ! + ! Compute and store in X the Gauss-Newton direction. + ! + ! IF the jacobian is rank-deficient, obtain a least squares solution. + ! + nsing = n + + DO j = 1, n + wa1(j) = qtb(j) + IF ( r(j,j) == 0.0D+00 .and. nsing == n ) THEN + nsing = j - 1 + ENDIF + IF ( nsing < n ) THEN + wa1(j) = 0.0D+00 + ENDIF + ENDDO + + DO k = 1, nsing + j = nsing - k + 1 + wa1(j) = wa1(j) / r(j,j) + temp = wa1(j) + wa1(1:j-1) = wa1(1:j-1) - r(1:j-1,j) * temp + ENDDO + + DO j = 1, n + l = ipvt(j) + x(l) = wa1(j) + ENDDO + ! + ! Initialize the iteration counter. + ! Evaluate the FUNCTION at the origin, and test + ! for acceptance of the Gauss-Newton direction. + ! + iter = 0 + wa2(1:n) = diag(1:n) * x(1:n) + dxnorm = enorm ( n, wa2 ) + fp = dxnorm - delta + + IF ( fp <= 0.1D+00 * delta ) THEN + IF ( iter == 0 ) THEN + par = 0.0D+00 + ENDIF + RETURN + ENDIF + ! + ! IF the jacobian is not rank deficient, the Newton + ! step provides a lower bound, PARL, for the zero of + ! the FUNCTION. + ! + ! Otherwise set this bound to zero. + ! + parl = 0.0D+00 + + IF ( n <= nsing ) THEN + + DO j = 1, n + l = ipvt(j) + wa1(j) = diag(l) * ( wa2(l) / dxnorm ) + ENDDO + + DO j = 1, n + sum2 = dot_product ( wa1(1:j-1), r(1:j-1,j) ) + wa1(j) = ( wa1(j) - sum2 ) / r(j,j) + ENDDO + + temp = enorm ( n, wa1 ) + parl = ( ( fp / delta ) / temp ) / temp + + ENDIF + ! + ! Calculate an upper bound, PARU, for the zero of the FUNCTION. + ! + DO j = 1, n + sum2 = dot_product ( qtb(1:j), r(1:j,j) ) + l = ipvt(j) + wa1(j) = sum2 / diag(l) + ENDDO + + gnorm = enorm ( n, wa1 ) + paru = gnorm / delta + + IF ( paru == 0.0D+00 ) THEN + paru = dwarf / min ( delta, 0.1D+00 ) + ENDIF + ! + ! IF the input PAR lies outside of the interval (PARL, PARU), + ! set PAR to the closer endpoint. + ! + par = max ( par, parl ) + par = min ( par, paru ) + IF ( par == 0.0D+00 ) THEN + par = gnorm / dxnorm + ENDIF + ! + ! Beginning of an iteration. + ! + DO + + iter = iter + 1 + ! + ! Evaluate the FUNCTION at the current value of PAR. + ! + IF ( par == 0.0D+00 ) THEN + par = max ( dwarf, 0.001D+00 * paru ) + ENDIF + + wa1(1:n) = sqrt ( par ) * diag(1:n) + + CALL qrsolv ( n, r, ldr, ipvt, wa1, qtb, x, sdiag ) + + wa2(1:n) = diag(1:n) * x(1:n) + dxnorm = enorm ( n, wa2 ) + temp = fp + fp = dxnorm - delta + ! + ! IF the FUNCTION is small enough, accept the current value of PAR. + ! + IF ( abs ( fp ) <= 0.1D+00 * delta ) THEN + EXIT + ENDIF + ! + ! Test for the exceptional cases WHERE PARL + ! is zero or the number of iterations has reached 10. + ! + IF ( parl == 0.0D+00 .and. fp <= temp .and. temp < 0.0D+00 ) THEN + EXIT + ELSEIF ( iter == 10 ) THEN + EXIT + ENDIF + ! + ! Compute the Newton correction. + ! + DO j = 1, n + l = ipvt(j) + wa1(j) = diag(l) * ( wa2(l) / dxnorm ) + ENDDO + + DO j = 1, n + wa1(j) = wa1(j) / sdiag(j) + temp = wa1(j) + wa1(j+1:n) = wa1(j+1:n) - r(j+1:n,j) * temp + ENDDO + + temp = enorm ( n, wa1 ) + parc = ( ( fp / delta ) / temp ) / temp + ! + ! Depending on the sign of the FUNCTION, update PARL or PARU. + ! + IF ( 0.0D+00 < fp ) THEN + parl = max ( parl, par ) + ELSEIF ( fp < 0.0D+00 ) THEN + paru = min ( paru, par ) + ENDIF + ! + ! Compute an improved estimate for PAR. + ! + par = max ( parl, par + parc ) + ! + ! END of an iteration. + ! + ENDDO + ! + ! Termination. + ! + IF ( iter == 0 ) THEN + par = 0.0D+00 + ENDIF + + RETURN + + END SUBROUTINE lmpar + + SUBROUTINE qrfac ( m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm ) + + !*****************************************************************************80 + ! + !! QRFAC computes a QR factorization using Householder transformations. + ! + ! Discussion: + ! + ! This FUNCTION uses Householder transformations with optional column + ! pivoting to compute a QR factorization of the + ! M by N matrix A. That is, QRFAC determines an orthogonal + ! matrix Q, a permutation matrix P, and an upper trapezoidal + ! matrix R with diagonal elements of nonincreasing magnitude, + ! such that A*P = Q*R. + ! + ! The Householder transformation for column K, K = 1,2,...,min(M,N), + ! is of the form + ! + ! I - ( 1 / U(K) ) * U * U' + ! + ! WHERE U has zeros in the first K-1 positions. + ! + ! The form of this transformation and the method of pivoting first + ! appeared in the corresponding LINPACK routine. + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 06 April 2010 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) M, the number of rows of A. + ! + ! Input, integer ( kind = 4 ) N, the number of columns of A. + ! + ! Input/output, real ( kind = 8 ) A(LDA,N), the M by N array. + ! On input, A CONTAINS the matrix for which the QR factorization is to + ! be computed. On output, the strict upper trapezoidal part of A CONTAINS + ! the strict upper trapezoidal part of R, and the lower trapezoidal + ! part of A CONTAINS a factored form of Q, the non-trivial elements of + ! the U vectors described above. + ! + ! Input, integer ( kind = 4 ) LDA, the leading dimension of A, which must + ! be no less than M. + ! + ! Input, logical PIVOT, is TRUE IF column pivoting is to be carried out. + ! + ! Output, integer ( kind = 4 ) IPVT(LIPVT), defines the permutation matrix P + ! such that A*P = Q*R. Column J of P is column IPVT(J) of the identity + ! matrix. IF PIVOT is false, IPVT is not referenced. + ! + ! Input, integer ( kind = 4 ) LIPVT, the dimension of IPVT, which should + ! be N IF pivoting is used. + ! + ! Output, real ( kind = 8 ) RDIAG(N), CONTAINS the diagonal elements of R. + ! + ! Output, real ( kind = 8 ) ACNORM(N), the norms of the corresponding + ! columns of the input matrix A. IF this information is not needed, + ! THEN ACNORM can coincide with RDIAG. + ! + IMPLICIT NONE + + integer ( kind = 4 ) lda + integer ( kind = 4 ) lipvt + integer ( kind = 4 ) m + integer ( kind = 4 ) n + + real ( kind = 8 ) a(lda,n) + real ( kind = 8 ) acnorm(n) + real ( kind = 8 ) ajnorm + real ( kind = 8 ) epsmch + integer ( kind = 4 ) i + integer ( kind = 4 ) i4_temp + integer ( kind = 4 ) ipvt(lipvt) + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) kmax + integer ( kind = 4 ) minmn + logical pivot + real ( kind = 8 ) r8_temp(m) + real ( kind = 8 ) rdiag(n) + real ( kind = 8 ) temp + real ( kind = 8 ) wa(n) + + epsmch = epsilon ( epsmch ) + ! + ! Compute the initial column norms and initialize several arrays. + ! + DO j = 1, n + acnorm(j) = enorm ( m, a(1:m,j) ) + ENDDO + + rdiag(1:n) = acnorm(1:n) + wa(1:n) = acnorm(1:n) + + IF ( pivot ) THEN + DO j = 1, n + ipvt(j) = j + ENDDO + ENDIF + ! + ! Reduce A to R with Householder transformations. + ! + minmn = min ( m, n ) + + DO j = 1, minmn + ! + ! Bring the column of largest norm into the pivot position. + ! + IF ( pivot ) THEN + + kmax = j + + DO k = j, n + IF ( rdiag(kmax) < rdiag(k) ) THEN + kmax = k + ENDIF + ENDDO + + IF ( kmax /= j ) THEN + + r8_temp(1:m) = a(1:m,j) + a(1:m,j) = a(1:m,kmax) + a(1:m,kmax) = r8_temp(1:m) + + rdiag(kmax) = rdiag(j) + wa(kmax) = wa(j) + + i4_temp = ipvt(j) + ipvt(j) = ipvt(kmax) + ipvt(kmax) = i4_temp + + ENDIF + + ENDIF + ! + ! Compute the Householder transformation to reduce the + ! J-th column of A to a multiple of the J-th unit vector. + ! + ajnorm = enorm ( m-j+1, a(j,j) ) + + IF ( ajnorm /= 0.0D+00 ) THEN + + IF ( a(j,j) < 0.0D+00 ) THEN + ajnorm = -ajnorm + ENDIF + + a(j:m,j) = a(j:m,j) / ajnorm + a(j,j) = a(j,j) + 1.0D+00 + ! + ! Apply the transformation to the remaining columns and update the norms. + ! + DO k = j + 1, n + + temp = dot_product ( a(j:m,j), a(j:m,k) ) / a(j,j) + + a(j:m,k) = a(j:m,k) - temp * a(j:m,j) + + IF ( pivot .and. rdiag(k) /= 0.0D+00 ) THEN + + temp = a(j,k) / rdiag(k) + rdiag(k) = rdiag(k) * sqrt ( max ( 0.0D+00, 1.0D+00-temp ** 2 ) ) + + IF ( 0.05D+00 * ( rdiag(k) / wa(k) ) ** 2 <= epsmch ) THEN + rdiag(k) = enorm ( m-j, a(j+1,k) ) + wa(k) = rdiag(k) + ENDIF + + ENDIF + + ENDDO + + ENDIF + + rdiag(j) = - ajnorm + + ENDDO + + RETURN + + END SUBROUTINE qrfac + + SUBROUTINE qrsolv ( n, r, ldr, ipvt, diag, qtb, x, sdiag ) + + !*****************************************************************************80 + ! + !! QRSOLV solves a rectangular linear system A*x=b in the least squares sense. + ! + ! Discussion: + ! + ! Given an M by N matrix A, an N by N diagonal matrix D, + ! and an M-vector B, the problem is to determine an X which + ! solves the system + ! + ! A*X = B + ! D*X = 0 + ! + ! in the least squares sense. + ! + ! This FUNCTION completes the solution of the problem + ! IF it is provided with the necessary information from the + ! QR factorization, with column pivoting, of A. That is, IF + ! A*P = Q*R, WHERE P is a permutation matrix, Q has orthogonal + ! columns, and R is an upper triangular matrix with diagonal + ! elements of nonincreasing magnitude, THEN QRSOLV expects + ! the full upper triangle of R, the permutation matrix p, + ! and the first N components of Q'*B. + ! + ! The system is THEN equivalent to + ! + ! R*Z = Q'*B + ! P'*D*P*Z = 0 + ! + ! WHERE X = P*Z. IF this system does not have full rank, + ! THEN a least squares solution is obtained. On output QRSOLV + ! also provides an upper triangular matrix S such that + ! + ! P'*(A'*A + D*D)*P = S'*S. + ! + ! S is computed within QRSOLV and may be of separate interest. + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 06 April 2010 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, the order of R. + ! + ! Input/output, real ( kind = 8 ) R(LDR,N), the N by N matrix. + ! On input the full upper triangle must contain the full upper triangle + ! of the matrix R. On output the full upper triangle is unaltered, and + ! the strict lower triangle CONTAINS the strict upper triangle + ! (transposed) of the upper triangular matrix S. + ! + ! Input, integer ( kind = 4 ) LDR, the leading dimension of R, which must be + ! at least N. + ! + ! Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P such + ! that A*P = Q*R. Column J of P is column IPVT(J) of the identity matrix. + ! + ! Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D. + ! + ! Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B. + ! + ! Output, real ( kind = 8 ) X(N), the least squares solution. + ! + ! Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper + ! triangular matrix S. + ! + IMPLICIT NONE + + integer ( kind = 4 ) ldr + integer ( kind = 4 ) n + + real ( kind = 8 ) c + real ( kind = 8 ) cotan + real ( kind = 8 ) diag(n) + integer ( kind = 4 ) i + integer ( kind = 4 ) ipvt(n) + integer ( kind = 4 ) j + integer ( kind = 4 ) k + integer ( kind = 4 ) l + integer ( kind = 4 ) nsing + real ( kind = 8 ) qtb(n) + real ( kind = 8 ) qtbpj + real ( kind = 8 ) r(ldr,n) + real ( kind = 8 ) s + real ( kind = 8 ) sdiag(n) + real ( kind = 8 ) sum2 + real ( kind = 8 ) t + real ( kind = 8 ) temp + real ( kind = 8 ) wa(n) + real ( kind = 8 ) x(n) + + ! + ! Copy R and Q'*B to preserve input and initialize S. + ! + ! In particular, SAVE the diagonal elements of R in X. + ! + DO j = 1, n + r(j:n,j) = r(j,j:n) + x(j) = r(j,j) + ENDDO + + wa(1:n) = qtb(1:n) + ! + ! Eliminate the diagonal matrix D using a Givens rotation. + ! + DO j = 1, n + ! + ! Prepare the row of D to be eliminated, locating the + ! diagonal element using P from the QR factorization. + ! + l = ipvt(j) + + IF ( diag(l) /= 0.0D+00 ) THEN + + sdiag(j:n) = 0.0D+00 + sdiag(j) = diag(l) + ! + ! The transformations to eliminate the row of D + ! modify only a single element of Q'*B + ! beyond the first N, which is initially zero. + ! + qtbpj = 0.0D+00 + + DO k = j, n + ! + ! Determine a Givens rotation which eliminates the + ! appropriate element in the current row of D. + ! + IF ( sdiag(k) /= 0.0D+00 ) THEN + + IF ( abs ( r(k,k) ) < abs ( sdiag(k) ) ) THEN + cotan = r(k,k) / sdiag(k) + s = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan ** 2 ) + c = s * cotan + ELSE + t = sdiag(k) / r(k,k) + c = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * t ** 2 ) + s = c * t + ENDIF + ! + ! Compute the modified diagonal element of R and + ! the modified element of (Q'*B,0). + ! + r(k,k) = c * r(k,k) + s * sdiag(k) + temp = c * wa(k) + s * qtbpj + qtbpj = - s * wa(k) + c * qtbpj + wa(k) = temp + ! + ! Accumulate the tranformation in the row of S. + ! + DO i = k + 1, n + temp = c * r(i,k) + s * sdiag(i) + sdiag(i) = - s * r(i,k) + c * sdiag(i) + r(i,k) = temp + ENDDO + + ENDIF + + ENDDO + + ENDIF + ! + ! Store the diagonal element of S and restore + ! the corresponding diagonal element of R. + ! + sdiag(j) = r(j,j) + r(j,j) = x(j) + + ENDDO + ! + ! Solve the triangular system for Z. IF the system is + ! singular, THEN obtain a least squares solution. + ! + nsing = n + + DO j = 1, n + + IF ( sdiag(j) == 0.0D+00 .and. nsing == n ) THEN + nsing = j - 1 + ENDIF + + IF ( nsing < n ) THEN + wa(j) = 0.0D+00 + ENDIF + + ENDDO + + DO j = nsing, 1, -1 + sum2 = dot_product ( wa(j+1:nsing), r(j+1:nsing,j) ) + wa(j) = ( wa(j) - sum2 ) / sdiag(j) + ENDDO + ! + ! Permute the components of Z back to components of X. + ! + DO j = 1, n + l = ipvt(j) + x(l) = wa(j) + ENDDO + + RETURN + + END SUBROUTINE qrsolv + + FUNCTION enorm ( n, x ) + + !*****************************************************************************80 + ! + !! ENORM computes the Euclidean norm of a vector. + ! + ! Discussion: + ! + ! This is an extremely simplified version of the original ENORM + ! routine, which has been renamed to "ENORM2". + ! + ! Licensing: + ! + ! This code may freely be copied, modified, and used for any purpose. + ! + ! Modified: + ! + ! 06 April 2010 + ! + ! Author: + ! + ! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom. + ! FORTRAN90 version by John Burkardt. + ! + ! Reference: + ! + ! Jorge More, Burton Garbow, Kenneth Hillstrom, + ! User Guide for MINPACK-1, + ! Technical Report ANL-80-74, + ! Argonne National Laboratory, 1980. + ! + ! Parameters: + ! + ! Input, integer ( kind = 4 ) N, is the length of the vector. + ! + ! Input, real ( kind = 8 ) X(N), the vector whose norm is desired. + ! + ! Output, real ( kind = 8 ) ENORM, the Euclidean norm of the vector. + ! + IMPLICIT NONE + + integer ( kind = 4 ) n + real ( kind = 8 ) x(n) + real ( kind = 8 ) enorm + + enorm = sqrt ( sum ( x(1:n) ** 2 )) + + RETURN + + END FUNCTION enorm + + SUBROUTINE tridia (n, a, b, c, r, u) + + USE MOD_Precision + IMPLICIT NONE + integer, intent(in) :: n !length of diagonal element vector + real(r8), intent(in) :: a(1:n) !subdiagonal elements + real(r8), intent(in) :: b(1:n) !diagonal elements + real(r8), intent(in) :: c(1:n) !superdiagonal elements + real(r8), intent(in) :: r(1:n) !right hand side + real(r8), intent(out) :: u(1:n) !solution vector + + integer j + real(r8) gam(1:n),bet + + bet = b(1) + u(1) = r(1) / bet + DO j = 2, n + gam(j) = c(j-1) / bet + bet = b(j) - a(j) * gam(j) + u(j) = (r(j) - a(j)*u(j-1)) / bet + ENDDO + DO j = n-1, 1, -1 + u(j) = u(j) - gam(j+1) * u(j+1) + ENDDO + + END SUBROUTINE tridia + + ! ----------------------------------------------------------------- + SUBROUTINE polint(xa,ya,n,x,y) + + ! Given arrays xa and ya, each of length n, and gi + ! value y, and an error estimate dy. IF P (x) is the p + ! P (xa(i)) = ya(i), i = 1, . . . , n, THEN the returned value + ! (from: "Numerical Recipes") + + USE MOD_Precision + IMPLICIT NONE + integer n,NMAX + real(r8) dy,x,y,xa(n),ya(n) + parameter (NMAX=10) !Largest anticipated val + integer i,m,ns + real(r8) den,dif,dift,ho,hp,w,c(NMAX),d(NMAX) + + ns=1 + dif=abs(x-xa(1)) + + DO i=1,n !Here we find the index ns of the closest table entry, + dift=abs(x-xa(i)) + IF(dift.lt.dif) THEN + ns=i + dif=dift + ENDIF + c(i)=ya(i) !and initialize the tableau of c's and d's. + d(i)=ya(i) + ENDDO + + y=ya(ns) !This is the initial approximation to y. + ns=ns-1 + + DO m=1,n-1 !For each column of the tableau, + DO i=1,n-m !we loop over the current c's and d's and update them. + ho=xa(i)-x + hp=xa(i+m)-x + w=c(i+1)-d(i) + den=ho-hp + IF(den.eq.0.) print*, 'failure in polint' !two input xa's are identical. + den=w/den + d(i)=hp*den !here the c's and d's are updated. + c(i)=ho*den + ENDDO + IF(2*ns.lt.n-m)THEN !After each column in the tableau is completed, we decide + dy=c(ns+1) !which correction, c or d, we want to add to our accumulating + ELSE !value of y, i.e., which path to take through + dy=d(ns) !the tableau-forking up or down. We DO this in such a + ns=ns-1 !way as to take the most "straight line" route through the + ENDIF !tableau to its apex, updating ns accordingly to keep track + y=y+dy !of WHERE we are. This route keeps the partial approximations + ENDDO !centered (insofar as possible) on the target x. T he + !last dy added is thus the error indication. + + END SUBROUTINE polint + +END MODULE MOD_Utils 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 faa5761c9a..8b679a7adb 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 @@ -10037,6 +10037,7 @@ subroutine rrtmg_swrad( & swupb,swupbc,swdnb,swdnbc, & swupflx, swupflxc, swdnflx, swdnflxc, & swddir,swddni,swddif, & + swvisdir,swvisdif,swnirdir,swnirdif, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -10085,7 +10086,7 @@ subroutine rrtmg_swrad( & !--- output arguments: real,intent(out),dimension(ims:ime,jms:jme),optional:: & - swddir,swddni,swddif + swddir,swddni,swddif,swvisdir,swvisdif,swnirdir,swnirdif real,intent(out),dimension(ims:ime,kms:kme+2,jms:jme ),optional:: & swupflx,swupflxc,swdnflx,swdnflxc @@ -10625,6 +10626,14 @@ subroutine rrtmg_swrad( & swddif(i,j) = swdkdif(1,1) ! jararias 2013/08/10 endif + if(present(swvisdir) .and. present(swvisdif) .and. & + present(swnirdir) .and. present(swnirdif)) then + swvisdir(i,j) = sibvisdir(1,1) + swvisdif(i,j) = sibvisdif(1,1) + swnirdir(i,j) = sibnirdir(1,1) + swnirdif(i,j) = sibnirdif(1,1) + endif + if(present (swupflx)) then do k = kts, kte+2 swupflx(i,k,j) = swuflx(1,k) @@ -10655,6 +10664,20 @@ subroutine rrtmg_swrad( & swdnbc(i,j) = 0. endif + if(present(swddir) .and. present(swddni) .and. present(swddif)) then + swddir(i,j) = 0. + swddni(i,j) = 0. + swddif(i,j) = 0. + endif + + if(present(swvisdir) .and. present(swvisdif) .and. & + present(swnirdir) .and. present(swnirdif)) then + swvisdir(i,j) = 0. + swvisdif(i,j) = 0. + swnirdir(i,j) = 0. + swnirdif(i,j) = 0. + endif + endif end do i_loop !end longitude loop.