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..c934cde3e9 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -22,6 +22,7 @@ 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)
message(STATUS "[OPTION] MPAS_CORES: ${MPAS_CORES}")
message(STATUS "[OPTION] MPAS_DOUBLE_PRECISION: ${MPAS_DOUBLE_PRECISION}")
@@ -29,6 +30,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)
@@ -68,9 +70,14 @@ 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_COLM2024)
+ find_package(LAPACK REQUIRED)
+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..1a349d13fc 100644
--- a/cmake/Functions/MPAS_Functions.cmake
+++ b/cmake/Functions/MPAS_Functions.cmake
@@ -214,25 +214,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)
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..9780e83714 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,108 @@ 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(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 ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES ${_colm2024_src_rel})
+ endforeach()
+ list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SOURCES _colm2024_source_count)
+ if(_colm2024_source_count EQUAL 0)
+ message(FATAL_ERROR "CoLM2024 CMake source list is empty")
+ endif()
+ list(LENGTH ATMOSPHERE_CORE_PHYSICS_COLM2024_SKIPPED_EMPTY_SOURCES _colm2024_skipped_empty_count)
+ message(STATUS "CoLM2024 embedded CMake sources: ${_colm2024_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()
+
+ _colm2024_source_depends(
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90)
+ _colm2024_source_depends(
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90)
+ _colm2024_source_depends(
+ physics/physics_colm2024/main/MOD_HistGridded.F90
+ physics/physics_colm2024/main/MOD_HistWriteBack.F90)
+ _colm2024_source_depends(
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90)
+ _colm2024_source_depends(
+ physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90)
+ _colm2024_source_depends(
+ physics/physics_colm2024/main/MOD_Hist.F90
+ physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90)
+ _colm2024_source_depends(
+ physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90
+ physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90
+ physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90)
+ _colm2024_source_depends(
+ physics/mpas_atmphys_driver_lsm_colm2024.F
+ physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90)
+endif()
+
# diagnostics/
set(ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES
mpas_atm_diagnostic_template.F
@@ -351,6 +454,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,7 +469,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)
+ if(TARGET LAPACK::LAPACK)
+ target_link_libraries(core_atmosphere PUBLIC LAPACK::LAPACK)
+ else()
+ target_link_libraries(core_atmosphere PUBLIC ${LAPACK_LIBRARIES})
+ endif()
+ 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)
+ if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10)
+ list(APPEND _colm2024_compile_options -fallow-argument-mismatch)
+ endif()
+ 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})
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..8b0ff5241e 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 @@
+
+
+
+
+
+
+
+
@@ -1028,9 +1037,9 @@
#endif
-
@@ -1157,9 +1166,9 @@
#endif
-
@@ -1170,9 +1179,9 @@
#endif
-
@@ -1694,7 +1703,7 @@
description="Moist potential temperature: theta*(1+q_v*R_v/R_d)"/>
-
+
#ifndef MPAS_CAM_DYCORE
@@ -2024,7 +2033,7 @@
-
+
@@ -2060,7 +2069,7 @@
description="Tendency of surface pressure"/>
-
+
#ifndef MPAS_CAM_DYCORE
@@ -2093,7 +2102,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 +2118,7 @@
description="Tendency of water-friendly aerosol number concentration multiplied by dry air density divided by d(zeta)/dz"
packages="mp_thompson_aers_in"/>
-
@@ -2252,7 +2261,7 @@
possible_values="Positive integers"/>
-
+
+ possible_values="`suite',`sf_noah',`sf_noahmp`, `sf_colm2024`, `off'"/>
+
+
+
+
@@ -3237,6 +3253,18 @@
+
+
+
+
+
+
+
+
@@ -3543,7 +3571,7 @@
-
+
#ifdef DO_PHYSICS
@@ -3970,7 +3998,7 @@
#endif
-
+
diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F
index eef1951e36..792d9f561d 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
diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile
index 2b7422ddec..0422dc4da0 100644
--- a/src/core_atmosphere/physics/Makefile
+++ b/src/core_atmosphere/physics/Makefile
@@ -4,9 +4,42 @@ 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
+COLM2024_MOD_CMD ?= -J
+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_FOPTS ?= $(CPPFLAGS) $(COREDEF) $(FFLAGS) -fdefault-real-8 -ffree-form -cpp -ffree-line-length-0 -fallow-argument-mismatch
+COLM2024_SOURCE_DIRS = \
+ physics_colm2024/share \
+ physics_colm2024/main \
+ physics_colm2024/main/HYDRO \
+ physics_colm2024/main/BGC \
+ physics_colm2024/main/URBAN \
+ physics_colm2024/main/DA \
+ 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 +60,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 +105,245 @@ 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_SPMD_Task.o \
+ MOD_Namelist.o \
+ MOD_Vars_Global.o \
+ MOD_Const_Physical.o \
+ MOD_Const_LC.o \
+ MOD_Utils.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_NetCDFPoint.o \
+ MOD_NetCDFBlock.o \
+ MOD_CatchmentDataReadin.o \
+ MOD_5x5DataReadin.o \
+ MOD_Mesh.o \
+ MOD_Pixelset.o \
+ MOD_NetCDFVector.o \
+ MOD_RangeCheck.o \
+ MOD_SpatialMapping.o \
+ MOD_ComputePushData.o \
+ MOD_AggregationRequestData.o \
+ MOD_PixelsetShared.o \
+ MOD_LandElm.o \
+ MOD_LandHRU.o \
+ MOD_LandPatch.o \
+ MOD_Land2mWMO.o \
+ MOD_LandCrop.o \
+ MOD_LandPFT.o \
+ MOD_LandUrban.o \
+ MOD_Urban_Const_LCZ.o \
+ MOD_SingleSrfdata.o \
+ MOD_SrfdataRestart.o \
+ MOD_ElmVector.o \
+ MOD_HRUVector.o \
+ MOD_MeshFilter.o
+
+COLM2024_OBJS_BASIC_NAMES = \
+ MOD_Vector_ReadWrite.o \
+ MOD_dataSpec_PDB.o \
+ MOD_tav_abs.o \
+ MOD_prospect_DB.o \
+ MOD_Catch_BasinNetwork.o \
+ MOD_Catch_Vars_TimeVariables.o \
+ MOD_Catch_Vars_1DFluxes.o \
+ MOD_Grid_RiverLakeNetwork.o \
+ MOD_Grid_Reservoir.o \
+ MOD_Grid_RiverLakeTimeVars.o \
+ MOD_BGC_Vars_1DFluxes.o \
+ MOD_BGC_Vars_1DPFTFluxes.o \
+ MOD_BGC_Vars_PFTimeVariables.o \
+ MOD_BGC_Vars_TimeInvariants.o \
+ MOD_BGC_Vars_TimeVariables.o \
+ MOD_Urban_Vars_1DFluxes.o \
+ MOD_Urban_Vars_TimeVariables.o \
+ MOD_Urban_Vars_TimeInvariants.o \
+ MOD_DA_Vars_1DFluxes.o \
+ MOD_Vars_TimeInvariants.o \
+ MOD_DA_Vars_TimeVariables.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_CropReadin.o \
+ MOD_NitrifData.o \
+ MOD_NdepData.o \
+ MOD_FireData.o \
+ MOD_OrbCoszen.o \
+ MOD_OrbCosazi.o \
+ MOD_HighRes_Parameters.o \
+ MOD_3DCanopyRadiation.o \
+ MOD_Aerosol.o \
+ MOD_SnowSnicar.o \
+ MOD_Albedo.o \
+ MOD_SnowSnicar_HiRes.o \
+ MOD_Albedo_HiRes.o \
+ MOD_SnowFraction.o \
+ MOD_Urban_LAIReadin.o \
+ MOD_Urban_Shortwave.o \
+ MOD_Urban_Albedo.o \
+ MOD_MonthlyinSituCO2MaunaLoa.o \
+ MOD_BGC_CNSummary.o \
+ MOD_ElementNeighbour.o \
+ MOD_Catch_HillslopeNetwork.o \
+ MOD_Catch_RiverLakeNetwork.o \
+ MOD_Catch_Reservoir.o \
+ MOD_VicParaReadin.o
+
+COLM2024_OBJS_MAIN_NAMES = \
+ MOD_Catch_HillslopeFlow.o \
+ MOD_Catch_SubsurfaceFlow.o \
+ MOD_Catch_RiverLakeFlow.o \
+ MOD_Catch_Hist.o \
+ MOD_Catch_WriteParameters.o \
+ MOD_BGC_CNCStateUpdate1.o \
+ MOD_BGC_CNCStateUpdate2.o \
+ MOD_BGC_CNCStateUpdate3.o \
+ MOD_BGC_CNNStateUpdate1.o \
+ MOD_BGC_CNNStateUpdate2.o \
+ MOD_BGC_CNNStateUpdate3.o \
+ MOD_BGC_Soil_BiogeochemNStateUpdate1.o \
+ MOD_BGC_Soil_BiogeochemNitrifDenitrif.o \
+ MOD_BGC_Soil_BiogeochemCompetition.o \
+ MOD_BGC_Soil_BiogeochemDecompCascadeBGC.o \
+ MOD_BGC_Soil_BiogeochemDecomp.o \
+ MOD_BGC_Soil_BiogeochemLittVertTransp.o \
+ MOD_BGC_Soil_BiogeochemNLeaching.o \
+ MOD_BGC_Soil_BiogeochemPotential.o \
+ MOD_BGC_Soil_BiogeochemVerticalProfile.o \
+ MOD_BGC_Veg_CNGapMortality.o \
+ MOD_BGC_Veg_CNGResp.o \
+ MOD_BGC_Veg_CNMResp.o \
+ MOD_BGC_Daylength.o \
+ MOD_BGC_Veg_CNPhenology.o \
+ MOD_BGC_Veg_NutrientCompetition.o \
+ MOD_BGC_Veg_CNVegStructUpdate.o \
+ MOD_BGC_CNAnnualUpdate.o \
+ MOD_BGC_CNZeroFluxes.o \
+ MOD_BGC_CNBalanceCheck.o \
+ MOD_BGC_CNSASU.o \
+ MOD_BGC_Veg_CNNDynamics.o \
+ MOD_BGC_Veg_CNFireBase.o \
+ MOD_BGC_Veg_CNFireLi2016.o \
+ MOD_Vars_2DForcing.o \
+ MOD_UserSpecifiedForcing.o \
+ MOD_ForcingDownscaling.o \
+ MOD_Forcing.o \
+ MOD_DA_TWS.o \
+ MOD_DA_Const.o \
+ MOD_DA_RTM.o \
+ MOD_DA_EnKF.o \
+ MOD_DA_SM.o \
+ MOD_DA_Ensemble.o \
+ MOD_DA_Main.o \
+ MOD_Opt_Baseflow.o \
+ MOD_ParameterOptimization.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_NetSolar_Hyper.o \
+ MOD_WetBulb.o \
+ MOD_RainSnowTemp.o \
+ MOD_SoilSurfaceResistance.o \
+ MOD_NewSnow.o \
+ MOD_Thermal.o \
+ MOD_Vars_1DAccFluxes.o \
+ MOD_Irrigation.o \
+ MOD_BGC_driver.o \
+ MOD_HistWriteBack.o \
+ MOD_HistGridded.o \
+ MOD_HistVector.o \
+ MOD_HistSingle.o \
+ MOD_Grid_RiverLakeHist.o \
+ MOD_Hist.o \
+ MOD_CheckEquilibrium.o \
+ MOD_LightningData.o \
+ MOD_Catch_LateralFlow.o \
+ MOD_Grid_RiverLakeFlow.o \
+ MOD_Urban_Longwave.o \
+ MOD_Urban_NetSolar.o \
+ MOD_Urban_Flux.o \
+ MOD_Urban_GroundFlux.o \
+ MOD_Urban_RoofFlux.o \
+ MOD_Urban_RoofTemperature.o \
+ MOD_Urban_WallTemperature.o \
+ MOD_Urban_PerviousTemperature.o \
+ MOD_Urban_ImperviousTemperature.o \
+ MOD_Urban_Hydrology.o \
+ MOD_Urban_BEM.o \
+ MOD_Urban_LUCY.o \
+ MOD_Urban_Thermal.o \
+ CoLMMAIN_Urban.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_CMD)$(COLM2024_BUILD_DIR); \
+ 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 +351,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 +372,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 +449,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 +461,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 +485,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 +531,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 +541,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/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F
index b3162019e5..c83013c5ee 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. &
@@ -379,9 +380,9 @@ subroutine physics_registry_init(mesh,configs,sfc_input)
enddo
case default
-
+
end select lsm_select
-
+
endif
!call mpas_log_write('--- enter subroutine physics_namelist_check.')
@@ -535,4 +536,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..1538930736 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
@@ -169,18 +170,216 @@ 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, &
+ sfc_input,itimestep,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_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,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 +496,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 +571,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..aeca5641a5
--- /dev/null
+++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_colm2024.F
@@ -0,0 +1,577 @@
+! 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_atmphys_constants, only: R_d, R_v
+ use mpas_atmphys_manager, only: year, curr_julday
+ use mpas_atmphys_utilities, only: physics_error_fatal
+ use mpas_atmphys_vars, only: dt_pbl, xice_threshold
+
+#ifdef MPAS_COLM2024
+ 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_state, &
+ colm_mpas_finalize
+ use MOD_Vars_Global, only: colm_dz_soi => dz_soi
+#endif
+
+ implicit none
+ private
+ public :: init_lsm_colm2024, push_lsm_colm2024, step_lsm_colm2024, pull_lsm_colm2024, finalize_lsm_colm2024
+
+ logical, save :: colm_first_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.
+#endif
+
+ contains
+
+!=================================================================================================================
+ subroutine init_lsm_colm2024(dminfo,configs,block,diag_physics,sfc_input)
+!=================================================================================================================
+
+ type(dm_info),intent(in):: dminfo
+ type(mpas_pool_type),intent(in):: configs
+ type(block_type),intent(in):: block
+ type(mpas_pool_type),intent(inout):: diag_physics
+ type(mpas_pool_type),intent(inout):: sfc_input
+#ifdef MPAS_COLM2024
+ logical :: colm_ready
+ integer :: colm_ierr
+ integer :: colm_mpas_comm
+ integer :: colm_patch_count
+ integer :: block_cells
+ integer :: n_mpas_cells
+ integer :: offset
+ character(len=StrKIND),pointer:: config_colm2024_namelist
+ integer,pointer:: nCellsSolve
+ integer,dimension(:),pointer:: indexToCellID
+ integer,allocatable:: cell_to_element(:), mpas_cell_id(:)
+ type(block_type),pointer:: block_cursor
+ type(colm_block_map_type),pointer:: block_map
+ type(mpas_pool_type),pointer:: block_mesh
+#endif
+
+#ifdef MPAS_COLM2024
+ call mpas_pool_get_config(configs,'config_colm2024_namelist',config_colm2024_namelist)
+ 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
+
+ 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 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), 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)
+
+ block_cells = nCellsSolve
+ if(block_cells > 0) then
+ mpas_cell_id(offset+1:offset+block_cells) = indexToCellID(1:block_cells)
+ 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
+ colm_mpas_comm = dminfo % comm % mpi_val
+#else
+ colm_mpas_comm = dminfo % comm
+#endif
+
+ call colm_mpas_initialize_from_namelist(trim(config_colm2024_namelist), colm_ierr, &
+ mpas_comm=colm_mpas_comm, &
+ mpas_cell_id=mpas_cell_id, &
+ n_mpas_cells=n_mpas_cells, &
+ cell_to_element=cell_to_element)
+ if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 initialization from config_colm2024_namelist failed.")
+
+ 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_first_step = .true.
+ colm_initialized = .true.
+#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,sfc_input,itimestep,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(inout):: sfc_input
+ integer,intent(in):: time_lev
+ integer,intent(in):: itimestep
+ 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, &
+ sfc_input, itimestep, its, ite)
+#else
+ call colm2024_adapter_not_built
+#endif
+
+ end subroutine push_lsm_colm2024
+
+!=================================================================================================================
+ subroutine step_lsm_colm2024()
+!=================================================================================================================
+
+#ifdef MPAS_COLM2024
+ logical :: colm_ready
+ integer :: colm_ierr
+ integer :: colm_patch_count
+ integer :: colm_idate(3)
+
+ call colm_mpas_ready(colm_ready, colm_patch_count)
+ if(.not. colm_ready) call colm2024_adapter_not_ready
+ colm_idate(1) = year
+ colm_idate(2) = int(curr_julday) + 1
+ colm_idate(3) = nint((curr_julday - real(int(curr_julday), RKIND)) * 86400._RKIND)
+ call colm_mpas_step(colm_idate, real(dt_pbl, colm_r8), colm_first_step, .true., .false., colm_ierr)
+ if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 driver returned before completing a land-surface step.")
+ colm_first_step = .false.
+#else
+ call colm2024_adapter_not_built
+#endif
+
+ end subroutine step_lsm_colm2024
+
+!=================================================================================================================
+ subroutine pull_lsm_colm2024(block,diag_physics,sfc_input,its,ite)
+!=================================================================================================================
+
+ type(block_type),intent(in):: block
+ type(mpas_pool_type),intent(inout):: diag_physics
+ 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, sfc_input, real(dt_pbl, colm_r8), its, ite)
+#else
+ call colm2024_adapter_not_built
+#endif
+
+ end subroutine pull_lsm_colm2024
+
+!=================================================================================================================
+ subroutine finalize_lsm_colm2024()
+ !=================================================================================================================
+
+#ifdef MPAS_COLM2024
+ integer :: colm_ierr
+
+ if(.not. colm_initialized) return
+ call colm_mpas_finalize(colm_ierr)
+ if(colm_ierr /= 0) call physics_error_fatal("CoLM2024 finalization failed.")
+ call colm2024_free_block_maps()
+ colm_first_step = .true.
+ 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,sfc_input,itimestep,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):: sfc_input
+ integer,intent(in):: time_lev
+ integer,intent(in):: itimestep
+ integer,intent(in):: its,ite
+
+ character(len=StrKIND),pointer:: config_convection_scheme, config_microp_scheme
+ integer,pointer:: index_qv
+ integer:: i, k
+ integer:: ierr
+ real(kind=colm_r8):: aerdep(14)
+ real(kind=colm_r8):: dt, micro_rain, micro_snow, hgt, oro, pbot, psrf, prc, prl, qair, rain, rhoair, snow, &
+ solld, soll, solsd, sols, spectral_sw, swdir, swdif, tair, uair, vair
+ real(kind=RKIND):: qv_cell
+ real(kind=RKIND),dimension(:),pointer:: glw, swddir, swddif, swvisdir, swvisdif, swnirdir, swnirdif
+ real(kind=RKIND),dimension(:),pointer:: surface_pressure, sr, xice, xland
+ real(kind=RKIND),dimension(:),pointer:: raincv, rainncv, snowncv, graupelncv
+ real(kind=RKIND),dimension(:,:),pointer:: exner, 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_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)
+ call mpas_pool_get_array(diag_physics,'glw' ,glw )
+ 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)
+ call mpas_pool_get_array(diag_physics,'raincv' ,raincv )
+ call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv )
+ call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv )
+ call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv)
+ call mpas_pool_get_array(diag_physics,'sr' ,sr )
+ call mpas_pool_get_array(sfc_input,'xland',xland)
+ call mpas_pool_get_array(sfc_input,'xice' ,xice )
+
+ dt = max(real(dt_pbl, colm_r8), 1._colm_r8)
+ 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.")
+
+ psrf = real(surface_pressure(i), colm_r8)
+ pbot = real(pressure_b(k,i) + pressure_p(k,i), colm_r8)
+ 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 = max(0.1_colm_r8, pbot / (R_d * tair * (1._colm_r8 + 0.61_colm_r8 * qair)))
+ 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_rain = max(0._colm_r8, real(rainncv(i), colm_r8) / dt)
+ micro_snow = max(0._colm_r8, real(snowncv(i) + graupelncv(i), colm_r8) / dt)
+ if(micro_snow <= 0._colm_r8 .and. sr(i) > 0._RKIND) then
+ micro_snow = micro_rain * min(1._colm_r8, real(sr(i), colm_r8))
+ micro_rain = max(0._colm_r8, micro_rain - micro_snow)
+ endif
+ prl = micro_rain + micro_snow
+ rain = rain + micro_rain
+ snow = snow + micro_snow
+ 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_sw = sols + solsd + soll + solld
+ if(spectral_sw <= 0._colm_r8 .and. swdir + swdif > 0._colm_r8) then
+ sols = 0.5_colm_r8 * swdir
+ soll = 0.5_colm_r8 * swdir
+ solsd = 0.5_colm_r8 * swdif
+ solld = 0.5_colm_r8 * swdif
+ endif
+ oro = 1._colm_r8
+ if(xland(i) >= 1.5_RKIND) oro = 0._colm_r8
+ if(xice(i) >= xice_threshold) oro = 2._colm_r8
+
+ call colm_mpas_set_element_forcing(element_for_cell(i), psrf * 420.e-6_colm_r8, &
+ psrf * 0.209_colm_r8, uair, vair, tair, qair, &
+ prc, prl, rain, snow, psrf, pbot, &
+ sols, soll, solsd, solld, &
+ real(glw(i), colm_r8), hgt, hgt, hgt, rhoair, 1000._colm_r8, &
+ aerdep, oro=oro, 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_pull_mpas_surface(element_for_cell,diag_physics,sfc_input,dt,its,ite)
+!=================================================================================================================
+
+ integer,dimension(:),intent(in):: element_for_cell
+ type(mpas_pool_type),intent(inout):: diag_physics
+ type(mpas_pool_type),intent(inout):: sfc_input
+ real(kind=colm_r8),intent(in):: dt
+ integer,intent(in):: its,ite
+
+ integer:: i, ns, nlev, nvalid_soil
+ integer:: ierr
+ real(kind=colm_r8):: sensible, latent, evaporation, ground_heat, runoff
+ real(kind=colm_r8):: surface_runoff, subsurface_runoff, skin_temp, t2m_colm, q2m_colm, qsfc_colm
+ real(kind=colm_r8):: emissivity, roughness, albedo
+ real(kind=colm_r8):: canopy_water, snow_water, snow_depth, snow_cover, leaf_area_index
+ real(kind=colm_r8):: soil_moisture_sum
+ real(kind=colm_r8):: soil_depth_sum
+ real(kind=colm_r8),parameter:: colm_state_bad_value = 1.e30_colm_r8
+ real(kind=colm_r8),dimension(:),allocatable:: soil_liquid, soil_moisture, soil_temperature
+ 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
+ real(kind=RKIND),dimension(:),pointer:: skintemp, canwat, smstav, smstot, snow, snowc, snowh, lai
+ real(kind=RKIND),dimension(:,:),pointer:: sh2o, smois, tslb
+
+ 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,'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,'sh2o' ,sh2o )
+ call mpas_pool_get_array(sfc_input,'smois' ,smois )
+ call mpas_pool_get_array(sfc_input,'tslb' ,tslb )
+
+ nlev = size(tslb, 1)
+ allocate(soil_liquid(nlev), soil_moisture(nlev), soil_temperature(nlev))
+
+ 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.")
+
+ 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, &
+ qsfc_colm, emissivity, roughness, albedo, ierr)
+ if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface fluxes.")
+ call colm_mpas_get_element_state(element_for_cell(i), canopy_water, snow_water, snow_depth, snow_cover, &
+ leaf_area_index, soil_liquid, soil_moisture, soil_temperature, ierr)
+ if(ierr /= 0) call physics_error_fatal("Failed to retrieve CoLM2024 surface state.")
+
+ 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)
+ qsfc(i) = real(qsfc_colm, RKIND)
+ ! MPAS/WRF q2 is a 2 m mixing ratio; CoLM qref is specific humidity.
+ if(abs(q2m_colm) < colm_state_bad_value .and. q2m_colm >= 0._colm_r8 .and. q2m_colm < 1._colm_r8) then
+ q2(i) = real(q2m_colm / (1._colm_r8 - q2m_colm), RKIND)
+ endif
+ sfc_emiss(i) = real(emissivity, RKIND)
+ z0(i) = real(roughness, RKIND)
+ znt(i) = real(roughness, RKIND)
+ if(albedo > 0._colm_r8 .and. albedo < 1._colm_r8) sfc_albedo(i) = real(albedo, RKIND)
+ 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)
+
+ soil_moisture_sum = 0._colm_r8
+ soil_depth_sum = 0._colm_r8
+ nvalid_soil = 0
+ do ns = 1,nlev
+ if(abs(soil_liquid(ns)) < colm_state_bad_value .and. &
+ abs(soil_moisture(ns)) < colm_state_bad_value .and. &
+ abs(soil_temperature(ns)) < colm_state_bad_value) then
+ sh2o(ns,i) = real(soil_liquid(ns), RKIND)
+ smois(ns,i) = real(soil_moisture(ns), RKIND)
+ tslb(ns,i) = real(soil_temperature(ns), RKIND)
+ if(ns <= size(colm_dz_soi) .and. colm_dz_soi(ns) > 0._colm_r8) then
+ soil_moisture_sum = soil_moisture_sum + soil_moisture(ns) * colm_dz_soi(ns)
+ soil_depth_sum = soil_depth_sum + colm_dz_soi(ns)
+ endif
+ nvalid_soil = nvalid_soil + 1
+ endif
+ enddo
+ if(nvalid_soil > 0 .and. soil_depth_sum > 0._colm_r8) then
+ smstot(i) = real(soil_moisture_sum / soil_depth_sum, RKIND)
+ if(abs(soil_moisture(1)) < colm_state_bad_value) then
+ smstav(i) = real(soil_moisture(1), RKIND)
+ else
+ smstav(i) = smstot(i)
+ endif
+ smstav(i) = max(0._RKIND, min(1._RKIND, smstav(i)))
+ endif
+ enddo
+
+ deallocate(soil_liquid, soil_moisture, soil_temperature)
+
+ 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_finalize.F b/src/core_atmosphere/physics/mpas_atmphys_finalize.F
index 5367d83286..b3d7a7b12b 100644
--- a/src/core_atmosphere/physics/mpas_atmphys_finalize.F
+++ b/src/core_atmosphere/physics/mpas_atmphys_finalize.F
@@ -10,6 +10,7 @@ module mpas_atmphys_finalize
use mpas_pool_routines
use mpas_atmphys_lsm_noahmpfinalize,only: sf_noahmp_deallocate
+ use mpas_atmphys_driver_lsm_colm2024,only: finalize_lsm_colm2024
use module_mp_thompson
use cires_ugwpv1_module
@@ -46,7 +47,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 +56,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 +75,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..431442c19b 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,block,diag_physics,sfc_input)
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..228bb86243 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)
@@ -190,8 +194,12 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr)
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 +208,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/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..d08b93f20e
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/README.md
@@ -0,0 +1,12 @@
+# 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`.
+
+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..eb500330d0
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/drivers/mpas/MOD_CoLM_MPAS_Interface.F90
@@ -0,0 +1,1313 @@
+#include
+
+MODULE MOD_CoLM_MPAS_Interface
+
+ USE MOD_Precision
+ USE MOD_LandPatch, only: numpatch, landpatch, elm_patch
+ USE MOD_Vars_Global, only: spval, nl_soil, dz_soi
+ 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
+ USE MOD_Vars_TimeVariables, only: t_grnd, tref, qref, qsfc, emis, z0m, alb, &
+ ldew, scv, snowdp, fsno, lai, t_soisno, wliq_soisno, wice_soisno
+ 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_get_surface
+ PUBLIC :: colm_mpas_get_element_surface
+ PUBLIC :: colm_mpas_get_element_state
+
+ logical, save :: colm_mpas_initialized = .false.
+ character(len=256), save :: colm_mpas_casename = ''
+ character(len=256), save :: colm_mpas_dir_restart = ''
+ integer, save :: colm_mpas_lc_year = -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, &
+ n_mpas_cells, cell_to_element)
+ 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_forcing, DEF_Reservoir_Method, &
+ DEF_WRST_FREQ, DEF_HIST_FREQ, DEF_HIST_WriteBack
+ USE MOD_Vars_Global, only: Init_GlobalVars
+ USE MOD_SPMD_Task, only: spmd_init, p_is_root
+ USE MOD_Const_LC, only: Init_LC_Const
+ USE MOD_Const_PFT, only: Init_PFT_Const, rho_p, tau_p
+ USE MOD_TimeManager, only: initimetype, monthday2julian, 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_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), optional :: mpas_comm
+ integer, intent(in), optional :: mpas_cell_id(:)
+ integer, intent(in), optional :: n_mpas_cells
+ integer, intent(out), optional :: cell_to_element(:)
+
+ 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 :: e_julian
+ integer :: n_mpas
+ integer :: i
+ integer*8, allocatable :: mpas_cell_id_i8(:)
+
+ ierr = 1
+ IF (colm_mpas_initialized) THEN
+ ierr = 0
+ RETURN
+ ENDIF
+
+ IF (present(mpas_comm)) THEN
+ CALL spmd_init(mpas_comm)
+ ELSE
+ CALL spmd_init()
+ ENDIF
+
+ CALL read_namelist(trim(nlfile))
+#ifdef MPAS_EMBEDDED_COLM
+ CALL colm_mpas_check_embedded_io(ierr)
+ IF (ierr /= 0) RETURN
+#endif
+
+ 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)
+ CALL monthday2julian(DEF_simulation_time%end_year, DEF_simulation_time%end_month, &
+ DEF_simulation_time%end_day, e_julian)
+ sdate(1) = DEF_simulation_time%start_year
+ sdate(2) = s_julian
+ sdate(3) = DEF_simulation_time%start_sec
+
+ colm_mpas_casename = casename
+ colm_mpas_dir_restart = dir_restart
+ colm_mpas_lc_year = lc_year
+ 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 = DEF_simulation_time%end_year
+ colm_mpas_etstamp%day = e_julian
+ colm_mpas_etstamp%sec = DEF_simulation_time%end_sec
+ colm_mpas_last_idate(:) = -1
+ colm_mpas_last_restart_idate(:) = -1
+ colm_mpas_restart_ready = .true.
+
+ CALL Init_GlobalVars
+ CALL Init_LC_Const
+ CALL Init_PFT_Const
+
+ n_mpas = 0
+#ifdef MPAS_EMBEDDED_COLM
+ IF (.not. present(n_mpas_cells)) THEN
+ IF (p_is_root) write(*,'(A)') 'CoLM2024 MPAS embedded initialization requires MPAS-owned cell ids.'
+ RETURN
+ ENDIF
+#endif
+ IF (present(n_mpas_cells)) THEN
+ IF (.not. present(mpas_cell_id)) RETURN
+ IF (.not. present(cell_to_element)) RETURN
+
+ n_mpas = n_mpas_cells
+ IF (n_mpas < 0) RETURN
+ IF (size(mpas_cell_id) < 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
+ ENDIF
+
+ CALL pixel%load_from_file(dir_landdata)
+ CALL gblock%load_from_file(dir_landdata)
+
+#ifdef MPAS_EMBEDDED_COLM
+ CALL colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id_i8, 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)
+#else
+ IF (n_mpas > 0) THEN
+ CALL colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id_i8, 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)
+ ELSE
+ CALL mesh_load_from_file(dir_landdata, lc_year)
+ CALL pixelset_load_from_file(dir_landdata, 'landelm', landelm, numelm, lc_year)
+ CALL pixelset_load_from_file(dir_landdata, 'landpatch', landpatch, numpatch, lc_year)
+ ENDIF
+#endif
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+#ifdef MPAS_EMBEDDED_COLM
+ CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year, &
+ subset_eindex=mpas_cell_id_i8)
+#else
+ IF (n_mpas > 0) THEN
+ CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year, &
+ subset_eindex=mpas_cell_id_i8)
+ ELSE
+ CALL pixelset_load_from_file(dir_landdata, 'landpft', landpft, numpft, lc_year)
+ ENDIF
+#endif
+#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
+ ENDIF
+
+ CALL elm_patch%build(landelm, landpatch, use_frac = .true.)
+#ifdef MPAS_EMBEDDED_COLM
+ CALL colm_mpas_validate_element_patch_map(.false., ierr)
+ IF (ierr /= 0) RETURN
+#endif
+
+#ifdef GridRiverLakeFlow
+#ifdef MPAS_EMBEDDED_COLM
+ CALL colm_mpas_check_embedded_riverlake(ierr)
+ IF (ierr /= 0) RETURN
+#endif
+ 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)
+#ifdef MPAS_EMBEDDED_COLM
+ CALL colm_mpas_validate_element_patch_map(.true., ierr)
+ IF (ierr /= 0) RETURN
+#endif
+ CALL allocate_TimeVariables()
+ CALL READ_TimeVariables(jdate, lc_year, casename, dir_restart)
+
+ 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()
+ DEF_forcing%has_missing_value = .false.
+
+#ifdef GridRiverLakeFlow
+ CALL grid_riverlake_flow_init()
+#endif
+
+ colm_mpas_initialized = .true.
+ ierr = 0
+ END SUBROUTINE colm_mpas_initialize_from_namelist
+
+#if defined(GridRiverLakeFlow) && defined(MPAS_EMBEDDED_COLM)
+ SUBROUTINE colm_mpas_check_embedded_riverlake(ierr)
+ USE MOD_Namelist, only: DEF_USE_SEDIMENT
+ USE MOD_SPMD_Task, only: p_np_glb, p_is_root
+ integer, intent(out) :: ierr
+
+ ierr = 0
+ IF (DEF_USE_SEDIMENT) THEN
+ IF (p_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 (p_np_glb > 1 .and. p_is_root) THEN
+ write(*,'(A)') 'CoLM2024 MPAS embedded GridRiverLakeFlow uses MPAS communicator ranks for distributed routing.'
+ write(*,'(A)') 'Legacy CoLM MPI process pools and replicated full-river-network fallback are disabled.'
+ 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
+ USE MOD_SPMD_Task, only: p_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 (p_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
+ END SUBROUTINE colm_mpas_check_embedded_io
+
+ SUBROUTINE colm_mpas_claim_owned_blocks(dir_landdata, lc_year, mpas_cell_id, n_mpas_cells, ierr)
+ USE MOD_Block, only: gblock, get_filename_block
+ USE MOD_SPMD_Task, only: p_iam_glb
+ USE MOD_NetCDFSerial, only: ncio_read_serial
+ USE MOD_Utils, only: quicksort, find_in_sorted_list1
+ character(len=*), intent(in) :: dir_landdata
+ integer, intent(in) :: lc_year
+ integer*8, intent(in) :: mpas_cell_id(:)
+ integer, intent(in) :: n_mpas_cells
+ integer, intent(out) :: ierr
+
+ logical, allocatable :: keep_block(:,:)
+ logical, allocatable :: found_element(:)
+ logical :: fexists
+ integer :: i
+ integer :: ie
+ integer :: iblk
+ integer :: jblk
+ integer :: iblkme
+ integer :: match
+ 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%pio)) RETURN
+ IF (.not. allocated(gblock%lon_w)) RETURN
+ IF (.not. allocated(gblock%lat_s)) RETURN
+ IF (size(mpas_cell_id) < n_mpas_cells) RETURN
+
+ allocate(keep_block(gblock%nxblk, gblock%nyblk))
+ keep_block = .false.
+
+ IF (n_mpas_cells == 0) THEN
+ gblock%pio(:,:) = -1
+ IF (allocated(gblock%xblkme)) deallocate(gblock%xblkme)
+ IF (allocated(gblock%yblkme)) deallocate(gblock%yblkme)
+ gblock%nblkme = 0
+ deallocate(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)
+
+ 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 ', &
+ p_iam_glb, ': ', sorted_cell_id(i)
+ deallocate(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'
+
+ DO jblk = 1, gblock%nyblk
+ DO iblk = 1, gblock%nxblk
+ 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
+ keep_block(iblk,jblk) = .true.
+ found_element(match) = .true.
+ ENDIF
+ ENDDO
+ IF (allocated(elmindx)) deallocate(elmindx)
+ 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 ', &
+ p_iam_glb, ': ', sorted_cell_id(i)
+ EXIT
+ ENDIF
+ ENDDO
+ deallocate(keep_block, found_element, sorted_cell_id)
+ RETURN
+ ENDIF
+
+ gblock%pio(:,:) = -1
+ WHERE (keep_block)
+ gblock%pio = p_iam_glb
+ 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 ', p_iam_glb
+ deallocate(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(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_SPMD_Task, only: spmd_exit
+ 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 spmd_exit()
+ colm_mpas_initialized = .false.
+ colm_mpas_restart_ready = .false.
+ 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: numelm
+#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 :: keep_elm(:)
+ logical, allocatable :: keep_patch(:)
+ logical, allocatable :: keep_pft(:)
+ integer, allocatable :: old_to_new(:)
+ integer, allocatable :: old_element_for_cell(:)
+ integer :: i
+ integer :: old_element
+ integer :: packed_count
+
+ ierr = 1
+ IF (n_mpas_cells < 1) RETURN
+ IF (numelm < 1) RETURN
+ IF (landelm%nset < 1) RETURN
+
+ allocate(keep_elm(numelm))
+ allocate(old_to_new(numelm))
+ allocate(old_element_for_cell(n_mpas_cells))
+
+ keep_elm = .false.
+ old_to_new = 0
+
+ DO i = 1, n_mpas_cells
+ CALL colm_mpas_find_element_by_eindex(mpas_cell_id(i), old_element)
+ IF (old_element <= 0 .or. old_element > numelm) RETURN
+
+ old_element_for_cell(i) = old_element
+ keep_elm(old_element) = .true.
+ ENDDO
+
+ packed_count = 0
+ DO i = 1, numelm
+ IF (keep_elm(i)) THEN
+ packed_count = packed_count + 1
+ old_to_new(i) = packed_count
+ ENDIF
+ ENDDO
+ IF (packed_count /= n_mpas_cells) RETURN
+
+ CALL colm_mpas_pack_mesh(keep_elm, old_to_new)
+ CALL landelm%pset_pack(keep_elm, packed_count)
+ CALL colm_mpas_remap_pixelset_ielm(landelm, old_to_new, ierr)
+ IF (ierr /= 0) RETURN
+
+ IF (landpatch%nset > 0) THEN
+ allocate(keep_patch(landpatch%nset))
+ DO i = 1, landpatch%nset
+ keep_patch(i) = landpatch%ielm(i) >= 1 .and. landpatch%ielm(i) <= size(old_to_new)
+ IF (keep_patch(i)) keep_patch(i) = old_to_new(landpatch%ielm(i)) > 0
+ ENDDO
+ CALL landpatch%pset_pack(keep_patch, numpatch)
+ CALL colm_mpas_remap_pixelset_ielm(landpatch, old_to_new, ierr)
+ deallocate(keep_patch)
+ IF (ierr /= 0) RETURN
+ ENDIF
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (landpft%nset > 0) THEN
+ allocate(keep_pft(landpft%nset))
+ DO i = 1, landpft%nset
+ keep_pft(i) = landpft%ielm(i) >= 1 .and. landpft%ielm(i) <= size(old_to_new)
+ IF (keep_pft(i)) keep_pft(i) = old_to_new(landpft%ielm(i)) > 0
+ ENDDO
+ CALL landpft%pset_pack(keep_pft, numpft)
+ CALL colm_mpas_remap_pixelset_ielm(landpft, old_to_new, ierr)
+ deallocate(keep_pft)
+ IF (ierr /= 0) RETURN
+ ENDIF
+#endif
+
+ DO i = 1, n_mpas_cells
+ cell_to_element(i) = old_to_new(old_element_for_cell(i))
+ IF (cell_to_element(i) <= 0) RETURN
+ ENDDO
+
+ ierr = 0
+ END SUBROUTINE colm_mpas_restrict_to_mpas_cells
+
+ SUBROUTINE colm_mpas_pack_mesh(keep_elm, old_to_new)
+ USE MOD_Mesh, only: irregular_elm_type, mesh, numelm, copy_elm
+ logical, intent(in) :: keep_elm(:)
+ integer, intent(in) :: old_to_new(:)
+
+ type(irregular_elm_type), allocatable :: packed_mesh(:)
+ integer :: old_elm
+ integer :: new_elm
+ integer :: packed_count
+
+ packed_count = count(keep_elm)
+ allocate(packed_mesh(packed_count))
+
+ DO old_elm = 1, size(keep_elm)
+ IF (.not. keep_elm(old_elm)) CYCLE
+ new_elm = old_to_new(old_elm)
+ CALL copy_elm(mesh(old_elm), packed_mesh(new_elm))
+ ENDDO
+
+ IF (allocated(mesh)) deallocate(mesh)
+ CALL move_alloc(packed_mesh, mesh)
+ numelm = packed_count
+ END SUBROUTINE colm_mpas_pack_mesh
+
+ SUBROUTINE colm_mpas_remap_pixelset_ielm(pixelset, old_to_new, ierr)
+ USE MOD_Pixelset, only: pixelset_type
+ type(pixelset_type), intent(inout) :: pixelset
+ integer, intent(in) :: old_to_new(:)
+ integer, intent(out) :: ierr
+
+ integer :: iset
+ integer :: old_elm
+
+ ierr = 1
+ DO iset = 1, pixelset%nset
+ old_elm = pixelset%ielm(iset)
+ IF (old_elm < 1 .or. old_elm > size(old_to_new)) RETURN
+ IF (old_to_new(old_elm) <= 0) RETURN
+ pixelset%ielm(iset) = old_to_new(old_elm)
+ ENDDO
+
+ ierr = 0
+ END SUBROUTINE colm_mpas_remap_pixelset_ielm
+
+ SUBROUTINE colm_mpas_find_element_by_eindex(cell_id, element)
+ USE MOD_LandElm, only: landelm
+ integer, intent(in) :: cell_id
+ integer, intent(out) :: element
+
+ integer :: i
+ integer :: hits
+ integer*8 :: cell_id_i8
+
+ element = 0
+ hits = 0
+ cell_id_i8 = cell_id
+ DO i = 1, landelm%nset
+ IF (landelm%eindex(i) == cell_id_i8) THEN
+ hits = hits + 1
+ element = i
+ ENDIF
+ ENDDO
+ IF (hits /= 1) element = 0
+ END SUBROUTINE colm_mpas_find_element_by_eindex
+
+ SUBROUTINE colm_mpas_validate_element_patch_map(require_active_patch, ierr)
+ USE MOD_LandElm, only: landelm
+ USE MOD_SPMD_Task, only: p_iam_glb
+ 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 :: has_patch
+
+ 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)
+ has_patch = .false.
+
+ IF (istt >= 1 .and. iend >= istt .and. iend <= numpatch) THEN
+ DO patch = istt, iend
+ IF (patch < 1 .or. patch > numpatch) CYCLE
+ IF (require_active_patch .and. allocated(patchmask)) THEN
+ IF (patchmask(patch)) has_patch = .true.
+ ELSE
+ has_patch = .true.
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (.not. has_patch) 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 is missing usable patch coverage on rank ', &
+ p_iam_glb, ': ', local_missing, ' element(s); first local element ', &
+ first_missing, ', eindex ', landelm%eindex(first_missing)
+ ELSE
+ write(*,'(A,I0,A,I0)') &
+ 'CoLM2024 MPAS embedded landdata is missing usable patch coverage on rank ', &
+ p_iam_glb, ': ', local_missing
+ ENDIF
+ RETURN
+ ENDIF
+
+ ierr = 0
+ END SUBROUTINE colm_mpas_validate_element_patch_map
+
+ 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 = allocated(forc_t) .and. allocated(oroflag) .and. allocated(fsena) .and. allocated(t_grnd) &
+ .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, &
+ 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
+ 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
+
+ ierr = 1
+ IF (.not. allocated(forc_t)) RETURN
+ IF (patch < 1 .or. patch > size(forc_t)) RETURN
+
+ 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
+ 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) .and. allocated(oroflag)) oroflag(patch) = oro
+ 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, &
+ 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
+ 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 (element < 1 .or. element > size(elm_patch%substt)) RETURN
+
+ istt = elm_patch%substt(element)
+ iend = elm_patch%subend(element)
+ IF (istt < 1 .or. iend < istt) RETURN
+
+ did_set = .false.
+ DO patch = istt, iend
+ IF (patch < 1 .or. patch > numpatch) CYCLE
+ 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, &
+ 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, &
+ 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, &
+ 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, &
+ 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)
+#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
+
+ logical :: ready
+
+ CALL colm_mpas_ready(ready)
+ ierr = 1
+ IF (.not. ready) RETURN
+
+ IF (numpatch > 0) CALL CoLMDRIVER(idate, deltim, dolai, doalb, dosst, oroflag)
+#ifdef GridRiverLakeFlow
+ CALL grid_riverlake_flow(idate(1), deltim)
+#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_write_restart_if_due(idate, deltim, force, ierr)
+ USE MOD_Namelist, only: DEF_WRST_FREQ
+ USE MOD_SPMD_Task, only: p_is_root
+ USE MOD_TimeManager, only: adj2begin
+ USE MOD_Vars_TimeVariables, only: save_to_restart, WRITE_TimeVariables
+#ifdef GridRiverLakeFlow
+ USE MOD_Grid_RiverLakeTimeVars, only: WRITE_GridRiverLakeTimeVars
+#endif
+ 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
+#if defined(GridRiverLakeFlow) && !defined(MPAS_EMBEDDED_COLM)
+ character(len=14) :: cdate
+ character(len=256) :: cyear
+ character(len=256) :: file_restart
+#endif
+
+ 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
+
+#ifdef GridRiverLakeFlow
+#ifdef MPAS_EMBEDDED_COLM
+ CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart)
+#else
+ IF (numpatch == 0) THEN
+ write(cyear,'(i4.4)') write_lc_year
+ write(cdate,'(i4.4,"-",i3.3,"-",i5.5)') write_idate(1), write_idate(2), write_idate(3)
+ IF (p_is_root) CALL system('mkdir -p ' // trim(colm_mpas_dir_restart)//'/'//trim(cdate))
+ file_restart = trim(colm_mpas_dir_restart)// '/'//trim(cdate)//'/' // &
+ trim(colm_mpas_casename) //'_restart_gridriver_'//trim(cdate)//'_lc'//trim(cyear)//'.nc'
+ CALL WRITE_GridRiverLakeTimeVars(file_restart)
+ ELSE
+ CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart)
+ ENDIF
+#endif
+#else
+#ifdef MPAS_EMBEDDED_COLM
+ CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart)
+#else
+ IF (numpatch > 0) CALL WRITE_TimeVariables(write_idate, write_lc_year, colm_mpas_casename, colm_mpas_dir_restart)
+#endif
+#endif
+ 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, &
+ surface_humidity, emissivity, roughness, albedo, 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) :: surface_humidity
+ real(r8), intent(out) :: emissivity, roughness, albedo
+ integer, intent(out) :: ierr
+
+ 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
+ surface_humidity = spval
+ emissivity = spval
+ roughness = spval
+ albedo = 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(t_grnd)) 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(t_grnd)) 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 = t_grnd(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)
+ IF (allocated(alb)) THEN
+ ! ponytail: bulk albedo average; replace with band/beam mapping when MPAS consumes CoLM spectral albedo.
+ IF (patch <= size(alb,3)) albedo = sum(alb(:,:,patch)) / real(size(alb(:,:,patch)), r8)
+ ENDIF
+ ierr = 0
+ END SUBROUTINE colm_mpas_get_surface
+
+ SUBROUTINE colm_mpas_get_element_surface(element, sensible, latent, evaporation, ground_heat, runoff, &
+ surface_runoff, subsurface_runoff, skin_temp, t2m, q2m, &
+ surface_humidity, emissivity, roughness, albedo, 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) :: surface_humidity
+ real(r8), intent(out) :: emissivity, roughness, albedo
+ 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) :: 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_surface_humidity
+ real(r8) :: patch_emissivity, patch_roughness, patch_albedo
+
+ 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
+ surface_humidity = spval
+ emissivity = spval
+ roughness = spval
+ albedo = spval
+
+ IF (.not. allocated(elm_patch%substt)) RETURN
+ IF (.not. allocated(elm_patch%subend)) RETURN
+ IF (.not. allocated(elm_patch%subfrc)) RETURN
+ IF (element < 1 .or. element > size(elm_patch%substt)) RETURN
+
+ istt = elm_patch%substt(element)
+ iend = elm_patch%subend(element)
+ IF (istt < 1 .or. iend < istt) 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
+ surface_humidity = 0._r8
+ emissivity = 0._r8
+ roughness = 0._r8
+ albedo_sum = 0._r8
+ albedo_wt = 0._r8
+ 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 (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_surface_humidity, &
+ patch_emissivity, patch_roughness, patch_albedo, patch_ierr)
+ IF (patch_ierr /= 0) THEN
+ WRITE(*,*) 'Error: failed to retrieve CoLM2024 patch surface:', element, patch, patch_ierr
+ RETURN
+ ENDIF
+
+ 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
+ skin_temp = skin_temp + wt * patch_skin_temp
+ t2m = t2m + wt * patch_t2m
+ q2m = q2m + wt * patch_q2m
+ surface_humidity = surface_humidity + wt * patch_surface_humidity
+ emissivity = emissivity + wt * patch_emissivity
+ roughness = roughness + wt * patch_roughness
+ 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
+ surface_humidity = spval
+ emissivity = spval
+ roughness = 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
+ skin_temp = skin_temp / sumwt
+ t2m = t2m / sumwt
+ q2m = q2m / sumwt
+ surface_humidity = surface_humidity / sumwt
+ emissivity = emissivity / sumwt
+ roughness = roughness / sumwt
+ IF (albedo_wt > 0._r8) albedo = albedo_sum / albedo_wt
+ ierr = 0
+ END SUBROUTINE colm_mpas_get_element_surface
+
+ SUBROUTINE colm_mpas_get_element_state(element, canopy_water, snow_water, snow_depth, snow_cover, &
+ leaf_area_index, soil_liquid, 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) :: soil_liquid(:), 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) :: bad_value
+ 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_liquid
+ real(r8) :: patch_moisture
+ real(r8) :: soil_wt(size(soil_liquid))
+
+ ierr = 1
+ canopy_water = spval
+ snow_water = spval
+ snow_depth = spval
+ snow_cover = spval
+ leaf_area_index = spval
+ soil_liquid(:) = spval
+ soil_moisture(:) = spval
+ soil_temperature(:) = spval
+
+ nlev = min(size(soil_liquid), size(soil_moisture), size(soil_temperature), nl_soil)
+ IF (nlev < 1) RETURN
+ 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_soisno)) RETURN
+ IF (.not. allocated(wliq_soisno)) RETURN
+ IF (.not. allocated(wice_soisno)) RETURN
+ IF (element < 1 .or. element > size(elm_patch%substt)) RETURN
+
+ istt = elm_patch%substt(element)
+ iend = elm_patch%subend(element)
+ IF (istt < 1 .or. iend < istt) 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
+ soil_liquid(:) = 0._r8
+ soil_moisture(:) = 0._r8
+ soil_temperature(:) = 0._r8
+ soil_wt(:) = 0._r8
+ sumwt = 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 (wt <= 0._r8) CYCLE
+
+ patch_canopy_water = ldew(patch)
+ IF (abs(patch_canopy_water) >= bad_value) patch_canopy_water = 0._r8
+ patch_snow_water = scv(patch)
+ IF (abs(patch_snow_water) >= bad_value) patch_snow_water = 0._r8
+ patch_snow_depth = snowdp(patch)
+ IF (abs(patch_snow_depth) >= bad_value) patch_snow_depth = 0._r8
+ patch_snow_cover = fsno(patch)
+ IF (abs(patch_snow_cover) >= bad_value) patch_snow_cover = 0._r8
+ patch_lai = lai(patch)
+ IF (abs(patch_lai) >= bad_value) patch_lai = 0._r8
+
+ 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)
+
+ DO n = 1, nlev
+ IF (n < lbound(t_soisno, 1) .or. n > ubound(t_soisno, 1)) CYCLE
+ IF (dz_soi(n) <= 0._r8) CYCLE
+ IF (abs(t_soisno(n, patch)) >= bad_value) CYCLE
+ IF (abs(wliq_soisno(n, patch)) >= bad_value) CYCLE
+ IF (abs(wice_soisno(n, patch)) >= bad_value) CYCLE
+
+ patch_liquid = max(0._r8, wliq_soisno(n, patch) / (1000._r8 * dz_soi(n)))
+ patch_moisture = max(0._r8, (wliq_soisno(n, patch) + wice_soisno(n, patch)) / (1000._r8 * dz_soi(n)))
+ soil_liquid(n) = soil_liquid(n) + wt * min(1._r8, patch_liquid)
+ soil_moisture(n) = soil_moisture(n) + wt * min(1._r8, 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
+ soil_liquid(:) = 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
+
+ DO n = 1, nlev
+ IF (soil_wt(n) > 0._r8) THEN
+ soil_liquid(n) = soil_liquid(n) / soil_wt(n)
+ soil_moisture(n) = soil_moisture(n) / soil_wt(n)
+ soil_temperature(n) = soil_temperature(n) / soil_wt(n)
+ ELSE
+ soil_liquid(n) = spval
+ soil_moisture(n) = spval
+ soil_temperature(n) = spval
+ ENDIF
+ 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..d3f5da4b34
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/include/define.h
@@ -0,0 +1,115 @@
+! 1. Spatial structure:
+! Select one of the following options.
+#define GRIDBASED
+#undef CATCHMENT
+#undef 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. If defined, debug information is output.
+#define CoLMDEBUG
+! 3.1 If defined, range of variables is checked.
+#define RangeCheck
+! 3.1 If defined, surface data in vector is mapped to gridded data for checking.
+#undef SrfdataDiag
+
+! 4. CoLM uses MPI collectives through MPAS-owned communicators. The legacy
+! CoLM process-pool decomposition is disabled in MOD_SPMD_Task.
+#define USEMPI
+
+! 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 local land-surface physics package on each MPAS rank.
+! Reusing the legacy CoLM process split inside MPAS leaves some
+! ranks without patch forcing/flux arrays, so the embedded library keeps CoLM
+! land state on MPAS-owned cells. MPAS also supplies broadband shortwave forcing.
+#define MPAS_EMBEDDED_COLM
+#ifdef MPAS_EMBEDDED_COLM
+#ifndef USEMPI
+#define USEMPI
+#endif
+#undef HYPERSPECTRAL
+#undef CoLMDEBUG
+! CoLM range diagnostics still assume the standalone role split.
+#undef RangeCheck
+#endif
+
+#undef COLM_PARALLEL
+#if defined(USEMPI)
+#define COLM_PARALLEL
+#endif
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..df66ec3151
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNBalanceCheck.F90
@@ -0,0 +1,273 @@
+#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_SPMD_Task
+ 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, p_iam_glb
+ 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
+#ifdef USEMPI
+ CALL mpi_abort (p_comm_glb, p_err)
+#else
+ CALL abort
+#endif
+ 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, p_iam_glb
+ 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
+#ifdef USEMPI
+ CALL mpi_abort (p_comm_glb, p_err)
+#else
+ CALL abort
+#endif
+ 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..f4cd21b975
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_CNSASU.F90
@@ -0,0 +1,1074 @@
+#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_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 abort
+ 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..0d612d9eb7
--- /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_SPMD_Task
+
+ 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:',p_iam_glb,'i=',i,'ps',ps,'does not equal to pe',pe
+ CALL abort
+ 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:',p_iam_glb,'i=',i,'ps',ps,'does not equal to pe',pe
+ CALL abort
+ 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..aa07e6c7c3
--- /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_SPMD_Task
+
+ 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..b255dfe366
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/BGC/MOD_BGC_Soil_BiogeochemVerticalProfile.F90
@@ -0,0 +1,237 @@
+#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_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 abort()
+ 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 abort
+ 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..ae192eb1c3
--- /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_SPMD_Task
+ USE MOD_LandPatch
+ IMPLICIT NONE
+
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPatch
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPatch
+ IMPLICIT NONE
+ real(r8),intent(in) :: Values
+ real(r8),intent(in) :: Nan
+
+
+ IF (p_is_compute) 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..916ac32018
--- /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_SPMD_Task
+ USE MOD_LandPFT
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPFT
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPFT
+ IMPLICIT NONE
+ real(r8),intent(in) :: Values
+ real(r8),intent(in) :: Nan
+
+ IF (p_is_compute) 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..b91c4e7301
--- /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_SPMD_Task
+ USE MOD_LandPFT
+ USE MOD_Vars_Global
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPFT
+
+ IF (p_is_compute) 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_SPMD_Task
+ 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..6d9d9605a9
--- /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_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ 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 USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#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_SPMD_Task
+ 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 USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_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_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+ ! --------------------------------------------------
+ ! Deallocates memory for CoLM 1d [numpatch] variables
+ ! --------------------------------------------------
+
+ IF (p_is_compute) 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_SPMD_Task
+ 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..ec3ee02169
--- /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_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+! --------------------------------------------------
+! Deallocates memory for CoLM 1d [numpatch] variables
+! --------------------------------------------------
+
+ IF (p_is_compute) 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_SPMD_Task
+ 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_SPMD_Task
+ 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..8513dde698
--- /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_SPMD_Task
+
+ 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..8cb4a8bba1
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/CoLMDRIVER.F90
@@ -0,0 +1,355 @@
+#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_forcing, DEF_URBAN_RUN
+ USE MOD_Forcing, only: forcmask_pch
+ USE omp_lib
+#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
+
+! ======================================================================
+
+#ifdef OPENMP
+!$OMP PARALLEL DO NUM_THREADS(OPENMP) &
+!$OMP PRIVATE(i, m, u, k, steps_in_one_deltim, deltim_phy) &
+!$OMP SCHEDULE(STATIC, 1)
+#endif
+
+ DO i = 1, numpatch
+
+ ! Apply forcing mask
+ IF (DEF_forcing%has_missing_value) THEN
+ IF (.not. forcmask_pch(i)) CYCLE
+ ENDIF
+
+ ! 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
+#ifdef OPENMP
+!$OMP END PARALLEL DO
+#endif
+
+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..2b2ca31314
--- /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_SPMD_Task
+
+#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/DA/MOD_DA_Const.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90
new file mode 100644
index 0000000000..f4280b27fe
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Const.F90
@@ -0,0 +1,143 @@
+#include
+
+#ifdef DataAssimilation
+MODULE MOD_DA_Const
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! 1. Define constants (do not rely on satellite parameters) used in RTM.
+! 2. Define parameters (IGBP) used in RTM.
+!
+! REFERENCES:
+! [1] L-band Microwave Emission of the Biosphere (L-MEB) Model: Description
+! and calibration against experimental data sets over crop fields.
+!
+! [2] Wigneron, J. P., Jackson, T. J., O'neill, P., De Lannoy, G., de Rosnay, P., Walker,
+! J. P., ... & Kerr, Y. (2017). Modelling the passive microwave signature from land surfaces:
+! A review of recent results and application to the L-band SMOS & SMAP soil moisture retrieval algorithms.
+! Remote Sensing of Environment, 192, 238-262.
+!
+! AUTHOR:
+! Lu Li, 12/2024: Initial version
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Vars_Global, only: pi, N_land_classification
+
+ IMPLICIT NONE
+ SAVE
+
+ ! Constant variables
+ real(r8), parameter :: C = 2.998e8 ! speed of light (m/s)
+ real(r8), parameter :: mu0 = 4.*pi*1e-7 ! vacuum permeability (H/m)
+ real(r8), parameter :: eps0 = 8.854e-12 ! vacuum permittivity (Klein and Swift 1977) [Farads/meter]
+ real(r8), parameter :: z0 = sqrt(mu0/eps0) ! impendace of free space (Ohm)
+ real(r8), parameter :: eps_w_inf = 4.9 ! dielectric constant at infinite frequency (Stogryn 1971),
+ real(r8), parameter :: eps_0 = 8.854e-12 ! dielectric constant of free space (Klein and Swift 1977) [Farads/meter]
+ real(r8), parameter :: rho_soil = 2.66 ! soil specific density (g/cm3)
+ real(r8), parameter :: f0w = 9. ! relaxation frequency of liquid water (GHz)
+ real(r8), parameter :: rgh_surf = 2.2 ! soil surface roughness (cm)
+ complex(r8), parameter :: jj = (0., 1.) ! imaginary unit for complex number
+
+
+#ifdef LULC_IGBP
+
+ ! 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 ! 水体
+
+ ! empirical parameters to account for the dependence of optical depth on incidence angle [1]
+ real(r8), parameter, dimension(N_land_classification) :: tth &
+ = (/0.80, 1.00, 0.80, 0.49, 0.49, &
+ 1.00, 1.00, 1.00, 1.00, 1.00, &
+ 1.00, 1.00, 1.00, 1.00, 1.00, &
+ 1.00, 2.00/)
+ real(r8), parameter, dimension(N_land_classification) :: ttv &
+ = (/0.80, 1.00, 0.80, 0.46, 0.46, &
+ 1.00, 1.00, 1.00, 1.00, 1.00, &
+ 1.00, 2.00, 1.00, 2.00, 1.00, &
+ 1.00, 1.00/)
+
+ ! empirical roughness parameters (Table 2 in [2])
+ real(r8), parameter, dimension(N_land_classification) :: hr_SMAP &
+ = (/0.160, 0.160, 0.160, 0.160, 0.160, &
+ 0.110, 0.110, 0.125, 0.156, 0.156, &
+ 0.100, 0.108, 0.000, 0.130, 0.000, &
+ 0.150, 0.000/)
+
+ real(r8), parameter, dimension(N_land_classification) :: hr_SMOS &
+ = (/0.300, 0.300, 0.300, 0.300, 0.300, &
+ 0.100, 0.100, 0.100, 0.100, 0.100, &
+ 0.100, 0.100, 0.100, 0.100, 0.000, &
+ 0.100, 0.000/)
+
+ real(r8), parameter, dimension(N_land_classification) :: hr_P16 &
+ = (/0.350, 0.460, 0.430, 0.450, 0.410, &
+ 0.260, 0.170, 0.350, 0.230, 0.130, &
+ 0.020, 0.170, 0.190, 0.220, 0.000, &
+ 0.020, 0.000/)
+
+ ! b parameters for Wigneron vegetation model (ref?)
+ real(r8), parameter, dimension(N_land_classification) :: b1 &
+ = (/0.2600, 0.2260, 0.2600, 0.2260, 0.2260, &
+ 0.0375, 0.0375, 0.0375, 0.0375, 0.0375, &
+ 0.0000, 0.0500, 0.0000, 0.0500, 0.0000, &
+ 0.0000, 0.0500/)
+
+ real(r8), parameter, dimension(N_land_classification) :: b2 &
+ = (/0.0060, 0.0010, 0.0060, 0.0010, 0.0010, &
+ 0.0500, 0.0500, 0.0500, 0.0500, 0.0500, &
+ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
+ 0.0000, 0.0000/)
+
+ real(r8), parameter, dimension(N_land_classification) :: b3 &
+ = (/0.6900, 0.7000, 0.6900, 0.7000, 0.7000, &
+ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
+ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, &
+ 0.0000, 0.0000/)
+
+ ! effective diffusion albedo (Table 3 in [2])
+ real(r8), parameter, dimension(N_land_classification) :: w_SMAPL2 &
+ = (/0.050, 0.050, 0.050, 0.050, 0.050, &
+ 0.050, 0.050, 0.050, 0.080, 0.050, &
+ 0.050, 0.000, 0.065, 0.000, 0.000, &
+ 0.000, 0.000/)
+
+ real(r8), parameter, dimension(N_land_classification) :: w_CMEM &
+ = (/0.080, 0.095, 0.080, 0.070, 0.070, &
+ 0.050, 0.050, 0.050, 0.050, 0.050, &
+ 0.000, 0.000, 0.000, 0.000, 0.000, &
+ 0.000, 0.000/)
+
+ real(r8), parameter, dimension(N_land_classification) :: w_K16 &
+ = (/0.050, 0.050, 0.060, 0.030, 0.050, &
+ 0.030, 0.050, 0.040, 0.020, 0.030, &
+ 0.000, 0.040, 0.000, 0.020, 0.000, &
+ 0.000, 0.000/)
+
+ real(r8), parameter, dimension(N_land_classification) :: w_SMAPL4 &
+ = (/0.120, 0.080, 0.120, 0.100, 0.120, &
+ 0.140, 0.110, 0.130, 0.120, 0.070, &
+ 0.000, 0.120, 0.000, 0.150, 0.000, &
+ 0.000, 0.000/)
+#endif
+
+END MODULE MOD_DA_Const
+!-----------------------------------------------------------------------------
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90
new file mode 100644
index 0000000000..1ec32f06e1
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_EnKF.F90
@@ -0,0 +1,137 @@
+#include
+
+#ifdef DataAssimilation
+MODULE MOD_DA_EnKF
+!-----------------------------------------------------------------------------
+! DESCRIPTION:
+! ensemble Kalman filter (EnKF) types
+!
+! AUTHOR:
+! Lu Li, 12/2024: Initial version
+! Zhilong Fan, Lu Li, 03/2024: Debug and clean codes
+!-----------------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ IMPLICIT NONE
+ SAVE
+
+! public functions
+ PUBLIC :: letkf
+
+
+!-----------------------------------------------------------------------------
+
+CONTAINS
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE letkf (&
+ num_ens, num_obs, &
+ HA, y, R, infl, &
+ trans)
+
+!-----------------------------------------------------------------------------
+! Description:
+! local transform ensemble Kalman filter
+!
+! Original author :
+! Lu Li, 12/2024
+!-----------------------------------------------------------------------------
+ USE MOD_Precision
+ IMPLICIT NONE
+
+!------------------------ Dummy Arguments ------------------------------------
+ integer, intent(in) :: num_ens ! ensemble size
+ integer, intent(in) :: num_obs ! number of observations
+ real(r8), intent(in) :: HA(num_obs, num_ens) ! ensemble predicted observation matrix
+ real(r8), intent(in) :: y(num_obs) ! observation vector
+ real(r8), intent(in) :: R(num_obs) ! observation error variance
+ real(r8), intent(in) :: infl ! inflation factor
+ real(r8), intent(out) :: trans(num_ens, num_ens) ! transform matrix (k x k)
+
+!------------------------ Local Variables ------------------------------------
+ real(r8) :: HA_mean(num_obs) ! mean of ensemble predicted observation (l)
+ real(r8) :: dHA(num_obs, num_ens) ! HA - mean(HA) (l x k)
+ real(r8) :: dHA_t(num_ens, num_obs) ! transpose of dHA (k x l)
+ real(r8) :: C(num_ens, num_obs) ! C = (dHA)^T * (R)^-1 (k x l)
+ real(r8) :: M1(num_ens, num_ens) ! C * dHA (k x k)
+ real(r8) :: pa_inv(num_ens, num_ens) ! inverse of background error covariance matrix (k x k)
+ real(r8) :: eigval(num_ens) ! eigenvalues of pa_inv (k)
+ real(r8) :: eigvec(num_ens, num_ens) ! eigenvectors of pa_inv (k x k)
+ integer :: lwork
+ real(r8), allocatable :: work(:)
+ integer :: err
+ real(r8) :: M2(num_ens, num_ens) ! M2 = eigvec * eigval^-1 (k x k)
+ real(r8) :: pa(num_ens, num_ens) ! background error covariance matrix (k x k)
+ real(r8) :: M3(num_ens, num_obs) ! M3 = pa * C (k x l)
+ real(r8) :: delta(num_obs) ! increment of observation (l)
+ real(r8) :: w_avg(num_ens) ! weight (k)
+ real(r8) :: M4(num_ens, num_ens) ! M4 = eigvec * sqrt((k-1)/eigval) (k x k)
+ real(r8) :: trans_pert(num_ens, num_ens) ! perturbation transform matrix (k x k)
+ real(r8) :: I0(num_ens, num_ens) ! identity matrix (k x k)
+ real(r8) :: one_div_ens(num_ens) ! 1/num_ens
+ integer :: i, j
+
+!-----------------------------------------------------------------------------
+
+ ! calculate observation space perturbation
+ HA_mean = sum(HA, dim=2) / size(HA, dim=2) !(lx1)
+ DO j = 1, num_ens
+ dHA(:,j) = HA(:,j) - HA_mean !(lxk)
+ ENDDO
+
+ ! calculate C, intermediate matrix in localized observation
+ dHA_t = transpose(dHA) !(kxl)
+ DO j = 1, num_obs
+ C(:,j) = dHA_t(:,j) / (R(j)) !(kxl)
+ ENDDO
+
+ ! calculate C*dHA, intermediate matrix in background error M1
+ CALL dgemm('N', 'N', num_ens, num_ens, num_obs, 1.0_8, C, num_ens, dHA, num_obs, 0.0_8, M1, num_ens)
+
+ ! calculate inverse of background error
+ pa_inv = M1
+ do i=1, num_ens
+ pa_inv(i,i) = M1(i,i) + (num_ens-1)*1.0d0/infl
+ end do
+
+ ! eigenvalues and eigenvectors of inverse of background error
+ lwork = 4 * num_ens
+ allocate( work(lwork) )
+ CALL dsyev('V', 'U', num_ens, pa_inv, num_ens, eigval, work, lwork, err)
+ eigvec = pa_inv !(kxk)
+
+ ! calculate background error covariance matrix pa = eigvec (eigval)^-1 eigvec^T
+ DO i = 1, num_ens
+ M2(:,i) = eigvec(:,i) / eigval(i) !(kxk)
+ ENDDO
+ CALL dgemm('N', 'T', num_ens, num_ens, num_ens, 1.0_8, M2, num_ens, eigvec, num_ens, 0.0_8, pa, num_ens) !(kxk)
+
+ ! caculate pa * C, intermediate matrix in Kalman gain M3
+ CALL dgemm('N', 'N', num_ens, num_obs, num_ens, 1.0_8, pa, num_ens, C, num_ens, 0.0_8, M3, num_ens) !(kxl)
+
+ ! calculate weight
+ delta = y - HA_mean
+ CALL dgemm('N', 'N', num_ens, 1, num_obs, 1.0_8, M3, num_ens, delta, num_obs, 0.0_8, w_avg, num_ens) !(kx1)
+
+ ! calculate pertubation transform matrix
+ DO j = 1, num_ens
+ M4(:,j) = eigvec(:,j) * sqrt((num_ens-1) / eigval(j)) !(kxk)
+ ENDDO
+ CALL dgemm('N', 'T', num_ens, num_ens, num_ens, 1.0_8, M4, num_ens, eigvec, num_ens, 0.0_8, trans_pert, num_ens) !(kxk)
+
+ ! calculate transform matrix
+ one_div_ens(:) = 1./num_ens
+ I0 = -1.0 / num_ens
+ DO i = 1, num_ens
+ I0(i, i) = 1.0 - 1./num_ens
+ ENDDO
+ DO j = 1, num_ens
+ trans(:, j) = matmul(trans_pert(:, j) + w_avg(:), I0) + one_div_ens(:)
+ ENDDO
+
+ END SUBROUTINE letkf
+
+!-----------------------------------------------------------------------------
+END MODULE MOD_DA_EnKF
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90
new file mode 100644
index 0000000000..8eea429ae2
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Ensemble.F90
@@ -0,0 +1,267 @@
+#include
+
+#ifdef DataAssimilation
+MODULE MOD_DA_Ensemble
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Provide functions to generate ensemble samples for data assimilation
+!
+! REFERENCES:
+! [1] Algorithm Theoretical Basis Document Level 4 Surface and Root
+! Zone Soil Moisture (L4_SM) Data Product
+!
+! AUTHOR:
+! Lu Li, 12/2024: Initial version
+! Lu Li, 10/2025: Consider correlation & AR(1) process
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Namelist
+ USE MOD_Vars_TimeVariables
+ USE MOD_DA_Vars_TimeVariables
+ USE MOD_Vars_1DForcing
+ USE MOD_LandPatch
+ IMPLICIT NONE
+ SAVE
+
+ ! public functions
+ PUBLIC :: ensemble
+
+ ! local parameters
+ ! forcing [parameters used here is consistent with SMAP L4 (Table 4 in [1])]
+ integer, parameter :: nvar = 4 ! number of pertutated forcing variables
+ real(r8), parameter :: tau_ar = 24.0 ! correlation time scale in hours
+
+ real(r8) :: dt ! time step in hours
+ real(r8) :: phi ! AR(1) autocorrelation coefficient consider time scale
+ real(r8) :: sigma_eps ! standard deviation of noise in AR(1) process
+ real(r8), dimension(nvar) :: sigma = (/0.5, 0.3, 20.0, 1.0/) ! standard deviation of perturbed forcing variables (prcp, sw, lw, t)
+ real(r8), dimension(nvar, nvar) :: C = reshape([ &
+ 1.0, -0.8, 0.5, 0.0, &
+ -0.8, 1.0, -0.5, 0.4, &
+ 0.5, -0.5, 1.0, 0.4, &
+ 0.0, 0.4, 0.4, 1.0], shape=[nvar, nvar]) ! cross-correlation matrix between perturbed forcing variables
+ real(r8), allocatable :: r_prev(:,:,:) ! previous perturbation (numpatch, nvar, DEF_DA_ENS_NUM)
+ real(r8), allocatable :: r_curr(:,:,:) ! current perturbation (numpatch, nvar, DEF_DA_ENS_NUM)
+ logical :: initialized = .false. ! flag to indicate if is initialized
+
+ ! soil moisture [default set 0.002 m3/m3 disterbulance]
+ integer, parameter :: nvar_sm = 2 ! number of pertutated soil moisture layers
+ real(r8), parameter :: tau_sm = 3.0 ! correlation time scale in hours
+ real(r8) :: phi_sm ! AR(1) autocorrelation coefficient consider time scale
+ real(r8) :: sigma_eps_sm ! standard deviation of noise in AR(1) process
+ real(r8), dimension(nvar_sm) :: sigma_sm = (/0.035, 0.0552/) ! standard deviation of perturbed soil moisture (equal to 0.002 m3/m3)
+ real(r8), allocatable :: r_prev_sm(:,:,:) ! previous perturbation (numpatch, nvar_sm, DEF_DA_ENS_NUM)
+ real(r8), allocatable :: r_curr_sm(:,:,:) ! current perturbation (numpatch, nvar_sm, DEF_DA_ENS_NUM)
+
+!-----------------------------------------------------------------------
+
+CONTAINS
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE ensemble(deltim)
+
+!-----------------------------------------------------------------------
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: deltim
+
+!------------------------ Local Variables ------------------------------
+ integer :: np, i, j
+
+ real(r8) :: cov_matrix(nvar, nvar) ! covariance matrix between perturbed forcing variables
+ real(r8) :: L(nvar, nvar) ! Cholesky decomposition of correlation matrix
+ integer :: info ! info flag for Cholesky decomposition
+ real(r8) :: u1(DEF_DA_ENS_NUM/2), u2(DEF_DA_ENS_NUM/2) ! uniform random variables
+ real(r8) :: z(nvar, DEF_DA_ENS_NUM) ! standard normal random variables
+ real(r8) :: mean_z(nvar) ! mean of perturbation (nvar)
+ real(r8) :: std_z(nvar) ! std of perturbation (nvar)
+ real(r8) :: zxL(nvar, DEF_DA_ENS_NUM) ! correlated random variables (nvar, DEF_DA_ENS_NUM)
+
+ real(r8) :: z_sm(DEF_DA_ENS_NUM) ! standard normal random variables
+ real(r8) :: mean_z_sm ! mean of perturbation
+ real(r8) :: std_z_sm ! std of perturbation
+ real(r8) :: mean_r_sm(nvar_sm) ! mean of perturbation for soil moisture (nvar_sm)
+ real(r8) :: std_r_sm(nvar_sm) ! std of perturbation for soil moisture (nvar_sm)
+ real(r8) :: a1(DEF_DA_ENS_NUM) ! temporary disturbed variable for soil moisture layer 1
+ real(r8) :: a2(DEF_DA_ENS_NUM) ! temporary disturbed variable for soil moisture layer 2
+
+!-----------------------------------------------------------------------
+
+ ! initialize persistent variables
+ IF (.not. initialized) THEN
+ allocate(r_prev(numpatch, nvar, DEF_DA_ENS_NUM))
+ allocate(r_curr(numpatch, nvar, DEF_DA_ENS_NUM))
+ allocate(r_prev_sm(numpatch, nvar_sm, DEF_DA_ENS_NUM))
+ allocate(r_curr_sm(numpatch, nvar_sm, DEF_DA_ENS_NUM))
+ r_prev = 0.0_r8
+ r_curr = 0.0_r8
+ r_prev_sm = 0.0_r8
+ r_curr_sm = 0.0_r8
+ initialized = .true.
+ ENDIF
+
+ ! calculate AR(1) parameters
+ dt = deltim/3600
+ phi = exp(-dt/tau_ar)
+ sigma_eps = sqrt(1.0 - phi**2)
+ phi_sm = exp(-dt/tau_sm)
+ sigma_eps_sm = sqrt(1.0 - phi_sm**2)
+
+ ! calculate covariance matrix by cross-correlation matrix and standard deviation
+ cov_matrix = 0.0_r8
+ DO i = 1, nvar
+ DO j = 1, nvar
+ cov_matrix(i,j) = C(i,j) * sigma(i) * sigma(j)
+ ENDDO
+ ENDDO
+
+ ! perform Cholesky decomposition of covariance matrix
+ L = cov_matrix
+ CALL dpotrf('L', nvar, L, nvar, info)
+ DO i = 1, nvar
+ DO j = i+1, nvar
+ L(i,j) = 0.0_r8
+ ENDDO
+ ENDDO
+ IF (info /= 0) THEN
+ print *, 'Error: Cholesky decomposition failed'
+ stop
+ ENDIF
+
+ ! Generate ensemble samples for forcing variables
+ DO np = 1, numpatch
+ ! generate disturbance ensemble samples ~ N(0, I)
+ CALL random_seed()
+ CALL random_number(u1)
+ CALL random_number(u2)
+ DO i = 1, DEF_DA_ENS_NUM/2
+ u1(i) = max(u1(i), 1e-10) ! ensure u1 is not zero
+ z(1,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i))
+ z(1,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i))
+ ENDDO
+ CALL random_seed()
+ CALL random_number(u1)
+ CALL random_number(u2)
+ DO i = 1, DEF_DA_ENS_NUM/2
+ u1(i) = max(u1(i), 1e-10)
+ z(2,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i))
+ z(2,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i))
+ ENDDO
+ CALL random_seed()
+ CALL random_number(u1)
+ CALL random_number(u2)
+ DO i = 1, DEF_DA_ENS_NUM/2
+ u1(i) = max(u1(i), 1e-10)
+ z(3,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i))
+ z(3,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i))
+ ENDDO
+ CALL random_seed()
+ CALL random_number(u1)
+ CALL random_number(u2)
+ DO i = 1, DEF_DA_ENS_NUM/2
+ u1(i) = max(u1(i), 1e-10)
+ z(4,i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i))
+ z(4,i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i))
+ ENDDO
+
+ ! normalize z to mean 0 and std 1
+ DO i = 1, nvar
+ mean_z(i) = sum(z(i, :))/DEF_DA_ENS_NUM
+ std_z(i) = sqrt(sum((z(i, :) - mean_z(i))**2)/(DEF_DA_ENS_NUM - 1))
+ ENDDO
+ DO i = 1, nvar
+ z(i,:) = (z(i,:)-mean_z(i))/std_z(i)
+ ENDDO
+
+ ! multiply by Cholesky factor to introduce correlation (z*L)
+ CALL dgemm('N', 'N', nvar, DEF_DA_ENS_NUM, nvar, 1.0_r8, L, nvar, z, nvar, 0.0_r8, zxL, nvar)
+
+ ! introduce correlation using AR(1) process
+ DO i = 1, nvar
+ DO j = 1, DEF_DA_ENS_NUM
+ r_curr(np,i,j) = phi * r_prev(np,i,j) + sigma_eps * zxL(i,j)
+ ENDDO
+ ENDDO
+ ! no AR(1) process, directly use correlated random variables
+ ! r_curr(np,:,:) = zxL
+
+ ! normalize the disturbance ensemble samples to mean 0
+ mean_z = sum(r_curr(np,:,:), dim=2)/DEF_DA_ENS_NUM
+ DO i = 1, nvar
+ DO j = 1, DEF_DA_ENS_NUM
+ r_curr(np,i,j) = r_curr(np,i,j) - mean_z(i)
+ ENDDO
+ ENDDO
+
+ ! save current perturbation as previous perturbation for next time step
+ r_prev = r_curr
+
+ ! generate ensemble samples according different types
+ DO j = 1, DEF_DA_ENS_NUM
+ forc_prc_ens(j,np) = forc_prc(np) * exp(r_curr(np,1,j) - 0.5 * sigma(1)**2)
+ forc_prl_ens(j,np) = forc_prl(np) * exp(r_curr(np,1,j) - 0.5 * sigma(1)**2)
+ forc_sols_ens(j,np) = forc_sols(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2)
+ forc_soll_ens(j,np) = forc_soll(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2)
+ forc_solsd_ens(j,np) = forc_solsd(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2)
+ forc_solld_ens(j,np) = forc_solld(np) * exp(r_curr(np,2,j) - 0.5 * sigma(2)**2)
+ forc_frl_ens(j,np) = forc_frl(np) + r_curr(np,3,j)
+ forc_t_ens(j,np) = forc_t(np) + r_curr(np,4,j)
+ ENDDO
+
+ IF (DEF_DA_ENS_SM) THEN
+ ! generate ensemble samples (0, I) for soil moisture
+ CALL random_seed()
+ CALL random_number(u1)
+ CALL random_number(u2)
+ DO i = 1, DEF_DA_ENS_NUM/2
+ u1(i) = max(u1(i), 1e-10)
+ z_sm(i*2-1) = sqrt(-2.0*log(u1(i))) * cos(2.0*pi*u2(i))
+ z_sm(i*2) = sqrt(-2.0*log(u1(i))) * sin(2.0*pi*u2(i))
+ ENDDO
+ mean_z_sm = sum(z_sm)/DEF_DA_ENS_NUM
+ std_z_sm = sqrt(sum((z_sm - mean_z_sm)**2)/(DEF_DA_ENS_NUM - 1))
+ z_sm = (z_sm - mean_z_sm)/std_z_sm
+
+ ! introduce correlation using AR(1) process
+ DO i = 1, nvar_sm
+ DO j = 1, DEF_DA_ENS_NUM
+ r_curr_sm(np,i,j) = phi_sm * r_prev_sm(np,i,j) + sigma_eps_sm * sigma_sm(i) * z_sm(j)
+ ENDDO
+ ENDDO
+
+ ! normalize the disturbance ensemble samples to mean 0
+ mean_r_sm = sum(r_curr_sm(np,:,:), dim=2)/DEF_DA_ENS_NUM
+ DO i = 1, nvar_sm
+ DO j = 1, DEF_DA_ENS_NUM
+ r_curr_sm(np,i,j) = r_curr_sm(np,i,j) - mean_r_sm(i)
+ ENDDO
+ ENDDO
+
+ ! save current perturbation as previous perturbation for next time step
+ r_prev_sm = r_curr_sm
+
+ ! generate ensemble samples according different types
+ DO j = 1, DEF_DA_ENS_NUM
+ a1(j) = wliq_soisno_ens(1,j,np) + r_curr_sm(np,1,j)
+ a2(j) = wliq_soisno_ens(2,j,np) + r_curr_sm(np,2,j)
+ ENDDO
+ DO j = 1, DEF_DA_ENS_NUM
+ a1(j) = max(1e-10, a1(j))
+ a2(j) = max(1e-10, a2(j))
+ ENDDO
+
+ ! move residual water to water table
+ DO j = 1, DEF_DA_ENS_NUM
+ wa_ens(j, np) = wa_ens(j, np) - (sum(wliq_soisno_ens(1:2, j, np)) - a1(j) - a2(j))
+ wliq_soisno_ens(1, j, np) = a1(j)
+ wliq_soisno_ens(2, j, np) = a2(j)
+ ENDDO
+ ENDIF
+ ENDDO
+
+ END SUBROUTINE ensemble
+
+!-----------------------------------------------------------------------
+END MODULE MOD_DA_Ensemble
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90
new file mode 100644
index 0000000000..70ab7e8981
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Main.F90
@@ -0,0 +1,396 @@
+#include
+
+#ifdef DataAssimilation
+MODULE MOD_DA_Main
+!-----------------------------------------------------------------------------
+! DESCRIPTION:
+! Main procedures for data assimilation
+!
+! AUTHOR:
+! Lu Li, 12/2024
+! Zhilong Fan, Lu Li, 03/2024
+!-----------------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Spmd_task
+ USE MOD_Namelist
+ USE MOD_TimeManager
+ USE MOD_LandPatch
+ USE MOD_DA_TWS
+ USE MOD_DA_SM
+ USE MOD_DA_Ensemble
+ USE MOD_Vars_1DFluxes
+ USE MOD_Vars_TimeVariables
+ USE MOD_Vars_1DForcing
+ IMPLICIT NONE
+ SAVE
+
+!-----------------------------------------------------------------------------
+
+CONTAINS
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE init_DA ()
+
+!-----------------------------------------------------------------------------
+ IMPLICIT NONE
+
+!-----------------------------------------------------------------------------
+
+!#############################################################################
+! Init data assimilation for different products
+!#############################################################################
+ IF (DEF_DA_TWS) THEN
+ IF (DEF_DA_TWS_GRACE) THEN
+ CALL init_DA_GRACE ()
+ ENDIF
+ ENDIF
+
+ IF (DEF_DA_SM) THEN
+ IF (p_is_root) THEN
+ print *, '[CoLM-DA] initialize surface soil moisture & temperature data assimilation.'
+ ENDIF
+ CALL init_DA_SM ()
+ ENDIF
+
+ END SUBROUTINE init_DA
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE run_DA (idate, deltim, dolai, doalb, dosst, oro)
+
+!-----------------------------------------------------------------------------
+ IMPLICIT NONE
+
+!------------------------ Dummy Arguments ------------------------------------
+ integer, intent(in) :: idate(3)
+ real(r8), intent(in) :: deltim
+ 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
+
+!------------------------ Local Variables ------------------------------------
+ integer :: np, i, maxday
+ integer :: sdate(3) ! backward date from the end to the begin of the time step
+
+!-----------------------------------------------------------------------------
+
+ ! use OI for terrestrial water storage
+ IF (DEF_DA_TWS) THEN
+ IF (DEF_DA_TWS_GRACE) THEN
+ CALL run_DA_GRACE (idate, deltim)
+ ENDIF
+ ENDIF
+
+ ! use ensemble DA for soil moisture
+ IF ((DEF_DA_SM) .and. (DEF_DA_ENS_NUM > 1))THEN
+!#############################################################################
+! Generate ensemble members
+!#############################################################################
+ IF (p_is_compute) THEN
+
+ ! store the non-DA trajectory
+ z_sno_noda = z_sno
+ dz_sno_noda = dz_sno
+ t_soisno_noda = t_soisno
+ wliq_soisno_noda = wliq_soisno
+ wice_soisno_noda = wice_soisno
+ smp_noda = smp
+ hk_noda = hk
+ t_grnd_noda = t_grnd
+ tleaf_noda = tleaf
+ ldew_noda = ldew
+ ldew_rain_noda = ldew_rain
+ ldew_snow_noda = ldew_snow
+ fwet_snow_noda = fwet_snow
+ sag_noda = sag
+ scv_noda = scv
+ snowdp_noda = snowdp
+ fveg_noda = fveg
+ fsno_noda = fsno
+ sigf_noda = sigf
+ green_noda = green
+ tlai_noda = tlai
+ lai_noda = lai
+ tsai_noda = tsai
+ sai_noda = sai
+ alb_noda = alb
+ ssun_noda = ssun
+ ssha_noda = ssha
+ ssoi_noda = ssoi
+ ssno_noda = ssno
+ thermk_noda = thermk
+ extkb_noda = extkb
+ extkd_noda = extkd
+ zwt_noda = zwt
+ wdsrf_noda = wdsrf
+ wa_noda = wa
+ wetwat_noda = wetwat
+ t_lake_noda = t_lake
+ lake_icefrac_noda = lake_icefrac
+ savedtke1_noda = savedtke1
+
+ tref_noda = tref
+ h2osoi_noda = h2osoi
+
+ ! Generate ensemble members
+ CALL ensemble (deltim)
+
+ ! loop over ensemble members
+ DO i = 1, DEF_DA_ENS_NUM
+ ! set ensemble forcing variables
+ forc_t = forc_t_ens(i,:)
+ forc_prc = forc_prc_ens(i,:)
+ forc_prl = forc_prl_ens(i,:)
+ forc_sols = forc_sols_ens(i,:)
+ forc_soll = forc_soll_ens(i,:)
+ forc_solsd = forc_solsd_ens(i,:)
+ forc_solld = forc_solld_ens(i,:)
+ forc_frl = forc_frl_ens(i,:)
+
+ ! give the i-th trajectory state value to state variables
+ z_sno = z_sno_ens ( :,i,:)
+ dz_sno = dz_sno_ens ( :,i,:)
+ t_soisno = t_soisno_ens ( :,i,:)
+ wliq_soisno = wliq_soisno_ens ( :,i,:)
+ wice_soisno = wice_soisno_ens ( :,i,:)
+ smp = smp_ens ( :,i,:)
+ hk = hk_ens ( :,i,:)
+ t_grnd = t_grnd_ens ( i,:)
+ tleaf = tleaf_ens ( i,:)
+ ldew = ldew_ens ( i,:)
+ ldew_rain = ldew_rain_ens ( i,:)
+ ldew_snow = ldew_snow_ens ( i,:)
+ fwet_snow = fwet_snow_ens ( i,:)
+ sag = sag_ens ( i,:)
+ scv = scv_ens ( i,:)
+ snowdp = snowdp_ens ( i,:)
+ fveg = fveg_ens ( i,:)
+ fsno = fsno_ens ( i,:)
+ sigf = sigf_ens ( i,:)
+ green = green_ens ( i,:)
+ tlai = tlai_ens ( i,:)
+ lai = lai_ens ( i,:)
+ tsai = tsai_ens ( i,:)
+ sai = sai_ens ( i,:)
+ alb = alb_ens (:,:,i,:)
+ ssun = ssun_ens (:,:,i,:)
+ ssha = ssha_ens (:,:,i,:)
+ ssoi = ssoi_ens (:,:,i,:)
+ ssno = ssno_ens (:,:,i,:)
+ thermk = thermk_ens ( i,:)
+ extkb = extkb_ens ( i,:)
+ extkd = extkd_ens ( i,:)
+ zwt = zwt_ens ( i,:)
+ wdsrf = wdsrf_ens ( i,:)
+ wa = wa_ens ( i,:)
+ wetwat = wetwat_ens ( i,:)
+ t_lake = t_lake_ens ( :,i,:)
+ lake_icefrac = lake_icefrac_ens( :,i,:)
+ savedtke1 = savedtke1_ens ( i,:)
+
+ ! run colm
+ CALL CoLMDRIVER (idate, deltim, dolai, doalb, dosst, oro)
+
+ ! output ensemble members
+ z_sno_ens ( :,i,:) = z_sno
+ dz_sno_ens ( :,i,:) = dz_sno
+ t_soisno_ens ( :,i,:) = t_soisno
+ wliq_soisno_ens ( :,i,:) = wliq_soisno
+ wice_soisno_ens ( :,i,:) = wice_soisno
+ smp_ens ( :,i,:) = smp
+ hk_ens ( :,i,:) = hk
+ t_grnd_ens ( i,:) = t_grnd
+ tleaf_ens ( i,:) = tleaf
+ ldew_ens ( i,:) = ldew
+ ldew_rain_ens ( i,:) = ldew_rain
+ ldew_snow_ens ( i,:) = ldew_snow
+ fwet_snow_ens ( i,:) = fwet_snow
+ sag_ens ( i,:) = sag
+ scv_ens ( i,:) = scv
+ snowdp_ens ( i,:) = snowdp
+ fveg_ens ( i,:) = fveg
+ fsno_ens ( i,:) = fsno
+ sigf_ens ( i,:) = sigf
+ green_ens ( i,:) = green
+ tlai_ens ( i,:) = tlai
+ lai_ens ( i,:) = lai
+ tsai_ens ( i,:) = tsai
+ sai_ens ( i,:) = sai
+ alb_ens (:,:,i,:) = alb
+ ssun_ens (:,:,i,:) = ssun
+ ssha_ens (:,:,i,:) = ssha
+ ssoi_ens (:,:,i,:) = ssoi
+ ssno_ens (:,:,i,:) = ssno
+ thermk_ens ( i,:) = thermk
+ extkb_ens ( i,:) = extkb
+ extkd_ens ( i,:) = extkd
+ zwt_ens ( i,:) = zwt
+ wdsrf_ens ( i,:) = wdsrf
+ wa_ens ( i,:) = wa
+ wetwat_ens ( i,:) = wetwat
+ t_lake_ens ( :,i,:) = t_lake
+ lake_icefrac_ens( :,i,:) = lake_icefrac
+ savedtke1_ens ( i,:) = savedtke1
+
+ h2osoi_ens(:,i,:) = h2osoi
+ trad_ens (i,:) = trad
+ tref_ens (i,:) = tref
+ qref_ens (i,:) = qref
+ ustar_ens (i,:) = ustar
+ qstar_ens (i,:) = qstar
+ tstar_ens (i,:) = tstar
+ fm_ens (i,:) = fm
+ fh_ens (i,:) = fh
+ fq_ens (i,:) = fq
+
+ fsena_ens (i,:) = fsena
+ lfevpa_ens(i,:) = lfevpa
+ fevpa_ens (i,:) = fevpa
+ rsur_ens (i,:) = rsur
+ ENDDO
+
+ ! recover the no-DA trajectory
+ z_sno = z_sno_noda
+ dz_sno = dz_sno_noda
+ t_soisno = t_soisno_noda
+ wliq_soisno = wliq_soisno_noda
+ wice_soisno = wice_soisno_noda
+ smp = smp_noda
+ hk = hk_noda
+ t_grnd = t_grnd_noda
+ tleaf = tleaf_noda
+ ldew = ldew_noda
+ ldew_rain = ldew_rain_noda
+ ldew_snow = ldew_snow_noda
+ fwet_snow = fwet_snow_noda
+ sag = sag_noda
+ scv = scv_noda
+ snowdp = snowdp_noda
+ fveg = fveg_noda
+ fsno = fsno_noda
+ sigf = sigf_noda
+ green = green_noda
+ tlai = tlai_noda
+ lai = lai_noda
+ tsai = tsai_noda
+ sai = sai_noda
+ alb = alb_noda
+ ssun = ssun_noda
+ ssha = ssha_noda
+ ssoi = ssoi_noda
+ ssno = ssno_noda
+ thermk = thermk_noda
+ extkb = extkb_noda
+ extkd = extkd_noda
+ zwt = zwt_noda
+ wdsrf = wdsrf_noda
+ wa = wa_noda
+ wetwat = wetwat_noda
+ t_lake = t_lake_noda
+ lake_icefrac = lake_icefrac_noda
+ savedtke1 = savedtke1_noda
+
+ tref = tref_noda
+ h2osoi = h2osoi_noda
+
+ ENDIF
+ ENDIF
+
+!#############################################################################
+! Perform data assimilation for different satellite products
+!#############################################################################
+ IF (DEF_DA_SM) THEN
+ ! backward date from the end to the begin of the time step
+ sdate = idate
+ sdate(3) = sdate(3) - nint(deltim)
+ IF (sdate(3) < 0) THEN
+ sdate(2) = sdate(2) - 1
+ sdate(3) = sdate(3) + 86400
+
+ IF (sdate(2) < 1) THEN
+ sdate(1) = sdate(1) - 1
+ IF (isleapyear(sdate(1))) THEN
+ maxday = 366
+ ELSE
+ maxday = 365
+ ENDIF
+ sdate(2) = maxday
+ ENDIF
+ ENDIF
+
+ ! data assimilation
+ IF (DEF_DA_SM) THEN
+ IF (p_is_root) THEN
+ print *, '[CoLM-DA] Start surface soil moisture & temperature data assimilation.'
+ ENDIF
+ CALL mpi_barrier (p_comm_glb, p_err)
+ CALL run_DA_SM (sdate, deltim)
+ ENDIF
+ ENDIF
+
+!#############################################################################
+! Use ensemble mean for important outputs
+!#############################################################################
+ IF ((DEF_DA_SM) .and. (DEF_DA_ENS_NUM > 1))THEN
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO np = 1, numpatch
+ ! important state variables
+ t_soisno_a(:,np) = sum(t_soisno_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM
+ wliq_soisno_a(:,np) = sum(wliq_soisno_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM
+ wice_soisno_a(:,np) = sum(wice_soisno_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM
+ t_grnd_a(np) = sum(t_grnd_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ tleaf_a(np) = sum(tleaf_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ snowdp_a(np) = sum(snowdp_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+
+ ! diagnostic variables
+ h2osoi_a(:,np) = sum(h2osoi_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM
+ t_brt_smap_a(:,np) = sum(t_brt_smap_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM
+ t_brt_fy3d_a(:,np) = sum(t_brt_fy3d_ens(:,:,np), dim=2) / DEF_DA_ENS_NUM
+ trad_a(np) = sum(trad_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ tref_a(np) = sum(tref_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ qref_a(np) = sum(qref_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ ustar_a(np) = sum(ustar_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ qstar_a(np) = sum(qstar_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ tstar_a(np) = sum(tstar_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ fm_a(np) = sum(fm_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ fh_a(np) = sum(fh_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ fq_a(np) = sum(fq_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ fsena_a(np) = sum(fsena_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ fevpa_a(np) = sum(fevpa_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ lfevpa_a(np) = sum(lfevpa_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ rsur_a(np) = sum(rsur_ens(:,np), dim=1) / DEF_DA_ENS_NUM
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE run_DA
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE end_DA ()
+
+!-----------------------------------------------------------------------------
+ IMPLICIT NONE
+
+!-----------------------------------------------------------------------------
+
+ IF (DEF_DA_TWS) THEN
+ IF (DEF_DA_TWS_GRACE) THEN
+ CALL end_DA_GRACE ()
+ ENDIF
+ ENDIF
+
+ IF (DEF_DA_SM) THEN
+ CALL end_DA_SM ()
+ ENDIF
+
+ END SUBROUTINE end_DA
+
+!-----------------------------------------------------------------------------
+END MODULE MOD_DA_Main
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90
new file mode 100644
index 0000000000..ef234e5cba
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_RTM.F90
@@ -0,0 +1,1431 @@
+#include
+
+#ifdef DataAssimilation
+MODULE MOD_DA_RTM
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Forward modeling of brightness temperature observations
+!
+! AUTHOR:
+! Lu Li, 12/2024: Initial version
+! Zhilong Fan, Lu Li, 03/2024: Debug and clean codes
+! Lu Li, 10/2025: Debug and clean codes
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ USE MOD_Vars_1DForcing
+ USE MOD_DA_Const
+ USE MOD_SPMD_Task
+ USE MOD_Vars_Global, only: nl_soil, nl_lake, N_land_classification
+ USE MOD_Namelist
+ IMPLICIT NONE
+ SAVE
+
+! public functions
+ PUBLIC :: forward
+
+! local variables (parameters depends on frequency and incidence angle of satellite)
+ real(r8) :: fghz ! frequency of satellite (GHz)
+ real(r8) :: theta ! incidence angle of satellite (rad)
+ real(r8) :: f ! frequency (Hz)
+ real(r8) :: omega ! radian frequency
+ real(r8) :: lam ! wavelength (m)
+ real(r8) :: k ! wave number (rad/m)
+ real(r8) :: kcm ! wave number (rad/cm)
+ real(r8) :: kr ! size parameter used in calcuate single-particle albedo
+
+!-----------------------------------------------------------------------
+
+CONTAINS
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE forward( &
+ patchtype, patchclass, dz_sno, &
+ forc_topo, htop, &
+ tref, t_soisno, tleaf, &
+ wliq_soisno, wice_soisno, h2osoi, &
+ snowdp, lai, sai, &
+ wf_clay, wf_sand, wf_silt, BD_all, porsl, &
+ sat_theta, sat_fghz, &
+ tb_toa_h, tb_toa_v)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Forward modeling of brightness temperature observations
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ USE MOD_Vars_Global, only: nl_soil, nl_lake, maxsnl, spval, dz_soi
+ USE MOD_DA_Const
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ integer, intent(in) :: patchtype ! land cover type
+ integer, intent(in) :: patchclass ! land cover class
+ real(r8), intent(in) :: dz_sno(maxsnl + 1:0) ! layer thickness (m)
+ real(r8), intent(in) :: forc_topo ! topography [m]
+ real(r8), intent(in) :: htop ! upper height of vegetation [m]
+ real(r8), intent(in) :: tref ! 2 m height air temperature [kelvin]
+ real(r8), intent(in) :: tleaf ! leaf temperature [K]
+ real(r8), intent(in) :: t_soisno(maxsnl + 1:nl_soil) ! soil temperature [K]
+ real(r8), intent(in) :: wliq_soisno(maxsnl + 1:nl_soil) ! liquid water in layers [kg/m2]
+ real(r8), intent(in) :: wice_soisno(maxsnl + 1:nl_soil) ! ice lens in layers [kg/m2]
+ real(r8), intent(in) :: h2osoi(nl_soil) ! volumetric soil water in layers [m3/m3]
+ real(r8), intent(in) :: snowdp ! snow depth [meter]
+ real(r8), intent(in) :: lai ! leaf area index
+ real(r8), intent(in) :: sai ! stem area index
+ real(r8), intent(in) :: wf_clay(nl_soil) ! gravimetric fraction of clay
+ real(r8), intent(in) :: wf_sand(nl_soil) ! gravimetric fraction of sand
+ real(r8), intent(in) :: wf_silt(nl_soil) ! gravimetric fraction of silt
+ real(r8), intent(in) :: BD_all(nl_soil) ! bulk density of soil (GRAVELS + ORGANIC MATTER + Mineral Soils,kg/m3)
+ real(r8), intent(in) :: porsl(nl_soil) ! fraction of soil that is voids [-]
+ real(r8), intent(in) :: sat_theta ! incidence angle of satellite (rad)
+ real(r8), intent(in) :: sat_fghz ! frequency of satellite (GHz)
+ real(r8), intent(out) :: tb_toa_h ! brightness temperature of top-of-atmosphere for H- polarization
+ real(r8), intent(out) :: tb_toa_v ! brightness temperature of top-of-atmosphere for V- polarization
+
+!----------------------- Local Variables -------------------------------
+ logical :: is_low_veg ! flag for low vegetation
+ real(r8) :: dz_soisno(maxsnl+1:nl_soil) ! liquid water in layers [kg/m2]
+ integer :: lb ! lower bound of arrays
+ real(r8) :: tau_atm ! atmospheric optical depth
+ real(r8) :: r_r(2) ! rough surface reflectivity for H and V polarizations
+ real(r8) :: r_sn(2) ! reflectivity between the snow and ground for H and V polarizations
+ real(r8) :: r_snow(2) ! reflectivity of the snow for H and V polarizations
+ real(r8) :: tb_soil(2) ! brightness temperature of soil for H and V polarizations
+ real(r8) :: tb_tos(2) ! brightness temperature of snow-covered ground for H and V polarizations
+ real(r8) :: tb_tov(2) ! brightness temperature of vegetation (consider snow) for H and V polarizations
+ real(r8) :: tb_tov_noad(2) ! brightness temperature of vegetation (no downwelling radiation) for H and V polarizations
+ real(r8) :: tb_au(2) ! upwelling radiation (brightness temperature) of atmosphere
+ real(r8) :: tb_ad(2) ! downwelling radiation (brightness temperature) of atmosphere
+ real(r8) :: rho_snow ! snow density (g/cm3)
+ real(r8) :: liq_snow ! snow liquid water content (cm3/cm3)
+ real(r8) :: gamma_p(2) ! vegetation opacity for H- and V- polarization
+ real(r8) :: tb_veg(2) ! brightness temperature of vegetation for H- and V- polarization
+ real(r8) :: tb_2(2) ! the downwelling vegetation emission reflected by the soil and attenuated by the canopy layer
+ real(r8) :: tb_3(2) ! upwelling soil emission attenuated by the canopy
+ real(r8) :: tb_4(2) ! the downwelling cosmic ray reflected by the soil and attenuated by the canopy layer
+ real(r8) :: tb_toa(2) ! brightness temperature of top-of-atmosphere for H- and V- polarization
+ real(r8) :: wf_total(nl_soil) ! total gravimetric
+ real(r8) :: BD_all_surf ! bulk density of soil (g/m3) at surface
+ real(r8) :: porsl_surf ! soil porosity at surface
+ real(r8) :: t_surf ! soil temperature at surface (C)
+ real(r8) :: t_deep ! soil temperature at deep layer (C)
+ real(r8) :: liq_surf ! liquid volumetric water content at surface (m3/m3)
+ real(r8) :: ice_surf ! ice volumetric water content at surface (m3/m3)
+ real(r8) :: wf_clay_surf ! gravimetric clay percent fraction(%) at surface
+ real(r8) :: wf_sand_surf ! gravimetric sand percent fraction(%) at surface
+ integer :: i
+
+!-----------------------------------------------------------------------
+
+!#############################################################################
+! Prepare parameters & states used in the operator
+!#############################################################################
+ ! get depth of soil and snow layers
+ dz_soisno(maxsnl+1:0) = dz_sno(maxsnl+1:0)
+ dz_soisno(1:nl_soil) = dz_soi(1:nl_soil)
+
+ ! calculate weighted parameters
+ wf_total = wf_clay + wf_sand + wf_silt
+ wf_clay_surf = (wf_clay(1)/wf_total(1)*0.0175 + wf_clay(2)/wf_total(2)*0.0276)/0.0451*100
+ wf_sand_surf = (wf_sand(1)/wf_total(1)*0.0175 + wf_sand(2)/wf_total(2)*0.0276)/0.0451*100
+ BD_all_surf = (BD_all(1)*0.0175 + BD_all(2)*0.0276)/0.0451/1000
+ porsl_surf = (porsl(1)*0.0175 + porsl(2)*0.0276)/0.0451
+
+ ! caculate temperature (C) at surface and deep soil layers
+ t_surf = ((t_soisno(1)*(0.0175) + t_soisno(2)*(0.0451 - 0.0175))/0.0451) - tfrz
+ t_deep = ((t_soisno(7)*(0.8289-0.5) + t_soisno(8)*(1.0 - 0.8289))/0.5) - tfrz
+
+ ! caculate liquid/ice volumetric water (first two layers)
+ liq_surf = (wliq_soisno(1) + wliq_soisno(2))/(0.0451*denh2o)
+ ice_surf = (wice_soisno(1) + wice_soisno(2))/(0.0451*denice)
+
+ ! calculate lower bound of snow
+ lb = 0
+ DO i = 0, maxsnl
+ IF (wliq_soisno(i) < 0.0) THEN
+ lb = i+1
+ EXIT
+ ENDIF
+ ENDDO
+
+!#############################################################################
+! Run the forward operator
+!#############################################################################
+ ! check the patch type
+ IF (patchtype >= 3) THEN ! ocean, lake, ice
+ tb_toa = spval
+ ELSE
+ ! calculate parameters used in operator varied with satellite
+ CALL calc_parameters(sat_theta, sat_fghz)
+
+!#############################################################################
+! atmosphere module
+!#############################################################################
+ CALL atm(forc_topo, tref, tau_atm, tb_au, tb_ad)
+
+!#############################################################################
+! soil module
+!#############################################################################
+ CALL soil(&
+ patchclass, &
+ t_surf, t_deep, &
+ liq_surf, ice_surf, &
+ wf_sand_surf, wf_clay_surf, BD_all_surf, porsl_surf, &
+ r_r, tb_soil)
+
+!#############################################################################
+! vegetation and snow module
+! We categorized four different cases for the calculations:
+! 1) no vegetation and no snow
+! 2) no vegetation with snow
+! 3) vegetation without snow
+! 4) vegetation with snow
+!#############################################################################
+ ! roughly judge low or high vegetation (only for IGBP)
+ is_low_veg = .true.
+ IF (patchclass >= 1 .and. patchclass <= 5) THEN
+ is_low_veg = .false.
+ END IF
+
+ ! ensure snow density to <= 1 g/cm3
+ IF (snowdp > 0.01) THEN
+ rho_snow = (wliq_soisno(lb) + wice_soisno(lb))/(dz_soisno(lb)*1e3)
+ liq_snow = wliq_soisno(lb)*rho_snow/(dz_soisno(lb)*1e3)
+
+ IF (liq_snow > 1.0 .or. rho_snow > 1.0) then
+ rho_snow = 1.0
+ liq_snow = wliq_soisno(lb)*rho_snow/(dz_soisno(lb)*1e3)
+ END IF
+ END IF
+
+ ! main procedures
+ ! --------------------------------------------------------------------
+ ! 1) no veg and no snow
+ ! two components:
+ ! (1) brightness temperature of soil
+ ! (2) the downwelling radiation reflected by the soil
+ ! --------------------------------------------------------------------
+ IF ((lai + sai < 1e-6) .and. (snowdp < 0.01)) THEN
+ tb_tov = tb_soil + tb_ad*r_r
+ tb_tov_noad = tb_soil
+
+ ! --------------------------------------------------------------------
+ ! 2) no veg and has snow
+ ! two components:
+ ! (1) brightness temperature of snow
+ ! (2) the downwelling radiation reflected by the snow
+ ! --------------------------------------------------------------------
+ ELSE IF ((lai + sai < 1e-6) .and. (snowdp > 0.01)) THEN
+ ! calculate brightness temperature of snow-covered ground
+ CALL snow(t_soisno(1), t_soisno(1), snowdp, rho_snow, liq_snow, r_r, r_snow, tb_tos)
+
+ tb_tov = tb_tos + tb_ad*r_snow
+ tb_tov_noad = tb_tos
+
+ ! --------------------------------------------------------------------
+ ! 3) has veg and no snow
+ ! four components:
+ ! (1) the direct upwelling vegetation emission,
+ ! (2) the downwelling vegetation emission reflected by the soil and attenuated by the canopy layer
+ ! (3) upwelling soil emission attenuated by the canopy
+ ! (4) the downwelling reflected by the soil and attenuated by the canopy layer
+ ! --------------------------------------------------------------------
+ ELSE IF ((lai + sai > 1e-6) .and. (snowdp < 0.01)) THEN
+ ! calculate brightness temperature of vegetation
+ CALL veg(patchclass, lai, htop, 0.0, tleaf, tb_veg, gamma_p)
+
+ DO i = 1, 2
+ tb_2(i) = tb_veg(i)*gamma_p(i)*r_r(i)
+ tb_3(i) = tb_soil(i)*gamma_p(i)
+ tb_4(i) = tb_ad(i)*r_r(i)*(gamma_p(i)**2)
+ tb_tov(i) = tb_veg(i) + tb_2(i) + tb_3(i) + tb_4(i)
+ tb_tov_noad(i) = tb_veg(i) + tb_2(i) + tb_3(i)
+ END DO
+
+ ! --------------------------------------------------------------------
+ ! 4) has veg and has snow
+ ! We need to determine the positional relationship between vegetation and snow.
+ !
+ ! If vegetation is higher than snow,
+ ! we first calculate brightness temperature of snow (soil boundary), then calculate
+ ! four components to derive brightness temperature of top of vegetation:
+ ! (1) the direct upwelling vegetation emission,
+ ! (2) the downwelling vegetation emission reflected by the snow and attenuated by the canopy layer
+ ! (3) upwelling snow emission attenuated by the canopy
+ ! (4) the downwelling reflected by the snow and attenuated by the canopy layer
+ !
+ ! If vegetation is lower than snow
+ ! we first calculate brightness temperature of top of vegetation (soil boundary), then calculate
+ ! four components to derive brightness temperature of top of snow:
+ ! (1) the direct upwelling vegetation emission,
+ ! (2) the downwelling vegetation emission reflected by the soil and attenuated by the canopy layer
+ ! (3) upwelling soil emission attenuated by the canopy
+ ! (4) the downwelling reflected by the soil and attenuated by the canopy layer
+ ! --------------------------------------------------------------------
+ ELSE IF ((lai + sai > 1e-6) .and. (snowdp > 0.01)) THEN
+ IF (htop < snowdp) THEN
+ ! calculate brightness temperature of low vegetation
+ CALL veg(patchclass, lai, htop, snowdp, tleaf, tb_veg, gamma_p)
+
+ ! calculate brightness temperature of top of vegetation
+ DO i = 1, 2
+ tb_2(i) = tb_veg(i)*gamma_p(i)*r_r(i)
+ tb_3(i) = tb_soil(i)*gamma_p(i)
+ tb_4(i) = tb_ad(i)*r_r(i)*(gamma_p(i)**2)
+ tb_tov(i) = tb_veg(i) + tb_2(i) + tb_3(i) + tb_4(i)
+ tb_tov_noad(i) = tb_veg(i) + tb_2(i) + tb_3(i)
+ END DO
+
+ ! calculate reflectivity between the snow and low veg (adopted from CMEM)
+ r_sn(:) = 1.0 - tb_tov_noad(:)/t_soisno(1)
+
+ ! calculate brightness temperature of snow-covered ground
+ CALL snow(t_soisno(1), t_soisno(1), snowdp, rho_snow, liq_snow, r_sn, r_snow, tb_tos)
+
+ ! calculate brightness temperature of top of snow
+ tb_tov = tb_tos + tb_ad*r_snow
+ tb_tov_noad = tb_tos
+
+ ELSE
+ ! calculate brightness temperature of snow-covered ground
+ CALL snow(t_soisno(1), t_soisno(1), snowdp, rho_snow, liq_snow, r_r, r_snow, tb_tos)
+
+ ! calculate brightness temperature of high vegetation
+ CALL veg(patchclass, lai, htop, snowdp, tleaf, tb_veg, gamma_p)
+
+ ! calculate brightness temperature of top of vegetation
+ DO i = 1, 2
+ tb_2(i) = tb_veg(i)*gamma_p(i)*r_snow(i)
+ tb_3(i) = tb_tos(i)*gamma_p(i)
+ tb_4(i) = tb_ad(i)*r_snow(i)*(gamma_p(i)**2)
+ tb_tov(i) = tb_veg(i) + tb_2(i) + tb_3(i) + tb_4(i)
+ tb_tov_noad(i) = tb_veg(i) + tb_2(i) + tb_3(i)
+ END DO
+ END IF
+ END IF
+
+!#############################################################################
+! Caculate brightness temperature of top-of-atmosphere
+!#############################################################################
+ tb_toa = tb_tov*exp(-tau_atm) + tb_au
+
+ END IF
+
+ tb_toa_h = tb_toa(1)
+ tb_toa_v = tb_toa(2)
+
+ END SUBROUTINE forward
+
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE calc_parameters (sat_theta, sat_fghz)
+
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_DA_Const
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument -------------------------------
+ real(r8), intent(in) :: sat_theta, sat_fghz
+
+!----------------------- Local Variables -------------------------------
+
+ theta = sat_theta ! incidence angle of satellite (rad)
+ fghz = sat_fghz ! frequency of satellite (GHz)
+ f = fghz*1e9 ! frequency (Hz)
+ omega = 2.0*pi*f ! radian frequency (rad/s)
+ lam = C/f ! wavelength (m)
+ k = 2*pi/lam ! wave number (rad/m)
+ kcm = k/100.0 ! wave number (rad/cm)
+ kr = k*(0.5*1e-3) ! size parameter used in calcuate single-particle albedo
+
+ END SUBROUTINE calc_parameters
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE atm(z, tref, tau_atm, tb_au, tb_ad)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the atmospheric opacity and up and downwelling brightness temperature
+!
+! REFERENCES:
+! [1] Pellarin, T., et al. (2003), Two-year global simulation of L-band brightness
+! temperature over land, IEEE Trans. Geosci. Remote Sens., 41, 2135–2139.
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ real(r8), intent(in) :: z ! altitude (m)
+ real(r8), intent(in) :: tref ! 2m air temperature (K)
+ real(r8), intent(out) :: tau_atm ! atmospheric optical depth
+ real(r8), intent(out) :: tb_au(2) ! upwelling radiation (brightness temperature) of atmosphere
+ real(r8), intent(out) :: tb_ad(2) ! downwelling radiation (brightness temperature) of atmosphere
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: t_sky = 2.7 ! cosmic ray radiation (K)
+ real(r8) :: t_eq ! equivalent layer temperature
+ real(r8) :: gossat
+
+!-----------------------------------------------------------------------
+
+ ! calculate optical depth of atmosphere [1] eq(A1)
+ tau_atm = exp(-3.9262 - 0.2211*z/1000 - 0.00369*tref)/cos(theta)
+ gossat = exp(-tau_atm)
+
+ ! calculate equivalent layer temperature
+ t_eq = exp(4.9274 + 0.002195*tref)
+
+ ! upwelling radiation (brightness temperature) of atmosphere
+ tb_au(:) = t_eq*(1.-gossat)
+
+ ! downwelling radiation (brightness temperature) of atmosphere [1] eq(A2)
+ tb_ad(:) = t_eq*(1.-gossat) + t_sky*gossat
+
+ END SUBROUTINE atm
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE soil( &
+ patchclass, &
+ t_surf, t_deep, &
+ liq_surf, ice_surf, &
+ wf_sand_surf, wf_clay_surf, BD_all_surf, porsl_surf, &
+ r_r, tb_soil)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate brightness temperature of soil surface
+!
+! REFERENCES:
+! [1] Wigneron et al., 2007, "L-band Microwave Emission of the Biosphere (L-MEB) Model:
+! Description and calibration against experimental
+! data sets over crop fields" Remote Sensing of Environment. Vol. 107, pp. 639-655k
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ integer, intent(in) :: patchclass ! land cover class
+ real(r8), intent(in) :: t_surf ! soil temperature at surface (C)
+ real(r8), intent(in) :: t_deep ! soil temperature at deep layer (C)
+ real(r8), intent(in) :: liq_surf ! liquid volumetric water content at surface (m3/m3)
+ real(r8), intent(in) :: ice_surf ! ice volumetric water content at surface (m3/m3)
+ real(r8), intent(in) :: wf_sand_surf ! gravimetric sand percent fraction(%) at surface
+ real(r8), intent(in) :: wf_clay_surf ! gravimetric clay percent fraction(%) at surface
+ real(r8), intent(in) :: BD_all_surf ! bulk density of soil (g/m3) at surface
+ real(r8), intent(in) :: porsl_surf ! soil porosity at surface
+ real(r8), intent(out) :: r_r(2) ! rough surface reflectivity for H and V polarizations
+ real(r8), intent(out) :: tb_soil(2) ! brightness temperature of soil
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: t_eff(2) ! effective temperature for H and V polarizations, [K]
+ complex(r8) :: eps_soil ! dielectric constant of soil for H and V polarizations
+ real(r8) :: r_s(2) ! smooth surface reflectivity for H and V polarizations
+ complex(r8) :: ew ! dielectric constant of water
+ logical :: is_desert ! flag for desert soil
+ real(r8) :: ffrz ! fraction of frozen soil
+ complex(r8) :: eps_f = (5.0, 0.5) ! dielectric constant of frozen soil
+ real(r8) :: sal_soil = 0.0 ! soil salinity (psu)
+
+!-----------------------------------------------------------------------
+
+ ! whether this patch is desert
+ is_desert = .false.
+ IF (liq_surf < 0.02 .and. wf_sand_surf > 90) THEN
+ is_desert = .true.
+ END IF
+
+ ! calculate ratio of freezed soil
+ IF (liq_surf + ice_surf <= 0.0d0) THEN
+ ffrz = 0.0d0
+ ELSE
+ ffrz = ice_surf / (liq_surf + ice_surf)
+ ENDIF
+
+ ! caculate effective temperature
+ CALL eff_soil_temp(liq_surf, t_surf, t_deep, t_eff)
+
+ ! caculate dielectric constant of soil (mixture medium)
+ IF (is_desert) THEN
+ ! Microwave 1-10GHz permittivity of dry sand (matzler '98, eq.1)
+ eps_soil = 2.53 + (2.79 - 2.53)/(1 - jj*(fghz/0.27)) + jj*0.002
+ ELSE
+ ! define bulk density and porosity (CMEM)
+ ! BD_all_surf = (wf_sand_surf*1.60d0 + wf_clay_surf*1.10d0 + (100.0d0 - wf_sand_surf - wf_clay_surf)*1.20d0)/100.0d0
+ ! porsl_surf = 1.0d0 - BD_all_surf/2.660d0
+
+ ! caculate ice or water dielectric constant
+ IF (ffrz > 0.95) THEN
+ CALL diel_ice(t_surf, ew)
+ ELSE
+ CALL diel_water(-1, liq_surf, t_surf, wf_sand_surf, wf_clay_surf, BD_all_surf, sal_soil, ew)
+ END IF
+
+ ! caculate dielectric constant in mixed soil
+ IF (DEF_DA_RTM_diel == 0) THEN
+ CALL diel_soil_W80 (ew, t_surf, liq_surf, wf_sand_surf, wf_clay_surf, porsl_surf, eps_soil)
+ ELSE IF (DEF_DA_RTM_diel == 1) THEN
+ CALL diel_soil_D85 (ew, liq_surf, wf_sand_surf, wf_clay_surf, BD_all_surf, eps_soil)
+ ELSE IF (DEF_DA_RTM_diel == 2) THEN
+ CALL diel_soil_M04 (liq_surf, wf_clay_surf, eps_soil)
+ ELSE IF (DEF_DA_RTM_diel == 3) THEN
+ CALL diel_soil_M09 (liq_surf, t_surf, wf_clay_surf, eps_soil)
+ ENDIF
+ END IF
+
+ ! mix dielectric constant of frozen and non-frozen soil
+ eps_soil = eps_soil*(1.-ffrz) + eps_f*ffrz
+
+ ! caculate smooth surface reflectivity
+ CALL smooth_reflectivity(eps_soil, r_s)
+
+ ! caculate rough surface reflectivity
+ CALL rough_reflectivity(is_desert, patchclass, r_s, r_r)
+
+ ! calculate brightness temperature
+ IF (is_desert) THEN
+ CALL desert(t_eff, r_r, eps_soil, tb_soil)
+ ELSE
+ tb_soil = t_eff * (1 - r_r)
+ END IF
+
+ END SUBROUTINE soil
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE eff_soil_temp(wc_surf, t_surf, t_deep, t_eff)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the effective temperature of soil
+!
+! REFERENCES:
+! [1] An improved two-layer algorithm for estimating effective soil
+! temperature in microwave radiometry using in situ temperature
+! and soil moisture measurements
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ IMPLICIT NONE
+
+! ------------------------ Dummy Argument ------------------------------
+ real(r8), intent(in) :: wc_surf ! soil moisture at surface (m3/m3)
+ real(r8), intent(in) :: t_surf ! soil temperature (C) at surface
+ real(r8), intent(in) :: t_deep ! soil temperature (C) at deep layer
+ real(r8), intent(out) :: t_eff(2) ! effective temperature for H and V polarizations, [K]
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: C ! parameter depending mainly on frequency
+ ! and soil moisture to describe the impact of
+ ! surface temperature on the effective temperature;
+ ! soil moisture increase, C large, teff close to tsurf
+ ! soil moisture decrease, C small, tdeep impact teff more
+ real(r8) :: w0 = 0.30 ! parameter
+ real(r8) :: bw = 0.30 ! parameter
+!-----------------------------------------------------------------------
+
+ IF (wc_surf < 0.0) THEN
+ C = 0.001
+ ELSE
+ C = max(0.001, (wc_surf/w0)**bw)
+ ENDIF
+ t_eff(:) = t_deep + (t_surf - t_deep)*C + tfrz
+
+ END SUBROUTINE eff_soil_temp
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE diel_ice(t, eps_i)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate dielectric constant of pure ice
+!
+! REFERENCES:
+! [1] Matzler, C. (2006). Thermal Microwave Radiation: Applications
+! for Remote Sensing p456-461
+!-----------------------------------------------------------------------
+ USE MOD_Const_Physical
+ USE MOD_Precision
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ real(r8), intent(in) :: t ! temperature (C)
+ complex(r8), intent(out) :: eps_i ! dielectric constant of ice water
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: betam ! beta parameter by Mishima et al. (1983)
+ real(r8) :: dbeta ! corrected delta beta parameter
+ real(r8) :: beta ! beta parameter
+ real(r8) :: t_inv ! modified inverse temperature
+ real(r8) :: tk ! temperature (K)
+ real(r8) :: alpha ! alpha parameter
+ real(r8) :: eps_i_r ! real part of pure ice dielectric constant
+ real(r8) :: eps_i_i ! imaginary part of pure ice dielectric constant
+
+!-----------------------------------------------------------------------
+
+ ! C to K
+ tk = t + tfrz
+
+ ! eq.(5.33): calculate beta parameter by Mishima et al. (1983)
+ betam = (0.0207/tk)*(exp(335./tk)/((exp(335./tk) - 1.)**2.)) + 1.16e-11*(fghz**2.) ! [1](5.33)
+
+ ! eq.(5.35): calculate delta beta parameter
+ dbeta = exp(-10.02 + 0.0364*t) ! [1](5.35)
+
+ ! eq.(5.34): calculate beta parameter
+ beta = betam + dbeta ! [1](5.34)
+
+ ! eq.(5.32): calculate alpha parameter
+ t_inv = 300./tk - 1 ! [1](p.457)
+ alpha = (0.00504 + 0.0062*t_inv)*exp(-22.1*t_inv) !(GHz) ! [1](5.32)
+
+ ! eq.(5.30): calculate real part of pure ice dielectric constant
+ eps_i_r = 3.1884 + 9.1e-4*t ! [1](5.30)
+
+ ! eq.(5.31): calculate imaginary part of pure ice dielectric constant
+ eps_i_i = alpha/fghz + beta*fghz ! [1](5.31)
+
+ ! calculate dielectric constant of pure ice
+ eps_i = eps_i_r - jj*eps_i_i ! [1](5.31)
+
+ END SUBROUTINE diel_ice
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE diel_water(type, swc, t, wf_sand, wf_clay, BD_all, sal, eps_w)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate dielectric constant of water in water (saline water)
+!
+! REFERENCES:
+! [1] Ulaby FT, R. K. Moore, and A. K. Fung, Microwave Remote Sensing:
+! Active and Passive. Vol. III. From theory to applications. Artech House,
+! Norwood, MA., 1986
+! [2] Klein, L. A. and C. T. Swift (1977): An improved model
+! for the dielectric constant of sea water at microwave
+! frequencies, IEEE Transactions on Antennas and Propagation,
+! Vol. AP-25, No. 1, 104-111.
+!-----------------------------------------------------------------------
+ USE MOD_Const_Physical
+ USE MOD_Precision
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ integer, intent(in) :: type ! type of water, 0: pure water, 1: sea water, 2: soil water
+ real(r8), intent(in) :: swc ! soil water content (m3/m3)
+ real(r8), intent(in) :: t ! soil temperature (C)
+ real(r8), intent(in) :: wf_sand ! gravimetric sand percent fraction(%)
+ real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%)
+ real(r8), intent(in) :: BD_all ! bulk density(g/cm3)
+ real(r8), intent(in) :: sal ! water salinity (psu)
+ complex(r8), intent(out) :: eps_w ! dielectric constant of soil water
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: sigma ! ionic conductivity (S/m)
+ real(r8) :: a, b ! parameters
+ real(r8) :: tau_w ! relaxation time of pure water
+ real(r8) :: eps_w0 ! static dielectric constant of pure water
+ real(r8) :: wc
+
+!-----------------------------------------------------------------------
+
+ ! [3] eq.16: tau(T, sal) = tau_w(T) * b(sal, T)
+ ! calculate relaxation time of pure water (Stogryn)
+ tau_w = 1.768e-11 - 6.068e-13*t + 1.104e-14*t**2 - 8.111e-17*t**3 ! [2](17)
+ b = 1.000 + 2.282e-5*sal*t - 7.638e-4*sal - 7.760e-6*sal**2 + 1.105e-8*sal**3 ! [2](18)
+ tau_w = tau_w*b ! [2](16)
+
+ ! [3] eq.13: eps_w0(sal, T) = eps_w0(T) * a(sal, T)
+ ! static dielectric constant of pure water (Klein and Swift)
+ eps_w0 = 87.134 - 1.949e-1*t - 1.276e-2*t**2 + 2.491e-4*t**3 ! [2](14)
+ a = 1.000 + 1.613e-5*sal*t - 3.656e-3*sal + 3.210e-5*sal**2 - 4.232e-7*sal**3 ! [2](15)
+ eps_w0 = eps_w0*a ! [2](13)
+
+ IF (type == 0) THEN ! pure water
+ ! [1] eq.19
+ eps_w0 = 88.045 - 0.4147*t + 6.295e-4*t**2 + 1.075e-5*t**3
+ eps_w = eps_w_inf + (eps_w0 - eps_w_inf)/(1 - jj*omega*tau_w)
+
+ ELSEIF (type == 1) THEN ! sea water
+ ! calculate ionic conductivity [1] eq.27, eq.28
+ sigma = sal*(0.182521 - 1.46192e-3*sal + 2.09324e-5*sal**2 - 1.28205e-7*sal**3) &
+ *exp(-1.*(25 - t)* &
+ (2.033e-2 + 1.266e-4*(25 - t) + 2.464e-6*(25 - t)**2 &
+ - sal*(1.849e-5 - 2.551e-7*(25 - t) + 2.551e-8*(25 - t)**2)))
+
+ ! diel constant of sea water [1] eq.21
+ eps_w = eps_w_inf + (eps_w0 - eps_w_inf)/(1 - jj*omega*tau_w) + jj*sigma/(omega*eps_0)
+ ELSE
+ ! calculate soil conductivity
+ sigma = -1.645 + 1.939*BD_all - 0.02256*wf_sand + 0.01594*wf_clay
+ IF (sigma < 0.) THEN
+ sigma = 0. ! negative for very sandy soils with low bulk density
+ END IF
+
+ ! calculate dielectric constant of soil-water by modified Debye expression
+ wc = max(0.001, swc)
+ eps_w = eps_w_inf + (eps_w0 - eps_w_inf)/(1 - jj*omega*tau_w) &
+ + jj*sigma/(omega*eps_0)*(rho_soil - BD_all)/(rho_soil*wc)
+ END IF
+
+ END SUBROUTINE diel_water
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE diel_soil_W80(ew, t, wc, wf_sand, wf_clay, porsl, eps)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the dielectric constant of a wet soil
+!
+! REFERENCES:
+! [1] Matzler, C. (1998). Microwave permittivity of dry sand.
+! IEEE Transactions on Geoscience and Remote Sensing, 36(1), 317-319.
+!
+! [2] Wang and Schmugge, 1980: An empirical model for the
+! complex dielectric permittivity of soils as a function of water
+! content. IEEE Trans. Geosci. Rem. Sens., GE-18, No. 4, 288-295.
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ IMPLICIT NONE
+
+! ------------------------ Dummy Argument ------------------------------
+ real(r8), intent(in) :: t ! soil temperature (C)
+ real(r8), intent(in) :: wc ! volumetric soil moisture (m3/m3)
+ real(r8), intent(in) :: wf_sand ! gravimetric sand percent fraction(%)
+ real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%)
+ real(r8), intent(in) :: porsl ! soil porosity at surface
+ complex(r8), intent(in) :: ew ! dielectric constant of water
+ complex(r8), intent(out) :: eps
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: wp ! wilting point
+ real(r8) :: wt ! transition moisture point (cm3/cm3)
+ real(r8) :: gamma ! fitting parameter
+ real(r8) :: ecl ! conductivity loss
+ real(r8) :: alpha ! conductivity loss parameter
+ real(r8) :: sal_sea = 32.5 ! sea water salinity (psu)
+ real(r8) :: sal_soil = 0.0 ! soil salinity (psu)
+ complex(r8) :: eps_x ! dielectric constant of the initially absorbed water
+ complex(r8) :: eps_a = (1.0, 0.0) ! dielectric constant of air, [2]IV
+ complex(r8) :: eps_r = (5.5, 0.2) ! dielectric constant of rock, [2]IV
+ complex(r8) :: eps_i = (3.2, 0.1) ! dielectric constant of ice, [2]IV
+ complex(r8) :: eps_f = (5.0, 0.5) ! dielectric constant of frozen soil
+
+!-----------------------------------------------------------------------
+
+ ! calculate wilting point at the soil layer
+ wp = 0.06774 - 0.00064*wf_sand + 0.00478*wf_clay ! [2](1)
+
+ ! calculate fitting parameters
+ gamma = -0.57*wp + 0.481 ! [2](8)
+
+ ! calculate transition moisture point
+ wt = 0.49*wp + 0.165 ! [2](9)
+
+ ! calculate dielectric constant of wet soil (when all soil freeze, eps_x = eps_i)
+ IF (wc <= wt) THEN
+ eps_x = eps_i + (ew - eps_i)*(wc/wt)*gamma ! [2](3)
+ eps = wc*eps_x + (porsl - wc)*eps_a + (1.-porsl)*eps_r ! [2](2)
+ ELSE
+ eps_x = eps_i + (ew - eps_i)*gamma ! [2](5)
+ eps = wt*eps_x + (wc - wt)*ew + (porsl - wc)*eps_a + (1.-porsl)*eps_r ! [2](4)
+ END IF
+
+ ! add conductivity loss for imaginary part
+ alpha = min(100.*wp, 26.)
+ ecl = alpha*wc**2 ! [2](6)
+ eps = eps + jj*ecl ! [2](6)
+
+ END SUBROUTINE diel_soil_W80
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE diel_soil_M04(wc, wf_clay, eps)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the dielectric constant of a wet soil Developed and
+! validated from 1 to 10 GHz, adapted for a large range of soil moisture
+!
+! REFERENCES:
+! [1] Mironov et al, Generalized Refractive Mixing Dielectric Model for
+! moist soil. IEEE Trans. Geosc. Rem. Sens., vol 42 (4), 773-785. 2004.
+!
+! [2] Mironov et al, Physically and Mineralogically Based Spectroscopic
+! Dielectric Model for Moist Soils. IEEE Trans. Geosc. Rem. Sens.,
+! vol 47 (7), 2059-2070. 2009.
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ IMPLICIT NONE
+
+! ------------------------ Dummy Argument ------------------------------
+ real(r8), intent(in) :: wc ! soil moisture (m3/m3)
+ real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%)
+ complex(r8), intent(out) :: eps
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: znd, zkd, zxmvt, zep0b, ztaub, zsigmab, zep0u, ztauu
+ real(r8) :: zsigmau, zcxb, zepwbx, zepwby, zcxu, zepwux, zepwuy
+ real(r8) :: znb, zkb, znu, zku, zxmvt2, znm, zkm, zepmx, zepmy
+ integer :: zflag
+
+!-----------------------------------------------------------------------
+!------------------------------------------------------------------------
+! Initializing the GRMDM spectroscopic parameters with clay (fraction)
+!------------------------------------------------------------------------
+ ! RI & NAC of dry soils
+ znd = 1.634 - 0.539 * (wf_clay/100) + 0.2748 * (wf_clay/100) ** 2
+ zkd = 0.03952 - 0.04038 * (wf_clay / 100) ! [2](18)
+
+ ! Maximum bound water fraction
+ zxmvt = 0.02863 + 0.30673 * wf_clay / 100 ! [2](19)
+
+ ! Bound water parameters
+ zep0b = 79.8 - 85.4 * (wf_clay / 100) + 32.7 * (wf_clay / 100)*(wf_clay / 100) ! [2](20)
+ ztaub = 1.062e-11 + 3.450e-12 * (wf_clay / 100) ! [2](21)
+ zsigmab = 0.3112 + 0.467 * (wf_clay / 100) ! [2](22)
+
+ ! Unbound (free) water parameters
+ zep0u = 100 ! [2](24)
+ ztauu = 8.5e-12 ! [2](25)
+ zsigmau = 0.3631 + 1.217 * (wf_clay / 100)
+
+ ! Computation of epsilon water (bound & unbound)
+ zcxb = (zep0b - eps_w_inf) / (1. + (2.*pi*f*ztaub)**2) ! [2](16)
+ zepwbx = eps_w_inf + zcxb ! [2](16)
+ zepwby = zcxb * (2.*pi*f*ztaub) + zsigmab / (2.*pi*eps_0*f) ! [2](16)
+ zcxu = (zep0u - eps_w_inf) / (1 + (2*pi*f*ztauu)**2) ! [2](16)
+ zepwux = eps_w_inf + zcxu ! [2](16)
+ zepwuy = zcxu * (2.*pi*f*ztauu) + zsigmau/(2.*pi*eps_0*f)
+
+ ! Computation of refractive index of water (bound & unbound)
+ znb = sqrt( sqrt( zepwbx**2 + zepwby**2) + zepwbx ) / sqrt(2.0) ! [2](14)
+ zkb = sqrt( sqrt( zepwbx**2 + zepwby**2) - zepwbx ) / sqrt(2.0) ! [2](15)
+ znu = sqrt( sqrt( zepwux**2 + zepwuy**2) + zepwux ) / sqrt(2.0) ! [2](14)
+ zku = sqrt( sqrt( zepwux**2 + zepwuy**2) - zepwux ) / sqrt(2.0) ! [2](15)
+
+ ! Computation of soil refractive index (nm & km): xmv can be a vector
+ zxmvt2 = min (wc, zxmvt)
+ zflag = 0
+ IF ( wc >= zxmvt ) zflag = 1
+ znm = znd + (znb - 1) * zxmvt2 + (znu - 1) * (wc-zxmvt) * zflag ! [2](12)
+ zkm = zkd + zkb * zxmvt2 + zku * (wc-zxmvt) * zflag ! [2](13)
+
+ ! computation of soil dielectric constant:
+ zepmx = znm ** 2 - zkm ** 2 ! [2](11)
+ zepmy = znm * zkm * 2 ! [2](11)
+ eps = cmplx(zepmx, zepmy, kind=r8)
+
+ END SUBROUTINE diel_soil_M04
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE diel_soil_M09(wc, t, wf_clay, eps)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the dielectric constant of a wet soil Developed and
+! validated from 1 to 10 GHz, adapted for a large range of soil moisture
+!
+! REFERENCES:
+! [1] V. L. Mironov, S. V. Fomin,
+! "Temperature and mineralogy dependable model for microwave dielectric
+! spectra of moist soils", PIERS Online, vol. 5, no. 5, pp. 411-415, 2009.
+!
+! [2] Mironov et al, Physically and Mineralogically Based Spectroscopic Dielectric
+! Model for Moist Soils. IEEE Trans. Geosc. Rem. Sens., vol 47 (7), 2059-2070. 2009.
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ IMPLICIT NONE
+
+! ------------------------ Dummy Argument ------------------------------
+ real(r8), intent(in) :: t ! soil temperature
+ real(r8), intent(in) :: wc ! soil moisture (m3/m3)
+ real(r8), intent(in) :: wf_clay ! weighted fraction (%)
+ complex(r8), intent(out) :: eps
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: nd, kd, mvt, ts, e0b, Bb, Bsgb, Fb, eb0
+ real(r8) :: dSbR, taub, sigmabt, sigmab, e0u, Bu, Bsgu, Fu, eu0, dHuR, dSuR, tauu, dHbR
+ real(r8) :: sigmau, sigmaut, cxb, eb_r, eb_i, cxu, eu_r, eu_i, nb, kb, nu, ku, nm, km, eps_r, eps_i
+
+!-----------------------------------------------------------------------
+!------------------------------------------------------------------------
+! Initializing the GRMDM spectroscopic parameters with clay (fraction)
+!------------------------------------------------------------------------
+ ! RI & NAC of dry soils
+ nd = 1.634 - 0.539 * (wf_clay/100) + 0.2748 * (wf_clay/100) ** 2 ! [1](11)
+ kd = 0.03952 - 0.04038 * (wf_clay/100) ! [1](12)
+
+ ! maximum bound water fraction
+ mvt = 0.02863 + 0.30673 * (wf_clay/100) ! [1](13)
+
+ ! starting temperature for parameters' fit ([1] p.413)
+ ts = 20.
+
+ ! eb0 computation
+ e0b = 79.8 - 85.4 * wf_clay + 32.7 * (wf_clay/100) **2 ! [1](14)
+ Bb = 8.67e-19 - 0.00126 * (wf_clay/100) + 0.00184 * (wf_clay/100) ** 2 - 9.77e-10*(wf_clay**3) - 1.39e-15 *(wf_clay**4) ! [1](15)
+ Bsgb = 0.0028 + 0.02094e-2*wf_clay - 0.01229e-4*(wf_clay**2) - 5.03e-22*(wf_clay**3) + 4.163e-24*(wf_clay**4) ! [1](23)
+ Fb = log((e0b - 1)/(e0b + 2)) ! [1](8)(ep0->e0p)
+ eb0 = (1 + 2*exp(Fb-Bb*(t-ts))) / (1 - exp(Fb-Bb*(t-ts))) ! [1](7)(e0p->ep0)
+
+ ! taub computation
+ dHbR = 1467 + 2697e-2*wf_clay - 980e-4 *(wf_clay**2) + 1.368e-10*(wf_clay**3) - 8.61e-13 *(wf_clay**4) ! [1](18)
+ dSbR = 0.888 + 9.7e-2 *wf_clay - 4.262e-4*(wf_clay**2) + 6.79e-21 *(wf_clay**3) + 4.263e-22*(wf_clay**4) ! [1](19)
+ taub = 48e-12 * exp(dHbR/(t+tfrz)-dSbR)/(t+tfrz) ! [1](9)
+
+ ! sigmab computation
+ sigmabt = 0.3112 + 0.467e-2*wf_clay ! [1](22)
+ sigmab = sigmabt + Bsgb*(t-ts) ! [1](10)
+
+ ! unbound (free) water parameters
+ !-------------------
+ ! eu0 computation
+ !-------------------
+ e0u = 100. ! [1](16)
+ Bu = 1.11e-4 - 1.603e-7 *wf_clay + 1.239e-9 *(wf_clay**2) + 8.33e-13 *(wf_clay**3) - 1.007e-14*(wf_clay**4) ! [1](17)
+ Bsgu = 0.00108 + 0.1413e-2*wf_clay - 0.2555e-4*(wf_clay**2) + 0.2147e-6*(wf_clay**3) - 0.0711e-8*(wf_clay**4) ! [1](25)
+ Fu = log((e0u - 1)/(e0u + 2)) ! [1](8)(ep0->e0p)
+ eu0 = (1 + 2*exp(Fu-Bu*(t-ts))) / (1-exp(Fu-Bu*(t-ts))) ! [1](7))e0p->ep0)
+
+ !--------------------
+ ! tauu computation
+ !--------------------
+ dHuR = 2231 - 143.1e-2 *wf_clay + 223.2e-4*(wf_clay**2) - 142.1e-6*(wf_clay**3) + 27.14e-8 *(wf_clay**4) ! [1](20)
+ dSuR = 3.649 - 0.4894e-2*wf_clay + 0.763e-4*(wf_clay**2) - 0.4859e-6*(wf_clay**3) + 0.0928e-8*(wf_clay**4) ! [1](21)
+ tauu = 48e-12 * exp(dHuR/(t+tfrz)-dSuR)/(t+tfrz) ! [1](9)
+
+ !----------------------
+ ! sigmau computation
+ !----------------------
+ sigmaut = 0.05_r8 + 1.4_r8*(1.0_r8 - (1.0_r8 - wf_clay*1.e-2_r8)**4.664_r8) ! [1](24)
+ sigmau = sigmaut + Bsgu*(t-ts) ! [1](10)
+
+ !--------------------------------------------------
+ ! computation of epsilon water (bound & unbound)
+ !--------------------------------------------------
+ cxb = (eb0-eps_w_inf) / (1+(2*pi*f*taub)**2) ! [1](6), [2](16)
+ eb_r = eps_w_inf + cxb ! [1](6), [2](16)
+ eb_i = cxb*(2*pi*f*taub) + sigmab/(2*pi*eps_0*f) ! [1](6), [2](16)
+ cxu = (eu0-eps_w_inf) / (1+(2*pi*f*tauu)**2) ! [1](6), [2](16)
+ eu_r = eps_w_inf + cxu ! [1](6), [2](16)
+ eu_i = cxu*(2*pi*f*tauu) + sigmau/(2*pi*eps_0*f) ! [1](6), [2](16)
+
+ !--------------------------------------------------------------
+ ! computation of refractive index of water (bound & unbound)
+ !--------------------------------------------------------------
+ nb = sqrt(sqrt(eb_r**2+eb_i**2)+eb_r) / sqrt(2.0) ! [1](5)
+ kb = sqrt(sqrt(eb_r**2+eb_i**2)-eb_r) / sqrt(2.0) ! [1](5)
+ nu = sqrt(sqrt(eu_r**2+eu_i**2)+eu_r) / sqrt(2.0) ! [1](5)
+ ku = sqrt(sqrt(eu_r**2+eu_i**2)-eu_r) / sqrt(2.0) ! [1](5)
+
+ !--------------------------------------------------
+ ! computation of soil refractive index (nm & km)
+ !--------------------------------------------------
+ IF (wc <= mvt) THEN
+ nm = nd + (nb-1)*wc ! [2](12)
+ km = kd + kb*wc ! [2](13)
+ ELSE
+ nm = nd + (nb-1)*mvt + (nu-1)*(wc-mvt) ! [2](12)
+ km = kd + kb*mvt + ku*(wc-mvt) ! [2](13)
+ ENDIF
+
+ !-------------------------------------------
+ ! computation of soil dielectric constant
+ !-------------------------------------------
+ eps_r = nm**2 - km**2 ! [1](4)
+ eps_i = 2* nm * km ! [1](4)
+ eps = cmplx(eps_r, eps_i, kind=r8)
+
+ END SUBROUTINE diel_soil_M09
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE diel_soil_D85(ew, swc, wf_sand, wf_clay, BD_all, eps)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the dielectric constant of a wet soil Developed and validated for 1.4 and 18 GHz.
+
+! REFERENCES:
+! [1] Dobson et al., 1985: Microwave Dielectric behavior of
+! wet soil - part II: Dielectric mixing models,
+! IEEE Trans. Geosc. Rem. Sens., GE-23, No. 1, 35-46.
+
+! [2] N. R. Peplinski, F. T. Ulaby, and M. C. Dobson,
+! Dielectric Properties of Soils in the 0.3-1.3-GHz Range,
+! IEEE Trans. Geosc. Rem. Sens., vol. 33, pp. 803-807, May 1995
+
+! [3] N. R. Peplinski, F. T. Ulaby, and M. C. Dobson,
+! Corrections to “Dielectric Properties of Soils in the 0.3-1.3-GHz Range",
+! IEEE Trans. Geosc. Rem. Sens., vol. 33, p. 1340, November 1995
+
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ IMPLICIT NONE
+
+! ------------------------ Dummy Argument ------------------------------
+ complex(r8), intent(in) :: ew ! dielectric constant of water
+ real(r8), intent(in) :: swc ! soil moisture
+ real(r8), intent(in) :: wf_sand ! gravimetric sand percent fraction(%)
+ real(r8), intent(in) :: wf_clay ! gravimetric clay percent fraction(%)
+ real(r8), intent(in) :: BD_all ! soil bulk density (g/cm3)
+ complex(r8), intent(out) :: eps
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: alphas = 0.65_r8
+ real(r8) :: beta, eaa, eps_s, epsi, epsr, wc
+
+!-----------------------------------------------------------------------
+
+ wc = max(swc, 0.001_r8)
+ eps_s = (1.01_r8 + 0.44_r8 * rho_soil)**2.0_r8 - 0.062_r8 ! [1](22)
+ beta = (127.48_r8 - 0.519_r8 * wf_sand - 0.152_r8 * wf_clay) / 100.0_r8 ! [1](30)
+ eaa = 1.0_r8 + (BD_all / rho_soil) * (eps_s ** alphas - 1.0_r8) &
+ & + (wc ** beta) * (real(ew) ** alphas) - wc ! [1](28)
+ epsr = eaa ** (1.0_r8/alphas) ! [2](2),[3]
+ beta = (133.797_r8 - 0.603_r8 * wf_sand - 0.166_r8 * wf_clay) / 100.0_r8 ! [1](31) 1.33797 -> 133.797, [2](5)
+ eaa = (wc ** beta) * (abs(aimag(ew)) ** alphas) ! [2](3)
+ epsi = eaa ** (1.0_r8/alphas) ! [2](3)
+ eps = cmplx(epsr, epsi, kind=r8)
+
+ END SUBROUTINE diel_soil_D85
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE smooth_reflectivity(eps, r_s)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the smooth surface reflectivity by Fresnel Law
+!
+! REFERENCES:
+! [1] Njoku and Kong, 1977: Theory for passive microwave remote sensing
+! of near-surface soil moisture. Journal of Geophysical Research,
+! Vol. 82, No. 20, 3108-3118.
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ complex(r8), intent(in) :: eps ! dielectric constant of the surface
+ real(r8), intent(out) :: r_s(2) ! reflectivities of flat surfaces for H and V polarizations
+
+!----------------------- Local Variables -------------------------------
+ complex(r8) :: g ! parameter in Fresnel Law
+
+!-----------------------------------------------------------------------
+
+ g = sqrt(eps - sin(theta)**2)
+ r_s(1) = abs((cos(theta) - g)/(cos(theta) + g))**2.
+ r_s(2) = abs((cos(theta)*eps - g)/(cos(theta)*eps + g))**2.
+
+ END SUBROUTINE smooth_reflectivity
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE rough_reflectivity(is_desert, patchclass, r_s, r_r)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the rough surface reflectivity
+!
+! REFERENCES:
+! [1] Kerr and Njokui, 1990: A Semiempirical Model For Interpreting Microwave
+! Emission From Semiarid Land Surfaces as Seen From Space
+! IEEE Trans. Geosci. Rem. Sens., Vol.28, No.3, 384-393.
+!
+! [2] Wigneron, J. P., Jackson, T. J., O'neill, P., De Lannoy, G., de Rosnay, P., Walker,
+! J. P., ... & Kerr, Y. (2017). Modelling the passive microwave signature from land surfaces:
+! A review of recent results and application to the L-band SMOS & SMAP soil moisture retrieval algorithms.
+! Remote Sensing of Environment, 192, 238-262.
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_DA_Const
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ logical, intent(in) :: is_desert ! flag for desert soil
+ integer, intent(in) :: patchclass ! patch class
+ real(r8), intent(in) :: r_s(2) ! reflectivities of flat surfaces for H and V polarizations
+ real(r8), intent(out) :: r_r(2) ! reflectivities of rough surfaces for H and V polarizations
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: Q ! parameter for polarization mixing
+ real(r8) :: hr(N_land_classification) ! roughness parameter
+ real(r8) :: nrh(N_land_classification) ! parameter for H polarization
+ real(r8) :: nrv(N_land_classification) ! parameter for V polarization
+
+!-----------------------------------------------------------------------
+
+ IF (is_desert) THEN
+ r_r = r_s
+ ELSE
+ ! calculate parameter for polarization mixing due to surface roughness
+ IF (fghz < 2.) THEN
+ Q = 0. ! Q is assumed zero at low frequency
+ ELSE
+ Q = 0.35*(1.0 - exp(-0.6*rgh_surf**2*fghz)) ! [1](16)
+ END IF
+
+ ! calculate rough surface reflectivity (default settings used in [2])
+ IF (DEF_DA_RTM_rough == 0) THEN
+ hr(:) = (2.0*kcm*rgh_surf)**2.0
+ nrh(:) = 0.0
+ nrv(:) = 0.0
+ ELSE IF (DEF_DA_RTM_rough == 1) THEN
+ hr(:) = hr_SMOS
+ nrh(:) = 2.0
+ nrv(:) = 0.0
+ ELSE IF (DEF_DA_RTM_rough == 2) THEN
+ hr(:) = hr_SMAP
+ nrh(:) = 2.0
+ nrv(:) = 2.0
+ ELSE IF (DEF_DA_RTM_rough == 3) THEN
+ hr(:) = hr_P16
+ nrh(:) = -1.0
+ nrv(:) = -1.0
+ END IF
+
+ ! rough surface reflectivity for H and V polarizations
+ r_r(1) = (Q*r_s(2) + (1.-Q)*r_s(1))*exp(-hr(patchclass)*cos(theta)**nrh(patchclass))
+ r_r(2) = (Q*r_s(1) + (1.-Q)*r_s(2))*exp(-hr(patchclass)*cos(theta)**nrv(patchclass))
+ END IF
+
+ END SUBROUTINE rough_reflectivity
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE desert(t_soil, r_r, eps, tb_desert)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate desert emissivity using Grody and Weng, 2008
+!
+! REFERENCES:
+! [1] Grody, N. C., & Weng, F. (2008). Microwave emission and scattering from deserts:
+! Theory compared with satellite measurements.
+! IEEE Transactions on Geoscience and Remote Sensing, 46, 361–375.
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ real(r8), intent(in) :: t_soil(2) ! desert surface temperature (K) (h-pol and v-pol)
+ real(r8), intent(in) :: r_r(2) ! reflectivity of rough surface (h-pol and v-pol)
+ complex(r8), intent(in) :: eps ! diel. const of desert
+ real(r8), intent(out) :: tb_desert(2) ! brightness temperature of soil for H- and V- polarization
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: f0 = 0.7 ! the fractional volume of spherical particles
+ ! (f = (4/3)*pi*r^3*n0),
+ ! r : the particle radius = 0.5 (mm)
+ ! n0 : the number of particles per unit volume.
+ real(r8) :: w ! single-particle albedo
+ real(r8) :: g ! asymmetry parameter
+ real(r8) :: a ! similarity parameter
+ real(r8) :: em(2) ! desert soil emissivity
+ real(r8) :: y_r ! real part of y-parameters
+ real(r8) :: y_i ! imaginary part of y-parameters
+
+!-----------------------------------------------------------------------
+ ! calculate y-parameters (eq.A15)
+ y_r = (real(eps) - 1)/(real(eps) + 2) ! [1](A15)
+ y_i = 3*aimag(eps)/(real(eps) + 2)**2 ! [1](A15)
+
+ ! calculate single-particle albedo (eq.A16)
+ w = (1 - f0)**4*kr**3*y_r**2/ &
+ ((1 - f0)**4*kr**3*y_r**2 + 1.5*(1 + 2*f0)**2*y_i) ! [1](A16)
+
+ ! calculate asymmetry parameter (p.374)
+ g = 0.23*kr**2 ! [1]p.374
+
+ ! calculate similarity parameter (eq.3b)
+ a = sqrt((1 - w)/(1 - w*g)) ! [1](3b)
+
+ ! calculate desert soil emissivity (eq.A13)
+ em = (1 - r_r)*(2*a/((1 + a) - (1 - a)*r_r)) ! [1](13)
+
+ ! calculate brightness temperature of desert
+ tb_desert = t_soil*em
+
+ END SUBROUTINE desert
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE veg(patchclass, lai, htop, snowdp, tleaf, tb_veg, gamma_p)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the brightness temperature on the top of vegetation
+!
+! REFERENCES:
+! [1] Wigneron et al., 2007, "L-band Microwave Emission of the Biosphere (L-MEB) Model:
+! Description and calibration against experimental
+! data sets over crop fields" Remote Sensing of Environment. Vol. 107, pp. 639-655k
+!
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ integer, intent(in) :: patchclass ! land cover class
+ real(r8), intent(in) :: lai ! leaf area index
+ real(r8), intent(in) :: tleaf ! leaf temperature (K)
+ real(r8), intent(out) :: tb_veg(2) ! brightness temperature of vegetation for H- and V- polarization
+ real(r8), intent(out) :: gamma_p(2) ! vegetation opacity for H- and V- polarization
+ real(r8), intent(in) :: htop, snowdp
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: tau_nadir ! vegetation opacity at nadir
+ real(r8) :: tau_veg(2) ! vegetation opacity for H- and V- polarization
+ integer :: i
+
+!-----------------------------------------------------------------------
+
+ ! caculate vegetation opacity (optical depth) at nadir b*VWC
+ IF (htop < snowdp) THEN
+ tau_nadir = b1(patchclass)*lai + b2(patchclass) ! low veg ! [1](22)
+ ELSE
+ tau_nadir = b3(patchclass) ! high veg
+ END IF
+
+ ! calculate vegetation optical depth at H- and V- polarizations
+ tau_veg(1) = tau_nadir*(cos(theta)**2 + tth(patchclass)*sin(theta)**2) ! [1](23)
+ tau_veg(2) = tau_nadir*(cos(theta)**2 + ttv(patchclass)*sin(theta)**2) ! [1](24)
+
+ ! calculate brightness temperature of vegetation
+ DO i = 1, 2
+ gamma_p(i) = exp(-tau_veg(i)/cos(theta)) ! [1](15)
+ tb_veg(i) = (1.-w_CMEM(patchclass))*(1.-gamma_p(i))*tleaf
+ END DO
+
+ END SUBROUTINE veg
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE snow(t_snow, t, snowdp, rho_snow, liq_snow, r_sn, r_snow, tb_tos)
+
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+! Calculate the brightness temperature of snow-covered ground
+!
+! REFERENCES:
+! [1] Christian Mätzler (1987) Applications of the interaction of
+! microwaves with the natural snow cover, Remote Sensing Reviews, 2:2, 259-387, DOI:
+! 10.1080/02757258709532086
+!
+! [2] Anderson, E. A., 1976: A point energy and mass balance model of a snow cover.
+! NOAA Tech. Rep. NWS 19, 150 pp. U.S. Dept. of Commer., Washington, D.C.(eq.5.1)
+!
+! [3] Hallikainen, M. T., F. Ulaby, and T. Deventer. 1987. Extinction behavior of dry snow in the
+! 18- to 90-GHz range. IEEE Trans. Geosci. Remote Sens., GE-25, 737–745.
+!
+! [4] Microwave remote sensing : active and passive
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Const_Physical
+ IMPLICIT NONE
+
+!------------------------ Dummy Argument ------------------------------
+ real(r8), intent(in) :: t_snow ! average snow temperature (K)
+ real(r8), intent(in) :: t ! temperature at bottom of snow (K), i.e., soil or leaf
+ real(r8), intent(in) :: snowdp ! snow depth (m)
+ real(r8), intent(in) :: rho_snow ! snow density (g/cm3)
+ real(r8), intent(in) :: liq_snow ! snow liquid water content (cm3/cm3)
+ real(r8), intent(in) :: r_sn(2) ! reflectivity between the snow and ground at (1, H-POL. 2, V.)
+ real(r8), intent(out) :: r_snow(2) ! reflectivity between the snow and air for H- and V- polarization
+ real(r8), intent(out) :: tb_tos(2) ! brightness temperature of snow-cover ground for H- and V- polarization
+
+!----------------------- Local Variables -------------------------------
+ real(r8) :: sal_snow = 0.0 ! snow salinity (pmm)
+ real(r8) :: eps_i_r ! real part of dielectric constant of ice
+ real(r8) :: eps_i_i ! imaginary part of dielectric constant of ice
+ real(r8) :: eps_i_is ! imaginary part of dielectric constant of impure ice -5(C)
+ real(r8) :: eps_i_ip ! imaginary part of dielectric constant of pure ice -5(C)
+ real(r8) :: eps_ds_r ! real part of dielectric constant of dry snow
+ real(r8) :: eps_ds_i ! imaginary part of dielectric constant of dry snow
+ real(r8) :: eps_ws_i ! imaginary part of dielectric constant of wet snow
+ real(r8) :: eps_ws_r ! real part of dielectric constant of wet snow
+ real(r8) :: eps_w_s = 88. ! dielectric constant of static water
+ real(r8) :: eps_a_inf, eps_b_inf, eps_c_inf ! infinite frequency dielectric constant of three parts
+ real(r8) :: eps_a_s, eps_b_s, eps_c_s ! static dielectric constant of three parts
+ complex(r8) :: eps_i ! dielectric constant of ice
+ complex(r8) :: eps_a
+ complex(r8) :: eps_b
+ complex(r8) :: eps_c ! dielectric constant of three parts
+ complex(r8) :: eps ! dielectric constant of wet snow
+ real(r8) :: rho_ds ! density of dry snow (g/cm3)
+ real(r8) :: rho_i = 0.916 ! density of ice (g/cm3)
+ real(r8) :: aa = 0.005
+ real(r8) :: bb = 0.4975
+ real(r8) :: cc = 0.4975 ! fitting parameters
+ real(r8) :: fa, fb, fc ! relaxation frequency of wet snow
+ real(r8) :: d ! snow grain size (mm)
+ real(r8) :: alpha, beta, pp, qq ! parameter used to calculate propogation angle in snow
+ real(r8) :: theta_s ! propogation angle in snow
+ complex(r8) :: z_s ! wave impedance in snow
+ real(r8) :: r_sa ! reflectivity between the snow and air for H- and V- polarization
+ real(r8) :: tb_2 ! the net apparent temperature contributions due to emission by layers 2 (snow)
+ real(r8) :: tb_3 ! the net apparent temperature contributions due to emission by layers 3 (soil)
+ real(r8) :: l2_apu ! extinction coefficient of snow (Beer's Law)
+ real(r8) :: q = 0.96 ! parameter
+ real(r8) :: ka_ws ! absorption coefficient of wet snow
+ real(r8) :: ka_ds ! absorption coefficient of dry snow
+ real(r8) :: ke ! extinction coefficient of wet snow
+ real(r8) :: ke_ds ! extinction coefficient of dry snow
+ real(r8) :: ks ! scattering coefficient of snow
+ real(r8) :: b_ds, b_ws
+ real(r8) :: wk_h ! [m], equal to cmem cmem_snow_set_var.F90:476
+ integer :: i
+
+!-----------------------------------------------------------------------
+ IF (snowdp > 0.01) THEN ! > 1cm
+ ! calculate dielectric constant of ice
+ CALL diel_ice(t_snow - tfrz, eps_i)
+ eps_i_r = real(eps_i)
+ eps_i_i = aimag(eps_i)
+
+ ! consider the effect of salinity on the dielectric constant of ice
+ eps_i_is = 0.0026/fghz + 0.00023*(fghz**0.87) ! impure ice -5(C)
+ eps_i_ip = 6.e-4/fghz + 6.5e-5*(fghz**1.07) ! pure ice -5(C)
+ eps_i_i = eps_i_i + (eps_i_is - eps_i_ip)*sal_snow/13.0d0 ! corrected imaginary part of diel cons of ice
+
+ ! calculate dielectric constant of dry snow (mixed by air and ice) (Polder–van Santen mixing model)
+ rho_ds = (rho_snow - liq_snow)/(1.0 - liq_snow) ! caculate density of dry snow,
+ eps_ds_r = 1.0 + 1.58*rho_ds/(1.0 - 0.365*rho_ds)
+ eps_ds_i = 3.0*(rho_ds/rho_i)*eps_i_i*(eps_ds_r**2)*(2*eps_ds_r + 1)/ &
+ ((eps_i_r + 2*eps_ds_r)*(eps_i_r + 2*eps_ds_r**2)) ! negative imaginary part of diel cons of dry snow
+
+ ! calculate dielectric constant of wet snow (Matzler 1987)
+ IF (liq_snow > 0.) THEN ! wet snow
+ ! caculate relaxation frequency of three parts (eq.2.26)
+ fa = f0w*(1 + (aa*(eps_w_s - eps_w_inf)/(eps_ds_r + (aa*(eps_w_inf - eps_ds_r)))))
+ fb = f0w*(1 + (bb*(eps_w_s - eps_w_inf)/(eps_ds_r + (bb*(eps_w_inf - eps_ds_r)))))
+ fc = f0w*(1 + (cc*(eps_w_s - eps_w_inf)/(eps_ds_r + (cc*(eps_w_inf - eps_ds_r)))))
+
+ ! caculate infinite frequency dielectric constant of three parts
+ eps_a_inf = (liq_snow*(eps_w_inf - eps_ds_r)/3.)/ &
+ (1.+aa*((eps_w_inf/eps_ds_r) - 1.))
+ eps_b_inf = (liq_snow*(eps_w_inf - eps_ds_r)/3.)/ &
+ (1.+bb*((eps_w_inf/eps_ds_r) - 1.))
+ eps_c_inf = (liq_snow*(eps_w_inf - eps_ds_r)/3.)/ &
+ (1.+cc*((eps_w_inf/eps_ds_r) - 1.))
+
+ ! caculate static dielectric constant of three parts
+ eps_a_s = (liq_snow/3.)*(eps_w_s - eps_ds_r)/ &
+ (1.+aa*((eps_w_s/eps_ds_r) - 1.))
+ eps_b_s = (liq_snow/3.)*(eps_w_s - eps_ds_r)/ &
+ (1.+bb*((eps_w_s/eps_ds_r) - 1.))
+ eps_c_s = (liq_snow/3.)*(eps_w_s - eps_ds_r)/ &
+ (1.+cc*((eps_w_s/eps_ds_r) - 1.))
+
+ ! Debye equations
+ eps_a = eps_a_inf + (eps_a_s - eps_a_inf)/(1 + jj*fghz/fa)
+ eps_b = eps_b_inf + (eps_b_s - eps_b_inf)/(1 + jj*fghz/fb)
+ eps_c = eps_c_inf + (eps_c_s - eps_c_inf)/(1 + jj*fghz/fc)
+
+ ! calculate dielectric constant of wet snow
+ eps = eps_a + eps_b + eps_c + (eps_ds_r - jj*eps_ds_i)
+ eps_ws_r = real(eps)
+ eps_ws_i = -1.*aimag(eps)
+ ELSE
+ eps_ws_r = eps_ds_r
+ eps_ws_i = eps_ds_i
+ END IF
+
+ ! caculate propogation angle in snow (change medium from air to snow)
+ alpha = k*abs(aimag(sqrt(eps_ws_r - jj*eps_ws_i)))
+ beta = k*real(sqrt(eps_ws_r - jj*eps_ws_i))
+ pp = 2.*alpha*beta
+ qq = beta**2 - alpha**2 - (k*k)*(sin(theta)**2)
+ theta_s = atan(k*sin(theta)/((1./sqrt(2.)) &
+ *sqrt(sqrt(pp**2.+qq**2.) + qq)))
+
+ ! caclulate wave impedance in snow
+ z_s = z0/sqrt(eps_ws_r - jj*eps_ws_i)
+
+ ! calculate brightness temperature above snow for H- V- polarization
+ DO i = 1, 2
+ ! Fresnel reflection coefficient between snow and air
+ IF (i == 1) THEN
+ r_sa = abs((z_s*cos(theta) - z0*cos(theta_s))/ &
+ (z_s*cos(theta) + z0*cos(theta_s)))**2
+ ELSE
+ r_sa = abs((z0*cos(theta) - z_s*cos(theta_s))/ &
+ (z0*cos(theta) + z_s*cos(theta_s)))**2
+ END IF
+
+ ! calculate snow grain size (mm) (Anderson 1976, eq.5.1) TODO
+ d = min(1000*(1.6e-4 + 1.1e-13*((rho_snow*1000.0)**4)), 3.0)
+
+ ! extinction coefficient of dry snow
+ !//TODO: the paper is not focus on L-band, thus the formula is not suitable
+ ke_ds = 0.0018*(fghz**2.8)*(d**2)/4.3429 ! [3](14)
+
+ ! absorption coefficient of dry snow
+ b_ds = (eps_ds_i/eps_ds_r)**2
+ ka_ds = 2.*omega*sqrt(mu0*eps_0*eps_ds_r)* &
+ sqrt(b_ds/(2.*(sqrt(1.+b_ds) + 1.)))
+
+ IF (ke_ds < ka_ds) ke_ds = ka_ds
+
+ ! absorption coefficient of wet snow
+ b_ws = (eps_ws_i/eps_ws_r)**2
+ ka_ws = 2.*omega*sqrt(mu0*eps_0*eps_ws_r)* &
+ sqrt(b_ws/(2.*(sqrt(1.+b_ws) + 1)))
+
+ ! total extinction (assuming scattering is the same for dry and wet snow)
+ ke = (ke_ds - ka_ds) + ka_ws
+
+ ! scattering coefficient of dry and wet snow
+ ks = ke_ds - ka_ds
+
+ wk_h = snowdp/rho_snow
+ IF (((ke - q*ks)*(1./cos(theta_s))*wk_h) > (log(HUGE(1.)) - 1.)) THEN
+ l2_apu = sqrt(HUGE(1.))
+ ELSE
+ l2_apu = min(sqrt(HUGE(1.)), exp((ke - q*ks)*(1./cos(theta_s))*wk_h))
+ END IF
+
+ ! brightness temperature through snow-air layer ([4] pp.243, eq.4.161)
+ tb_2 = (1.+r_sn(i)/l2_apu)*(1.-r_sa)*t_snow* &
+ (ka_ws/(ke - q*ks))*(1.-1./l2_apu)/ &
+ (1.-r_sn(i)*r_sa/l2_apu**2.)
+
+ ! brightness temperature through soil-snow layer ([4] pp.243, eq.4.162)
+ tb_3 = ((1.-r_sn(i))*(1.-r_sa)*t)/ &
+ (l2_apu*(1.-r_sn(i)*r_sa/l2_apu**2.))
+
+ ! brightness temperature of snow-cover ground
+ tb_tos(i) = tb_2 + tb_3
+
+ ! emission by layers 2 (snow) and 3 (soil)
+ ! reflectivity by layers 2 (snow) and 3 (soil)
+ r_snow(i) = 1 - (tb_2/t_snow + tb_3/t)
+ END DO
+ END IF
+
+ END SUBROUTINE snow
+!-----------------------------------------------------------------------
+END MODULE MOD_DA_RTM
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90
new file mode 100644
index 0000000000..8854feb488
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_SM.F90
@@ -0,0 +1,1787 @@
+#include
+
+#ifdef DataAssimilation
+MODULE MOD_DA_SM
+!-----------------------------------------------------------------------------
+! DESCRIPTION:
+! Data assimilation of surface soil moisture and temperature
+!
+! AUTHOR:
+! Lu Li, 12/2024: Initial version, based on SMAP L1C TB data
+! Zhilong Fan, Lu Li, 03/2024: Debug and clean codes
+! Lu Li, 07/2025: reframe codes
+! Lu Li, 10/2025: support SMAP/FY3D/SYNOP data
+!-----------------------------------------------------------------------------
+ USE MOD_DataType
+ USE MOD_SpatialMapping
+ USE MOD_DA_RTM
+ USE MOD_DA_EnKF
+ USE MOD_DA_Vars_TimeVariables
+ USE MOD_Vars_Global, only: pi, nl_soil, maxsnl
+ USE MOD_LandPatch
+ USE MOD_Block
+ USE MOD_Namelist
+ USE MOD_DA_Vars_TimeVariables
+ USE MOD_Pixelset
+ USE MOD_Pixel
+ USE MOD_Mesh
+ IMPLICIT NONE
+ SAVE
+
+! public functions
+ PUBLIC :: init_DA_SM
+ PUBLIC :: run_DA_SM
+ PUBLIC :: end_DA_SM
+
+ PRIVATE
+
+! local variables
+!#############################################################################
+! Universal variables
+!#############################################################################
+ ! time (UTC) at current step
+ integer :: month, mday, hour ! month, day, hour of current step
+ character(len=256) :: yearstr, monthstr, daystr, hourstr ! string of year, month, day, hour
+ integer :: idate_b, idate_e ! begin & end seconds since begin of current day (UTC)
+
+ integer :: num_obs_p
+ ! mask water
+ logical, allocatable :: filter(:) ! to mask the water
+
+ ! logical
+ logical, allocatable :: has_DA ! whether has data assimilation
+
+ ! setting of SMAP satellite
+ real(r8), parameter :: smap_theta = 40.0*pi/180 ! incidence angle (rad)
+ real(r8), parameter :: smap_fghz = 1.4 ! frequency (GHz), L-band
+
+ ! setting of FY satellite
+ real(r8), parameter :: fy3d_theta = 40.0*pi/180 ! incidence angle (rad)
+ real(r8), parameter :: fy3d_fghz = 1.4 ! frequency (GHz), L-band
+
+ ! parameters of LETKF
+ real(r8), allocatable :: obs_err(:) ! observation error
+ real(r8), parameter :: dres = 0.4 ! search localization radius (deg)
+ real(r8), parameter :: loc_r = 40.0 ! localization radius (km)
+ real(r8), parameter :: infl = 1.2 ! inflation factor
+
+ ! data assimilation outputs
+ real(r8), allocatable :: trans(:,:) ! transformation matrix on each patch
+ real(r8), allocatable :: wliq_soi_ens(:,:) ! soil liquid water content
+ real(r8), allocatable :: wliq_soi_ens_da(:,:) ! soil liquid water content after data assimilation
+ real(r8), allocatable :: t_soi_ens(:,:) ! soil temperature
+ real(r8), allocatable :: t_soi_ens_da(:,:) ! soil temperature after data assimilation
+ real(r8) :: eff_porsl ! effective porosity of each soil layer
+ integer :: end_idx(3)
+
+ real(r8), allocatable :: pred_obs_p_ens(:,:) ! predicted observations on each patch
+ real(r8), allocatable :: obs_p(:) ! observations on each patch
+ real(r8), allocatable :: obs_err_p(:) ! observation errors on each patch
+
+ real(r8), allocatable :: smap_err(:) ! observation errors for SMAP TB
+ real(r8), allocatable :: fy3d_err(:) ! observation errors for FY3D TB
+ real(r8), allocatable :: synop_tref_err(:) ! observation errors for SYNOP 2m temperature
+ real(r8), allocatable :: synop_qref_err(:) ! observation errors for SYNOP 2m humidity
+
+!#############################################################################
+! For SMAP L1C brightness temperature
+!#############################################################################
+ ! file path
+ character(len=256) :: file_smap ! SMAP observation file path
+ character(len=256) :: file_grid_smap ! SMAP world grid file path
+
+ ! grid
+ type(grid_type) :: grid_smap ! SMAP world grid
+ type(spatial_mapping_type) :: mg2p_smap ! mapping between SMAP world grid to patch
+
+ ! time variables used to determine whether has obs
+ real(r8), allocatable :: smap_time(:) ! seconds of all obs since begin of current day (UTC)
+ real(r8), allocatable :: dt_b_smap(:) ! delta time between SMAP and begin seconds of current day
+ real(r8), allocatable :: dt_e_smap(:) ! delta time between SMAP and end seconds of current day
+
+ ! logical variables
+ logical :: has_smap_file ! whether has file of SMAP at target hour
+ logical :: has_smap_obs ! whether has SMAP obs at current step
+
+ ! observations (dimensions changes with time)
+ integer :: num_smap_obs ! number of all obs in current file
+ integer :: num_smap_obs_domain ! number of all obs in simulation domain at current file
+ real(r8), allocatable :: smap_lat(:) ! latitude of all obs
+ real(r8), allocatable :: smap_lon(:) ! longitude of all obs
+ real(r8), allocatable :: smap_tb_h(:) ! H- polarized brightness temperature of all obs ([K])
+ real(r8), allocatable :: smap_tb_v(:) ! V- polarized brightness temperature of all obs ([K])
+ integer, allocatable :: smap_ii(:) ! i-th lat grid in world map of all obs
+ integer, allocatable :: smap_jj(:) ! j-th lon grid in world map of all obs
+
+ ! history mean value of smap and colm
+ real(r8), allocatable :: pred_smap_tb_h_mean(:) ! history mean value of predicted H- polarized temp
+ real(r8), allocatable :: pred_smap_tb_v_mean(:) ! history mean value of predicted V- polarized temp
+ real(r8), allocatable :: smap_tb_h_mean(:) ! history mean value of SMAP H- polarized temp
+ real(r8), allocatable :: smap_tb_v_mean(:) ! history mean value of SMAP V- polarized temp
+
+ ! ensemble predicted observations (at patch)
+ real(r8), allocatable :: pred_smap_tb_h_pset_ens(:, :) ! predicted H- polarized temp on patch
+ real(r8), allocatable :: pred_smap_tb_v_pset_ens(:, :) ! predicted V- polarized temp on patch
+ real(r8), allocatable :: area_pset(:) ! area of each patch across world grid
+
+ ! ensemble predicted observations (at world grid)
+ type(block_data_real8_3d) :: pred_smap_tb_h_wgrid_ens ! predicted H- polarized temp on world grid
+ type(block_data_real8_3d) :: pred_smap_tb_v_wgrid_ens ! predicted V- polarized temp on world grid
+ type(block_data_real8_2d) :: area_smap_wgrid ! area of each patch across world grid
+
+ ! ensemble predicted observations (at obs grid)
+ real(r8), allocatable :: pred_smap_tb_h_ogrid_ens(:, :) ! predicted H- polarized temp on obs grid
+ real(r8), allocatable :: pred_smap_tb_v_ogrid_ens(:, :) ! predicted V- polarized temp on obs grid
+ real(r8) :: area_smap_wgrid_obs ! area of each patch across world grid for each obs
+
+ ! observations around patch (dimensions changes with patch)
+ integer :: num_smap_p
+ logical, allocatable :: index_smap_p(:) ! index of obs around each patch
+ real(r8), allocatable :: smap_lat_p(:) ! latitude of obs around each patch
+ real(r8), allocatable :: smap_lon_p(:) ! longitude of obs around each patch
+ real(r8), allocatable :: smap_tb_h_p(:) ! H- polarized brightness temperature of obs around each patch ([K])
+ real(r8), allocatable :: smap_tb_v_p(:) ! V- polarized brightness temperature of obs around each patch ([K])
+ real(r8), allocatable :: pred_smap_tb_h_p_ens(:, :) ! predicted H- polarized temp around patch
+ real(r8), allocatable :: pred_smap_tb_v_p_ens(:, :) ! predicted V- polarized temp around patch
+
+ ! history mean value of brightness temperature around patch
+ real(r8), allocatable :: pred_smap_tb_h_mean_p(:) ! history mean value of predicted H- polarized temp around patch
+ real(r8), allocatable :: pred_smap_tb_v_mean_p(:) ! history mean value of predicted V- polarized temp around patch
+ real(r8), allocatable :: smap_tb_h_mean_p(:) ! history mean value of SMAP H- polarized temp around patch
+ real(r8), allocatable :: smap_tb_v_mean_p(:) ! history mean value of SMAP V- polarized temp around patch
+
+ ! parameters for distance calculation
+ real(r8), allocatable :: d_smap_p(:) ! distance between obs and patch center
+ real(r8), parameter :: static_smap_err = 0.1 ! static observation error
+
+!#############################################################################
+! For FY3D L1 brightness temperature
+!#############################################################################
+ ! file path
+ character(len=256) :: file_fy3d ! FY3D observation file path
+ character(len=256) :: file_grid_fy3d ! FY3D world grid file path
+
+ ! grid
+ type(grid_type) :: grid_fy3d ! FY3D world grid
+ type(spatial_mapping_type) :: mg2p_fy3d ! mapping between FY3D world grid to patch
+
+ ! time variables used to determine whether has obs
+ real(r8), allocatable :: fy3d_time(:) ! seconds of all obs since begin of current day (UTC)
+ real(r8), allocatable :: dt_b_fy3d(:) ! delta time between FY3D and begin seconds of current day
+ real(r8), allocatable :: dt_e_fy3d(:) ! delta time between FY3D and end seconds of current day
+
+ ! logical variables
+ logical :: has_fy3d_file ! whether has file of FY3D at target hour
+ logical :: has_fy3d_obs ! whether has FY3D obs at current step
+
+ ! observations (dimensions changes with time)
+ integer :: num_fy3d_obs ! number of all obs in current file
+ integer :: num_fy3d_obs_domain ! number of all obs in simulation domain at current file
+ real(r8), allocatable :: fy3d_lat(:) ! latitude of all obs
+ real(r8), allocatable :: fy3d_lon(:) ! longitude of all obs
+ real(r8), allocatable :: fy3d_tb_h(:) ! H- polarized brightness temperature of all obs ([K])
+ real(r8), allocatable :: fy3d_tb_v(:) ! V- polarized brightness temperature of all obs ([K])
+ integer, allocatable :: fy3d_ii(:) ! i-th lat grid in world map of all obs
+ integer, allocatable :: fy3d_jj(:) ! j-th lon grid in world map of all obs
+
+ ! history mean value of fy3d and colm
+ real(r8), allocatable :: pred_fy3d_tb_h_mean(:) ! history mean value of predicted H- polarized temp
+ real(r8), allocatable :: pred_fy3d_tb_v_mean(:) ! history mean value of predicted V- polarized temp
+ real(r8), allocatable :: fy3d_tb_h_mean(:) ! history mean value of FY3D H- polarized temp
+ real(r8), allocatable :: fy3d_tb_v_mean(:) ! history mean value of FY3D V- polarized temp
+
+ ! ensemble predicted observations (at patch)
+ real(r8), allocatable :: pred_fy3d_tb_h_pset_ens(:, :) ! predicted H- polarized temp on patch
+ real(r8), allocatable :: pred_fy3d_tb_v_pset_ens(:, :) ! predicted V- polarized temp on patch
+
+ ! ensemble predicted observations (at world grid)
+ type(block_data_real8_3d) :: pred_fy3d_tb_h_wgrid_ens ! predicted H- polarized temp on world grid
+ type(block_data_real8_3d) :: pred_fy3d_tb_v_wgrid_ens ! predicted V- polarized temp on world grid
+ type(block_data_real8_2d) :: area_fy3d_wgrid ! area of each patch across world grid
+
+ ! ensemble predicted observations (at obs grid)
+ real(r8), allocatable :: pred_fy3d_tb_h_ogrid_ens(:, :) ! predicted H- polarized temp on obs grid
+ real(r8), allocatable :: pred_fy3d_tb_v_ogrid_ens(:, :) ! predicted V- polarized temp on obs grid
+ real(r8) :: area_fy3d_wgrid_obs ! area of each patch across world grid for each obs
+
+ ! observations around patch (dimensions changes with patch)
+ integer :: num_fy3d_p
+ logical, allocatable :: index_fy3d_p(:) ! index of obs around each patch
+ real(r8), allocatable :: fy3d_lat_p(:) ! latitude of obs around each patch
+ real(r8), allocatable :: fy3d_lon_p(:) ! longitude of obs around each patch
+ real(r8), allocatable :: fy3d_tb_h_p(:) ! H- polarized brightness temperature of obs around each patch ([K])
+ real(r8), allocatable :: fy3d_tb_v_p(:) ! V- polarized brightness temperature of obs around each patch ([K])
+ real(r8), allocatable :: pred_fy3d_tb_h_p_ens(:, :) ! predicted H- polarized temp around patch
+ real(r8), allocatable :: pred_fy3d_tb_v_p_ens(:, :) ! predicted V- polarized temp around patch
+
+ ! history mean value of brightness temperature around patch
+ real(r8), allocatable :: pred_fy3d_tb_h_mean_p(:) ! history mean value of predicted H- polarized temp around patch
+ real(r8), allocatable :: pred_fy3d_tb_v_mean_p(:) ! history mean value of predicted V- polarized temp around patch
+ real(r8), allocatable :: fy3d_tb_h_mean_p(:) ! history mean value of FY3D H- polarized temp around patch
+ real(r8), allocatable :: fy3d_tb_v_mean_p(:) ! history mean value of FY3D V- polarized temp around patch
+
+ ! parameters for distance calculation
+ real(r8), allocatable :: d_fy3d_p(:) ! distance between obs and patch center
+ real(r8), parameter :: static_fy3d_err = 10.0 ! static observation error
+
+!#############################################################################
+! For SYNOP 2m temperature and humidity observations
+!#############################################################################
+ ! derived types of pixel index in each rank
+ ! firstly sorted by pixel latitude index (nlat) and record
+ ! corresponding longitude index and patch id for each pixel
+ type :: idx_type
+ integer, allocatable :: ilon (:)
+ integer, allocatable :: ipatch (:)
+ END type idx_type
+ type(idx_type), allocatable :: idx (:) ! derived types of pixel index at each rank
+ integer, allocatable :: counter (:) ! counter of pixel longitude index of each latitude index at each rank
+
+ ! file path
+ character(len=256) :: file_synop ! SYNOP file path
+
+ ! info of all SYNOP sites
+ character(len=256) :: file_site ! file of location of all SYNOP sites
+ real(r8), allocatable :: synop_lat_all(:)
+ real(r8), allocatable :: synop_lon_all(:) ! latitude and longitude of all SYNOP sites
+ integer :: nsite ! number of all SYNOP sites
+ integer, allocatable :: iloc_synop (:,:) ! global lat/lon index of pixel cover each site in all SYNOP sites
+ integer :: counter_rank_nsite ! number of all SYNOP sites located at each rank
+ integer, allocatable :: ip_rank (:,:) ! patch id of all SYNOP sites located at each rank
+ integer, allocatable :: idx_lat(:), idx_lon(:), pos(:) ! temporary array save global lat/lon index of each site
+ integer, allocatable :: synop_lut (:,:) ! look-up-table of all SYNOP sites
+
+ ! time variables used to determine whether has obs
+ real(r8), allocatable :: synop_time(:) ! seconds of all obs since begin of current day (UTC)
+ real(r8), allocatable :: dt_b_synop(:) ! delta time between SYNOP and begin seconds of current day
+ real(r8), allocatable :: dt_e_synop(:) ! delta time between SYNOP and end seconds of current day
+
+ ! logical variables
+ logical :: has_synop_file ! whether has file of SYNOP at target day
+ logical :: has_synop_obs ! whether has SYNOP obs at current step
+
+ ! info of SYNOP sites at each step
+ integer, allocatable :: synop_idx (:,:) ! index of SYNOP sites (rank/patch id) at each step
+ integer, allocatable :: site_id_rank (:) ! site id of SYNOP sites at each step at each rank
+ real(r8), allocatable :: tref_ens_rank (:,:) ! predicted 2m temperature of SYNOP sites at each step at each rank
+ real(r8), allocatable :: qref_ens_rank (:,:) ! predicted 2m humidity of SYNOP sites at each step at each rank
+ real(r8), allocatable :: qref_ens_o (:,:) ! predicted 2m temperature of SYNOP sites at each step
+ real(r8), allocatable :: tref_ens_o (:,:) ! predicted 2m humidity of SYNOP sites at each step
+
+ ! observations (dimensions changes with time)
+ integer :: num_synop_obs ! number of all obs in current file
+ integer :: num_synop_obs_domain ! number of all obs in simulation domain at current file
+ real(r8), allocatable :: synop_lat(:) ! latitude of all obs
+ real(r8), allocatable :: synop_lon(:) ! longitude of all obs
+ integer, allocatable :: synop_id(:) ! global id of all obs
+ real(r8), allocatable :: synop_tref(:) ! 2m temperature of all obs ([K])
+ integer, allocatable :: synop_qref(:) ! 2m humidity of all obs ([K])
+
+ ! observations around patch (dimensions changes with patch)
+ integer :: num_synop_p
+ logical, allocatable :: index_synop_p(:) ! index of obs around each patch
+ real(r8), allocatable :: synop_lat_p(:) ! latitude of obs around each patch
+ real(r8), allocatable :: synop_lon_p(:) ! longitude of obs around each patch
+ real(r8), allocatable :: synop_qref_p(:) ! 2m temperature of obs around each patch ([K])
+ real(r8), allocatable :: synop_tref_p(:) ! 2m humidity of obs around each patch ([K])
+ real(r8), allocatable :: synop_p(:) ! concatenate 2m temperature and humidity of obs around each patch
+ real(r8), allocatable :: qref_ens_p(:,:) ! predicted 2m temperature around patch
+ real(r8), allocatable :: tref_ens_p(:,:) ! predicted 2m humidity around patch
+ real(r8), allocatable :: pred_synop_ens_p(:,:) ! predicted 2m temperature and humidity around patch
+
+ ! parameters for distance calculation
+ real(r8), allocatable :: d_synop_p(:) ! distance between obs and patch center
+ real(r8), parameter :: static_synop_tref_err = 1.0 ! static observation error (2m temperature)
+ real(r8), parameter :: static_synop_qref_err = 0.04 ! static observation error (2m humidity)
+
+!-----------------------------------------------------------------------------
+
+CONTAINS
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE init_DA_SM()
+
+!-----------------------------------------------------------------------------
+ USE MOD_Spmd_Task
+ USE MOD_Namelist, only: DEF_DA_obsdir
+ USE MOD_Grid
+ USE MOD_NetCDFSerial
+ USE MOD_LandPatch
+ USE MOD_Pixelset
+ USE MOD_RangeCheck
+ IMPLICIT NONE
+
+ integer :: np, ie, ipxstt, ipxend, ipxl, i, ilat, isite, ilon, iwork, mesg(2), isrc, ndata, numpxl_lat, numpxl_lon, numpxl
+ integer, allocatable :: temp (:,:) ! temporary array for receiving data from ranks
+
+!-----------------------------------------------------------------------------
+
+#ifndef SinglePoint
+ IF (DEF_DA_SM_SMAP) THEN
+ ! grid file path of EASE v2.0, 36km world grid
+ file_grid_smap = trim(DEF_DA_obsdir)//'/grid/'//'/SMAP_L1C_36km.nc'
+ CALL grid_smap%define_from_file(file_grid_smap, 'latitude', 'longitude')
+
+ ! map SMAP grid to patch
+ CALL mg2p_smap%build_arealweighted(grid_smap, landpatch)
+ ENDIF
+
+ IF (DEF_DA_SM_FY) THEN
+ ! grid file path of FY3D, 0.25 degree world grid
+ file_grid_fy3d = trim(DEF_DA_obsdir)//'/grid/'//'/FY3D_L1_0p25.nc'
+
+ CALL grid_fy3d%define_from_file(file_grid_fy3d, 'latitude', 'longitude')
+
+ ! map FY3D grid to patch
+ CALL mg2p_fy3d%build_arealweighted(grid_fy3d, landpatch)
+ ENDIF
+
+ IF (DEF_DA_SM_SYNOP) THEN
+!#############################################################################
+! Makeup derived types of pixel index for fast access at each rank
+!#############################################################################
+ IF (p_is_compute) THEN
+ allocate (counter (pixel%nlat))
+ counter(:) = 0
+
+ ! count the number of pixel lon index for each pixel lat index
+ DO np = 1, numpatch
+ ie = landpatch%ielm(np)
+
+ ipxstt = landpatch%ipxstt(np)
+ ipxend = landpatch%ipxend(np)
+
+ DO ipxl = ipxstt, ipxend
+ counter(mesh(ie)%ilat(ipxl)) = counter(mesh(ie)%ilat(ipxl)) + 1
+ ENDDO
+ ENDDO
+
+ ! allocate derived types of index
+ allocate (idx (pixel%nlat))
+ DO i = 1, pixel%nlat
+ IF (counter(i) > 0) THEN
+ allocate (idx(i)%ilon(counter(i)))
+ allocate (idx(i)%ipatch(counter(i)))
+
+ idx(i)%ilon(:) = 0
+ idx(i)%ipatch(:) = 0
+ ENDIF
+ ENDDO
+
+ ! fill the index
+ counter(:) = 0
+ DO np = 1, numpatch
+ ie = landpatch%ielm(np)
+
+ ipxstt = landpatch%ipxstt(np)
+ ipxend = landpatch%ipxend(np)
+
+ DO ipxl = ipxstt, ipxend
+ ilat = mesh(ie)%ilat(ipxl)
+ counter(mesh(ie)%ilat(ipxl)) = counter(mesh(ie)%ilat(ipxl)) + 1
+ idx(ilat)%ilon(counter(mesh(ie)%ilat(ipxl))) = mesh(ie)%ilon(ipxl)
+ idx(ilat)%ipatch(counter(mesh(ie)%ilat(ipxl))) = np
+ ENDDO
+ ENDDO
+ ENDIF
+
+
+!#############################################################################
+! Read the location of SYNOP sites and find the located pixel of each site
+!#############################################################################
+ ! file of SYNOP sites
+ file_site = trim(DEF_DA_obsdir)//'/grid/'//'/SYNOP.nc'
+
+ ! read latitude and longitude of sites
+ IF (ncio_var_exist(file_site, 'latitude')) THEN
+ CALL ncio_read_bcast_serial(file_site, 'latitude', synop_lat_all)
+ CALL ncio_read_bcast_serial(file_site, 'longitude', synop_lon_all)
+ ENDIF
+ nsite = size(synop_lat_all)
+
+ ! find the located pixel of each site & broadcast ranks
+ allocate (iloc_synop (2, nsite))
+ iloc_synop(:,:) = -1
+ IF (p_is_root) THEN
+ DO i = 1, nsite
+ numpxl_lat = count(pixel%lat_s <= synop_lat_all(i) .and. pixel%lat_n > synop_lat_all(i))
+ numpxl_lon = count(pixel%lon_w <= synop_lon_all(i) .and. pixel%lon_e > synop_lon_all(i))
+
+ IF (numpxl_lat ==1 .and. numpxl_lon ==1) THEN
+ IF (allocated (idx_lat)) deallocate (idx_lat)
+ IF (allocated (idx_lon)) deallocate (idx_lon)
+ allocate (idx_lat(numpxl_lat))
+ allocate (idx_lon(numpxl_lon))
+
+ idx_lat = pack([(isite, isite=1, pixel%nlat)], pixel%lat_s <= synop_lat_all(i) .and. pixel%lat_n > synop_lat_all(i))
+ idx_lon = pack([(isite, isite=1, pixel%nlon)], pixel%lon_w <= synop_lon_all(i) .and. pixel%lon_e > synop_lon_all(i))
+
+ iloc_synop(1,i) = idx_lat(1)
+ iloc_synop(2,i) = idx_lon(1)
+ ELSE
+ iloc_synop(1,i) = -1
+ iloc_synop(2,i) = -1
+ ENDIF
+ ENDDO
+ ENDIF
+ CALL mpi_bcast(iloc_synop, 2*nsite, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+!#############################################################################
+! Assess the patch id of pixel that cover each observation at each rank
+!#############################################################################
+ IF (p_is_compute) THEN
+ ! count the number of site that located in pixels of each rank
+ counter_rank_nsite = 0
+ DO i = 1, nsite
+ IF (iloc_synop(1, i) > 0) THEN
+ IF (counter(iloc_synop(1, i)) > 0) THEN
+ IF (any(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) THEN
+ counter_rank_nsite = counter_rank_nsite + 1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+
+ ! assess patch/site id of sites located at each rank
+ IF (counter_rank_nsite > 0) THEN
+ allocate (ip_rank (2, counter_rank_nsite))
+ counter_rank_nsite = 0
+ ip_rank(:,:) = -1
+
+ DO i = 1, nsite
+ IF (iloc_synop(1, i) > 0) THEN
+ IF (counter(iloc_synop(1, i)) > 0) THEN
+ IF (any(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))) THEN
+ numpxl = count(idx(iloc_synop(1, i))%ilon == iloc_synop(2, i))
+ IF (allocated (pos)) deallocate (pos)
+ allocate (pos(numpxl))
+
+ pos = pack([(ilon, ilon=1, counter(iloc_synop(1, i)))], (idx(iloc_synop(1, i))%ilon == iloc_synop(2, i)))
+ counter_rank_nsite = counter_rank_nsite + 1
+ ip_rank(1, counter_rank_nsite) = i
+ ip_rank(2, counter_rank_nsite) = idx(iloc_synop(1, i))%ipatch(pos(1))
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ! send the number of site and their patch id to root
+#ifdef USEMPI
+ mesg = (/p_iam_glb, counter_rank_nsite/)
+ CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (counter_rank_nsite > 0) THEN
+ CALL mpi_send(ip_rank, 2*counter_rank_nsite, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+#endif
+
+ ! deallocate
+ IF (allocated (counter)) deallocate (counter)
+ DO i = 1, pixel%nlat
+ IF (allocated(idx(i)%ilon)) deallocate (idx(i)%ilon)
+ IF (allocated(idx(i)%ipatch)) deallocate (idx(i)%ipatch)
+ ENDDO
+ IF (allocated (idx)) deallocate (idx)
+ IF (allocated (iloc_synop)) deallocate (iloc_synop)
+ IF (allocated (ip_rank)) deallocate (ip_rank)
+ ENDIF
+
+!#############################################################################
+! Generate look-up-table (contains the rank/patch id of each site) at root
+!#############################################################################
+ IF (p_is_root) THEN
+ allocate (synop_lut (2, nsite))
+ synop_lut(:,:) = -1
+
+#ifdef USEMPI
+ DO iwork = 0, p_np_compute-1
+ CALL mpi_recv(mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ isrc = mesg(1)
+ ndata = mesg(2)
+
+ IF (ndata > 0) THEN
+ allocate (temp(2, ndata))
+ CALL mpi_recv(temp, 2*ndata, MPI_INTEGER, isrc, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ DO i = 1, ndata
+ synop_lut(1, temp(1,i)) = isrc
+ synop_lut(2, temp(1,i)) = temp(2,i)
+ ENDDO
+
+ deallocate(temp)
+ ENDIF
+ ENDDO
+#endif
+ ENDIF
+ ENDIF
+#endif
+
+ END SUBROUTINE init_DA_SM
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE run_DA_SM(idate, deltim)
+
+!-----------------------------------------------------------------------------
+ USE MOD_Spmd_task
+ USE MOD_TimeManager
+ USE MOD_NetCDFBlock
+ USE MOD_Mesh
+ USE MOD_LandElm
+ USE MOD_LandPatch
+ USE MOD_Vars_Global
+ USE MOD_Vars_1DFluxes
+ USE MOD_Vars_1DForcing
+ USE MOD_Vars_TimeVariables
+ USE MOD_Vars_TimeInvariants
+ USE MOD_DA_Vars_TimeVariables
+ USE MOD_RangeCheck
+ USE MOD_UserDefFun
+ USE MOD_DA_EnKF
+ USE MOD_Const_Physical, only: denice, denh2o
+ IMPLICIT NONE
+
+!------------------------ Dummy Arguments ------------------------------------
+ integer, intent(in) :: idate(3)
+ real(r8), intent(in) :: deltim
+
+!------------------------ Local Variables ------------------------------------
+ real(r8) :: lat_p_n, lat_p_s, lon_p_w, lon_p_e
+ real(r8) :: lat_p, lon_p
+ real(r8) :: es, e
+ integer :: ib, jb, il, jl, ip, iens, iobs, np, i, n, ndata, isrc, j
+ integer :: sdate(3), smesg(2), rmesg(2)
+ integer, allocatable :: iloc(:)
+ integer, allocatable :: itemp(:)
+ real(r8), allocatable :: dtemp(:,:)
+ integer :: iwork, mesg(2)
+
+!-----------------------------------------------------------------------------
+
+!#############################################################################
+! Identify if there are observations at this time step
+!#############################################################################
+ ! Do not perform DA, only calcuate predict BRT for diagnostic
+ IF (DEF_DA_ENS_NUM == 1) THEN
+ has_smap_file = .false.
+ has_fy3d_file = .false.
+ has_synop_file = .false.
+ ELSE
+ ! covert local time to UTC for single point
+ sdate = idate
+ CALL adj2begin(sdate)
+#ifdef SinglePoint
+ IF (.not. DEF_simulation_time%greenwich) THEN
+ CALL localtime2gmt(sdate)
+ ENDIF
+#endif
+ ! calculate year/month/day/hour of current step
+ CALL julian2monthday(sdate(1), sdate(2), month, mday)
+ hour = int(sdate(3)/3600)
+
+ ! whether has file at target day
+ write (yearstr, '(I4.4)') sdate(1)
+ write (monthstr, '(I2.2)') month
+ write (daystr, '(I2.2)') mday
+ write (hourstr, '(I2.2)') hour
+
+ ! check SMAP brightness temperature observations
+ IF (DEF_DA_SM_SMAP) THEN
+ ! file path of SMAP
+ file_smap = trim(DEF_DA_obsdir)//'/SMAP_L1C_D/'//'/SMAP_L1C_TB_'// &
+ trim(yearstr)//'_'//trim(monthstr)//'_'//trim(daystr)//'_'//trim(hourstr)//'.nc'
+ inquire (file=trim(file_smap), exist=has_smap_file)
+
+ ! whether have obs at this time interval
+ has_smap_obs = .false.
+ IF (has_smap_file) THEN
+ CALL ncio_read_bcast_serial(file_smap, 'time', smap_time)
+ num_smap_obs = size(smap_time)
+ idate_b = sdate(3)
+ idate_e = sdate(3) + deltim
+ allocate (dt_b_smap(num_smap_obs))
+ allocate (dt_e_smap(num_smap_obs))
+ dt_b_smap = smap_time - idate_b
+ dt_e_smap = smap_time - idate_e
+ IF (any(dt_b_smap >= 0 .and. dt_e_smap <= 0)) has_smap_obs = .true.
+ deallocate (dt_b_smap)
+ deallocate (dt_e_smap)
+ ELSE
+ has_smap_obs = .false.
+ ENDIF
+
+ ! check if there are obs in simulation domain
+ IF (has_smap_obs) THEN
+ CALL ncio_read_bcast_serial(file_smap, 'lat', smap_lat)
+ CALL ncio_read_bcast_serial(file_smap, 'lon', smap_lon)
+
+ num_smap_obs_domain = count(smap_lat(:) < DEF_domain%edgen .and. smap_lat(:) > DEF_domain%edges .and. &
+ smap_lon(:) > DEF_domain%edgew .and. smap_lon(:) < DEF_domain%edgee)
+ IF (num_smap_obs_domain == 0) has_smap_obs = .false.
+ ENDIF
+ ELSE
+ has_smap_file = .false.
+ has_smap_obs = .false.
+ ENDIF
+
+ ! check FY brightness temperature observations
+ IF (DEF_DA_SM_FY) THEN
+ ! file path of FY3D
+ file_fy3d = trim(DEF_DA_obsdir)//'/FY3D_L1/'//'/FY3D_L1_TB_'// &
+ trim(yearstr)//'_'//trim(monthstr)//'_'//trim(daystr)//'_'//trim(hourstr)//'.nc'
+ inquire (file=trim(file_fy3d), exist=has_fy3d_file)
+
+ ! whether have obs at this time interval
+ has_fy3d_obs = .false.
+ IF (has_fy3d_file) THEN
+ CALL ncio_read_bcast_serial(file_fy3d, 'time', fy3d_time)
+ num_fy3d_obs = size(fy3d_time)
+ idate_b = sdate(3)
+ idate_e = sdate(3) + deltim
+ allocate (dt_b_fy3d(num_fy3d_obs))
+ allocate (dt_e_fy3d(num_fy3d_obs))
+ dt_b_fy3d = fy3d_time - idate_b
+ dt_e_fy3d = fy3d_time - idate_e
+ IF (any(dt_b_fy3d >= 0 .and. dt_e_fy3d <= 0)) has_fy3d_obs = .true.
+ deallocate (dt_b_fy3d)
+ deallocate (dt_e_fy3d)
+ ELSE
+ has_fy3d_obs = .false.
+ ENDIF
+
+ ! check if there are obs in simulation domain
+ IF (has_fy3d_obs) THEN
+ CALL ncio_read_bcast_serial(file_fy3d, 'lat', fy3d_lat)
+ CALL ncio_read_bcast_serial(file_fy3d, 'lon', fy3d_lon)
+
+ num_fy3d_obs_domain = count(fy3d_lat(:) < DEF_domain%edgen .and. fy3d_lat(:) > DEF_domain%edges .and. &
+ fy3d_lon(:) > DEF_domain%edgew .and. fy3d_lon(:) < DEF_domain%edgee)
+ IF (num_fy3d_obs_domain == 0) has_fy3d_obs = .false.
+ ENDIF
+ ELSE
+ has_fy3d_file = .false.
+ has_fy3d_obs = .false.
+ ENDIF
+
+ ! check SYNOP 2m observations
+ IF (DEF_DA_SM_SYNOP) THEN
+ file_synop = trim(DEF_DA_obsdir)//'/SYNOP/'//'/SYNOP_'// &
+ trim(yearstr)//'_'//trim(monthstr)//'_'//trim(daystr)//'_'//trim(hourstr)//'.nc'
+ inquire (file=trim(file_synop), exist=has_synop_file)
+
+ ! whether have obs at this time interval
+ has_synop_obs = .false.
+ IF (has_synop_file) THEN
+ CALL ncio_read_bcast_serial(file_synop, 'time', synop_time)
+ num_synop_obs = size(synop_time)
+ idate_b = sdate(3)
+ idate_e = sdate(3) + deltim
+ allocate (dt_b_synop(num_synop_obs))
+ allocate (dt_e_synop(num_synop_obs))
+ dt_b_synop = synop_time - idate_b
+ dt_e_synop = synop_time - idate_e
+ IF (any(dt_b_synop >= 0 .and. dt_e_synop <= 0)) has_synop_obs = .true.
+ deallocate (dt_b_synop)
+ deallocate (dt_e_synop)
+ ELSE
+ has_synop_obs = .false.
+ ENDIF
+
+ ! check if there are obs in simulation domain
+ IF (has_synop_obs) THEN
+ CALL ncio_read_bcast_serial(file_synop, 'lat', synop_lat)
+ CALL ncio_read_bcast_serial(file_synop, 'lon', synop_lon)
+
+ num_synop_obs_domain = count(synop_lat(:) < DEF_domain%edgen .and. synop_lat(:) > DEF_domain%edges .and. &
+ synop_lon(:) > DEF_domain%edgew .and. synop_lon(:) < DEF_domain%edgee)
+ IF (num_synop_obs_domain == 0) has_synop_obs = .false.
+ ENDIF
+ ELSE
+ has_synop_file = .false.
+ has_synop_obs = .false.
+ ENDIF
+ ENDIF
+
+ ! print info of observations
+ IF (p_is_root) THEN
+ IF (has_smap_obs) THEN
+ print *, '[CoLM-DA] Have SMAP observations:', trim(file_smap)
+ ELSE
+ print *, '[CoLM-DA] No SMAP observations.'
+ ENDIF
+ IF (has_fy3d_obs) THEN
+ print *, '[CoLM-DA] Have FY3D observations:', trim(file_fy3d)
+ ELSE
+ print *, '[CoLM-DA] No FY3D observations.'
+ ENDIF
+ IF (has_synop_obs) THEN
+ print *, '[CoLM-DA] Have SYNOP observations:', trim(file_synop)
+ ELSE
+ print *, '[CoLM-DA] No SYNOP observations.'
+ ENDIF
+ ENDIF
+
+!#############################################################################
+! Allocate memory for variables
+!#############################################################################
+ IF (DEF_DA_SM_SMAP) THEN
+ ! allocate memory for ensemble predicted observations at patch (for DA or no DA)
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ IF (allocated(pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens)
+ IF (allocated(pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens)
+ allocate (pred_smap_tb_h_pset_ens(DEF_DA_ENS_NUM, numpatch))
+ allocate (pred_smap_tb_v_pset_ens(DEF_DA_ENS_NUM, numpatch))
+ ENDIF
+ ENDIF
+
+ ! allocate memory for ensemble predicted observations in vectors (only for DA)
+#ifndef SinglePoint
+ IF (has_smap_obs) THEN
+ IF (allocated(pred_smap_tb_h_ogrid_ens)) deallocate (pred_smap_tb_h_ogrid_ens)
+ IF (allocated(pred_smap_tb_v_ogrid_ens)) deallocate (pred_smap_tb_v_ogrid_ens)
+ allocate (pred_smap_tb_h_ogrid_ens(num_smap_obs, DEF_DA_ENS_NUM))
+ allocate (pred_smap_tb_v_ogrid_ens(num_smap_obs, DEF_DA_ENS_NUM))
+ ENDIF
+#endif
+ ENDIF
+
+ IF (DEF_DA_SM_FY) THEN
+ ! allocate memory for ensemble predicted observations at patch (for DA or no DA)
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ IF (allocated(pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens)
+ IF (allocated(pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens)
+ allocate (pred_fy3d_tb_h_pset_ens(DEF_DA_ENS_NUM, numpatch))
+ allocate (pred_fy3d_tb_v_pset_ens(DEF_DA_ENS_NUM, numpatch))
+ ENDIF
+ ENDIF
+
+ ! allocate memory for ensemble predicted observations in vectors (only for DA)
+#ifndef SinglePoint
+ IF (has_fy3d_obs) THEN
+ IF (allocated(pred_fy3d_tb_h_ogrid_ens)) deallocate (pred_fy3d_tb_h_ogrid_ens)
+ IF (allocated(pred_fy3d_tb_v_ogrid_ens)) deallocate (pred_fy3d_tb_v_ogrid_ens)
+ allocate (pred_fy3d_tb_h_ogrid_ens(num_fy3d_obs, DEF_DA_ENS_NUM))
+ allocate (pred_fy3d_tb_v_ogrid_ens(num_fy3d_obs, DEF_DA_ENS_NUM))
+ ENDIF
+#endif
+ ENDIF
+
+ IF (DEF_DA_SM_SYNOP) THEN
+ ! allocate memory
+ IF (has_synop_obs) THEN
+ IF (allocated(synop_idx)) deallocate (synop_idx)
+ IF (allocated(qref_ens_o)) deallocate (qref_ens_o)
+ IF (allocated(tref_ens_o)) deallocate (tref_ens_o)
+ allocate (synop_idx (2, num_synop_obs))
+ allocate (qref_ens_o (num_synop_obs, DEF_DA_ENS_NUM))
+ allocate (tref_ens_o (num_synop_obs, DEF_DA_ENS_NUM))
+ ENDIF
+ ENDIF
+
+!#############################################################################
+! Calculate predicted observations using observation operator
+!#############################################################################
+ ! forward model (for no DA)
+ IF (p_is_compute) THEN
+ ! SMAP forward model
+ DO np = 1, numpatch
+ lat_p = patchlatr(np)*180/pi
+ lon_p = patchlonr(np)*180/pi
+ CALL forward(&
+ patchtype(np), patchclass(np), dz_sno(:,np), &
+ forc_topo(np), htop(np), &
+ tref(np), t_soisno(:,np), tleaf(np), &
+ wliq_soisno(:,np), wice_soisno(:,np), h2osoi(:,np), &
+ snowdp(np), lai(np), sai(np), &
+ wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), &
+ smap_theta, smap_fghz, &
+ t_brt_smap(1,np), t_brt_smap(2,np))
+ ENDDO
+
+ ! FY3D forward model
+ DO np = 1, numpatch
+ CALL forward(&
+ patchtype(np), patchclass(np), dz_sno(:,np), &
+ forc_topo(np), htop(np), &
+ tref(np), t_soisno(:,np), tleaf(np), &
+ wliq_soisno(:,np), wice_soisno(:,np), h2osoi(:,np), &
+ snowdp(np), lai(np), sai(np), &
+ wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), &
+ fy3d_theta, fy3d_fghz, &
+ t_brt_fy3d(1,np), t_brt_fy3d(2,np))
+ ENDDO
+ ENDIF
+
+ ! forward model for ensemble DA
+ IF (p_is_compute) THEN
+ IF (DEF_DA_SM_SMAP) THEN
+ IF (DEF_DA_ENS_NUM > 1) THEN
+ DO iens = 1, DEF_DA_ENS_NUM
+ DO np = 1, numpatch
+ CALL forward(&
+ patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), &
+ forc_topo(np), htop(np), &
+ tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), &
+ wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), &
+ snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), &
+ wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), &
+ smap_theta, smap_fghz, &
+ pred_smap_tb_h_pset_ens(iens, np), pred_smap_tb_v_pset_ens(iens, np))
+ ENDDO
+ ENDDO
+ t_brt_smap_ens(1,:,:) = pred_smap_tb_h_pset_ens
+ t_brt_smap_ens(2,:,:) = pred_smap_tb_v_pset_ens
+ ENDIF
+ ENDIF
+
+ IF (DEF_DA_SM_FY) THEN
+ IF (DEF_DA_ENS_NUM > 1) THEN
+ DO iens = 1, DEF_DA_ENS_NUM
+ DO np = 1, numpatch
+ CALL forward(&
+ patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), &
+ forc_topo(np), htop(np), &
+ tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), &
+ wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), &
+ snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), &
+ wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), &
+ fy3d_theta, fy3d_fghz, &
+ pred_fy3d_tb_h_pset_ens(iens, np), pred_fy3d_tb_v_pset_ens(iens, np))
+ ENDDO
+ ENDDO
+ t_brt_fy3d_ens(1,:,:) = pred_fy3d_tb_h_pset_ens
+ t_brt_fy3d_ens(2,:,:) = pred_fy3d_tb_v_pset_ens
+ ENDIF
+ ENDIF
+
+ IF (DEF_DA_SM_SYNOP) THEN
+ IF (DEF_DA_ENS_NUM > 1) THEN
+ ! calculate relative humidity from specific humidity
+ DO ip = 1, numpatch
+ DO iens = 1, DEF_DA_ENS_NUM
+ es = 6.112 * exp((17.67 * (tref_ens(iens, ip) - 273.15))/ (tref_ens(iens, ip) - 273.15 + 243.5))
+ e = (qref_ens(iens, ip) * forc_psrf(ip) / 100) / (0.378 * qref_ens(iens, ip) + 0.622)
+ rhref_ens(iens, ip) = max(min(1.0d0, e / es), 0.0d0)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+
+!#############################################################################
+! Reading observations data
+!#############################################################################
+ ! read observations data (only for DA)
+ IF (has_smap_obs) THEN
+ CALL ncio_read_bcast_serial(file_smap, 'ii' , smap_ii )
+ CALL ncio_read_bcast_serial(file_smap, 'jj' , smap_jj )
+ CALL ncio_read_bcast_serial(file_smap, 'tb_h', smap_tb_h)
+ CALL ncio_read_bcast_serial(file_smap, 'tb_v', smap_tb_v)
+ CALL ncio_read_bcast_serial(file_smap, 'tb_h_colm_mean', pred_smap_tb_h_mean)
+ CALL ncio_read_bcast_serial(file_smap, 'tb_v_colm_mean', pred_smap_tb_v_mean)
+ CALL ncio_read_bcast_serial(file_smap, 'tb_h_obs_mean', smap_tb_h_mean)
+ CALL ncio_read_bcast_serial(file_smap, 'tb_v_obs_mean', smap_tb_v_mean)
+ ENDIF
+ IF (has_fy3d_obs) THEN
+ CALL ncio_read_bcast_serial(file_fy3d, 'ii' , fy3d_ii )
+ CALL ncio_read_bcast_serial(file_fy3d, 'jj' , fy3d_jj )
+ CALL ncio_read_bcast_serial(file_fy3d, 'tb_h', fy3d_tb_h)
+ CALL ncio_read_bcast_serial(file_fy3d, 'tb_v', fy3d_tb_v)
+ CALL ncio_read_bcast_serial(file_fy3d, 'tb_h_colm_mean', pred_fy3d_tb_h_mean)
+ CALL ncio_read_bcast_serial(file_fy3d, 'tb_v_colm_mean', pred_fy3d_tb_v_mean)
+ CALL ncio_read_bcast_serial(file_fy3d, 'tb_h_obs_mean', fy3d_tb_h_mean)
+ CALL ncio_read_bcast_serial(file_fy3d, 'tb_v_obs_mean', fy3d_tb_v_mean)
+ ENDIF
+ IF (has_synop_obs) THEN
+ CALL ncio_read_bcast_serial(file_synop, 'lat', synop_lat )
+ CALL ncio_read_bcast_serial(file_synop, 'lon', synop_lon )
+ CALL ncio_read_bcast_serial(file_synop, 'id', synop_id )
+ CALL ncio_read_bcast_serial(file_synop, 'tref', synop_tref)
+ CALL ncio_read_bcast_serial(file_synop, 'qref', synop_qref)
+ ENDIF
+
+!#############################################################################
+! Cropping predicted observations at observations space
+!#############################################################################
+#ifndef SinglePoint
+ IF (DEF_DA_SM_SMAP) THEN
+ IF (has_smap_obs) THEN
+ ! prepare filter for land patches
+ allocate (filter(numpatch))
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ filter(:) = patchtype <= 2
+ ENDIF
+ ENDIF
+
+ ! calculate area of each patch across world grid
+ IF (p_is_active) CALL allocate_block_data(grid_smap, area_smap_wgrid)
+ CALL mg2p_smap%get_sumarea(area_smap_wgrid, filter)
+
+ ! mapping predicted observations from patch to world grid
+ IF (p_is_active) THEN
+ CALL allocate_block_data(grid_smap, pred_smap_tb_h_wgrid_ens, DEF_DA_ENS_NUM)
+ CALL allocate_block_data(grid_smap, pred_smap_tb_v_wgrid_ens, DEF_DA_ENS_NUM)
+ ENDIF
+ CALL mg2p_smap%pset2grid(pred_smap_tb_h_pset_ens, pred_smap_tb_h_wgrid_ens, spv=spval, msk=filter)
+ CALL mg2p_smap%pset2grid(pred_smap_tb_v_pset_ens, pred_smap_tb_v_wgrid_ens, spv=spval, msk=filter)
+ deallocate (filter)
+
+ ! crop the predicted observations
+ IF (p_is_active) THEN
+ allocate (iloc(num_smap_obs))
+ pred_smap_tb_h_ogrid_ens = -9999.0
+ pred_smap_tb_v_ogrid_ens = -9999.0
+
+ ! crop obs from world grid to all obs grids
+ ndata = 0
+ DO i = 1, num_smap_obs
+ ib = grid_smap%xblk(smap_jj(i))
+ jb = grid_smap%yblk(smap_ii(i))
+ il = grid_smap%xloc(smap_jj(i))
+ jl = grid_smap%yloc(smap_ii(i))
+ IF (ib /= 0 .and. jb /= 0) THEN
+ IF (gblock%pio(ib, jb) == p_iam_glb) THEN
+ area_smap_wgrid_obs = area_smap_wgrid%blk(ib, jb)%val(il, jl)
+ IF (area_smap_wgrid_obs /= 0) THEN
+#ifdef USEMPI
+ ndata = ndata + 1
+ iloc(ndata) = i
+ pred_smap_tb_h_ogrid_ens(ndata, :) = (pred_smap_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs
+ pred_smap_tb_v_ogrid_ens(ndata, :) = (pred_smap_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs
+#else
+ pred_smap_tb_h_ogrid_ens(i, :) = (pred_smap_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs
+ pred_smap_tb_v_ogrid_ens(i, :) = (pred_smap_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_smap_wgrid_obs
+#endif
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+
+ ! send data from io to roots
+#ifdef USEMPI
+ smesg = (/p_iam_glb, ndata/)
+ CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (ndata > 0) THEN
+ CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+
+ allocate (dtemp(ndata, DEF_DA_ENS_NUM))
+ dtemp = pred_smap_tb_h_ogrid_ens(1:ndata, :)
+ CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ dtemp = pred_smap_tb_v_ogrid_ens(1:ndata, :)
+ CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data + 1, p_comm_glb, p_err)
+ deallocate (dtemp)
+ ENDIF
+#endif
+ deallocate (iloc)
+ deallocate (pred_smap_tb_h_wgrid_ens%blk, pred_smap_tb_v_wgrid_ens%blk)
+ ENDIF
+
+ ! broadcast from root to all ranks
+#ifdef USEMPI
+ IF (p_is_root) THEN
+ pred_smap_tb_h_ogrid_ens = -9999.0
+ pred_smap_tb_v_ogrid_ens = -9999.0
+ DO ip = 0, p_np_active - 1
+ CALL mpi_recv(rmesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ ndata = rmesg(2)
+ IF (ndata > 0) THEN
+ allocate (itemp(ndata))
+ allocate (dtemp(ndata, DEF_DA_ENS_NUM))
+
+ isrc = rmesg(1)
+ CALL mpi_recv(itemp, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ pred_smap_tb_h_ogrid_ens(itemp, :) = dtemp
+ CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data + 1, p_comm_glb, p_stat, p_err)
+ pred_smap_tb_v_ogrid_ens(itemp, :) = dtemp
+
+ deallocate (itemp)
+ deallocate (dtemp)
+ ENDIF
+ ENDDO
+ ENDIF
+ CALL mpi_bcast(pred_smap_tb_h_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+ CALL mpi_bcast(pred_smap_tb_v_ogrid_ens, num_smap_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+#endif
+ ENDIF
+ ENDIF
+
+ IF (DEF_DA_SM_FY) THEN
+ IF (has_fy3d_obs) THEN
+ ! prepare filter for land patches
+ allocate (filter(numpatch))
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ filter(:) = patchtype <= 2
+ ENDIF
+ ENDIF
+
+ ! calculate area of each patch across world grid
+ IF (p_is_active) CALL allocate_block_data(grid_fy3d, area_fy3d_wgrid)
+ CALL mg2p_fy3d%get_sumarea(area_fy3d_wgrid, filter)
+
+ ! mapping predicted observations from patch to world grid
+ IF (p_is_active) THEN
+ CALL allocate_block_data(grid_fy3d, pred_fy3d_tb_h_wgrid_ens, DEF_DA_ENS_NUM)
+ CALL allocate_block_data(grid_fy3d, pred_fy3d_tb_v_wgrid_ens, DEF_DA_ENS_NUM)
+ ENDIF
+ CALL mg2p_fy3d%pset2grid(pred_fy3d_tb_h_pset_ens, pred_fy3d_tb_h_wgrid_ens, spv=spval, msk=filter)
+ CALL mg2p_fy3d%pset2grid(pred_fy3d_tb_v_pset_ens, pred_fy3d_tb_v_wgrid_ens, spv=spval, msk=filter)
+ deallocate (filter)
+
+ ! crop the predicted observations
+ IF (p_is_active) THEN
+ allocate (iloc(num_fy3d_obs))
+ pred_fy3d_tb_h_ogrid_ens = -9999.0
+ pred_fy3d_tb_v_ogrid_ens = -9999.0
+
+ ! crop obs from world grid to all obs grids
+ ndata = 0
+ DO i = 1, num_fy3d_obs
+ ib = grid_fy3d%xblk(fy3d_jj(i))
+ jb = grid_fy3d%yblk(fy3d_ii(i))
+ il = grid_fy3d%xloc(fy3d_jj(i))
+ jl = grid_fy3d%yloc(fy3d_ii(i))
+ IF (ib /= 0 .and. jb /= 0) THEN
+ IF (gblock%pio(ib, jb) == p_iam_glb) THEN
+ area_fy3d_wgrid_obs = area_fy3d_wgrid%blk(ib, jb)%val(il, jl)
+ IF (area_fy3d_wgrid_obs /= 0) THEN
+#ifdef USEMPI
+ ndata = ndata + 1
+ iloc(ndata) = i
+ pred_fy3d_tb_h_ogrid_ens(ndata, :) = (pred_fy3d_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs
+ pred_fy3d_tb_v_ogrid_ens(ndata, :) = (pred_fy3d_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs
+#else
+ pred_fy3d_tb_h_ogrid_ens(i, :) = (pred_fy3d_tb_h_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs
+ pred_fy3d_tb_v_ogrid_ens(i, :) = (pred_fy3d_tb_v_wgrid_ens%blk(ib, jb)%val(:, il, jl))/area_fy3d_wgrid_obs
+#endif
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+
+ ! send data from io to roots
+#ifdef USEMPI
+ smesg = (/p_iam_glb, ndata/)
+ CALL mpi_send(smesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (ndata > 0) THEN
+ CALL mpi_send(iloc(1:ndata), ndata, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+
+ allocate (dtemp(ndata, DEF_DA_ENS_NUM))
+ dtemp = pred_fy3d_tb_h_ogrid_ens(1:ndata, :)
+ CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ dtemp = pred_fy3d_tb_v_ogrid_ens(1:ndata, :)
+ CALL mpi_send(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, mpi_tag_data + 1, p_comm_glb, p_err)
+ deallocate (dtemp)
+ ENDIF
+#endif
+ deallocate (iloc)
+ deallocate (pred_fy3d_tb_h_wgrid_ens%blk, pred_fy3d_tb_v_wgrid_ens%blk)
+ ENDIF
+
+ ! broadcast from root to all ranks
+#ifdef USEMPI
+ IF (p_is_root) THEN
+ pred_fy3d_tb_h_ogrid_ens = -9999.0
+ pred_fy3d_tb_v_ogrid_ens = -9999.0
+ DO ip = 0, p_np_active - 1
+ CALL mpi_recv(rmesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ ndata = rmesg(2)
+ IF (ndata > 0) THEN
+ allocate (itemp(ndata))
+ allocate (dtemp(ndata, DEF_DA_ENS_NUM))
+
+ isrc = rmesg(1)
+ CALL mpi_recv(itemp, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ pred_fy3d_tb_h_ogrid_ens(itemp, :) = dtemp
+ CALL mpi_recv(dtemp, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data + 1, p_comm_glb, p_stat, p_err)
+ pred_fy3d_tb_v_ogrid_ens(itemp, :) = dtemp
+
+ deallocate (itemp)
+ deallocate (dtemp)
+ ENDIF
+ ENDDO
+ ENDIF
+ CALL mpi_bcast(pred_fy3d_tb_h_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+ CALL mpi_bcast(pred_fy3d_tb_v_ogrid_ens, num_fy3d_obs*DEF_DA_ENS_NUM, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+#endif
+ ENDIF
+ ENDIF
+
+ IF (DEF_DA_SM_SYNOP) THEN
+ ! crop corresponding index (rank id and patch id) of each observation
+ IF (has_synop_obs) THEN
+ synop_idx(:,:) = -1
+ IF (p_is_root) THEN
+ synop_idx = synop_lut(:, synop_id)
+ ENDIF
+ CALL mpi_bcast(synop_idx, 2*num_synop_obs, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ ENDIF
+
+ ! recount the number of observations at each rank
+ IF (has_synop_obs) THEN
+ IF (p_is_compute) THEN
+ counter_rank_nsite = 0
+ DO i = 1, num_synop_obs
+ IF (synop_idx(1, i) == p_iam_glb) THEN
+ counter_rank_nsite = counter_rank_nsite + 1
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ ! allocate memory for rank
+ IF (has_synop_obs) THEN
+ IF (p_is_compute) THEN
+ IF (counter_rank_nsite > 0) THEN
+ IF (allocated(tref_ens_rank)) deallocate (tref_ens_rank)
+ IF (allocated(qref_ens_rank)) deallocate (qref_ens_rank)
+ IF (allocated(site_id_rank)) deallocate (site_id_rank)
+ allocate (tref_ens_rank (counter_rank_nsite, DEF_DA_ENS_NUM))
+ allocate (qref_ens_rank (counter_rank_nsite, DEF_DA_ENS_NUM))
+ allocate (site_id_rank (counter_rank_nsite))
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ! crop observations at each rank according index & send to root
+ IF (has_synop_obs) THEN
+ IF (p_is_compute) THEN
+ counter_rank_nsite = 0
+ DO i = 1, num_synop_obs
+ IF (synop_idx(1, i) == p_iam_glb) THEN
+ counter_rank_nsite = counter_rank_nsite + 1
+ tref_ens_rank(counter_rank_nsite,:) = tref_ens(:, synop_idx(2, i))
+ qref_ens_rank(counter_rank_nsite,:) = rhref_ens(:, synop_idx(2, i))
+ site_id_rank (counter_rank_nsite) = i
+ ENDIF
+ ENDDO
+
+#ifdef USEMPI
+ ! send the number of site and their patch id to root
+ mesg = (/p_iam_glb, counter_rank_nsite/)
+ CALL mpi_send(mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (counter_rank_nsite > 0) THEN
+ CALL mpi_send(tref_ens_rank, DEF_DA_ENS_NUM*counter_rank_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ CALL mpi_send(qref_ens_rank, DEF_DA_ENS_NUM*counter_rank_nsite, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ CALL mpi_send(site_id_rank, counter_rank_nsite, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+#endif
+
+ IF (allocated(tref_ens_rank)) deallocate (tref_ens_rank)
+ IF (allocated(qref_ens_rank)) deallocate (qref_ens_rank)
+ IF (allocated(site_id_rank)) deallocate (site_id_rank)
+ ENDIF
+ ENDIF
+
+ ! concatenate all predicted observations at root & broadcast to all ranks
+ IF (has_synop_obs) THEN
+ qref_ens_o = spval
+ tref_ens_o = spval
+ IF (p_is_root) THEN
+#ifdef USEMPI
+ DO iwork = 0, p_np_compute-1
+ CALL mpi_recv(mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ isrc = mesg(1)
+ ndata = mesg(2)
+
+ IF (ndata > 0) THEN
+ allocate(tref_ens_rank(ndata, DEF_DA_ENS_NUM))
+ allocate(qref_ens_rank(ndata, DEF_DA_ENS_NUM))
+ allocate(site_id_rank (ndata))
+
+ CALL mpi_recv(tref_ens_rank, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv(qref_ens_rank, ndata*DEF_DA_ENS_NUM, MPI_REAL8, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv(site_id_rank, ndata, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ qref_ens_o(site_id_rank,:) = qref_ens_rank
+ tref_ens_o(site_id_rank,:) = tref_ens_rank
+ ENDIF
+
+ IF (allocated(tref_ens_rank)) deallocate(tref_ens_rank)
+ IF (allocated(qref_ens_rank)) deallocate(qref_ens_rank)
+ IF (allocated(site_id_rank)) deallocate(site_id_rank)
+ ENDDO
+#endif
+ ENDIF
+ CALL mpi_bcast(qref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+ CALL mpi_bcast(tref_ens_o, DEF_DA_ENS_NUM*num_synop_obs, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+ ENDIF
+ ENDIF
+#endif
+
+!#############################################################################
+! Run data assimilation (for only DA)
+!#############################################################################
+ has_DA = .false.
+ IF (has_smap_obs .or. has_fy3d_obs .or. has_synop_obs) THEN
+ ! for grid data assimilation
+ IF (p_is_compute) THEN
+ DO np = 1, numpatch
+
+!#############################################################################
+! 1. Find observations around each patch
+!#############################################################################
+ ! regions info around target patch
+ lat_p_n = patchlatr(np)*180/pi + dres
+ lat_p_s = patchlatr(np)*180/pi - dres
+ lon_p_w = patchlonr(np)*180/pi - dres
+ lon_p_e = patchlonr(np)*180/pi + dres
+
+ ! find observations around each patch
+ num_obs_p = 0
+ num_smap_p = 0
+ num_fy3d_p = 0
+ num_synop_p = 0
+ IF (DEF_DA_SM_SMAP) THEN
+ IF (has_smap_obs) THEN
+ num_smap_p = count(smap_lat(:) < lat_p_n .and. smap_lat(:) > lat_p_s .and. &
+ smap_lon(:) > lon_p_w .and. smap_lon(:) < lon_p_e .and. &
+ smap_time(:) - idate_b >= 0 .and. smap_time(:) - idate_e <= 0 .and. &
+ smap_tb_h_mean(:) > 0 .and. pred_smap_tb_h_mean(:) > 0)
+ ENDIF
+ ENDIF
+ IF (DEF_DA_SM_FY) THEN
+ IF (has_fy3d_obs) THEN
+ num_fy3d_p = count(fy3d_lat(:) < lat_p_n .and. fy3d_lat(:) > lat_p_s .and. &
+ fy3d_lon(:) > lon_p_w .and. fy3d_lon(:) < lon_p_e .and. &
+ fy3d_time(:) - idate_b >= 0 .and. fy3d_time(:) - idate_e <= 0 .and. &
+ fy3d_tb_h_mean(:) > 0 .and. pred_fy3d_tb_h_mean(:) > 0)
+ ENDIF
+ ENDIF
+ IF (DEF_DA_SM_SYNOP) THEN
+ IF (has_synop_obs) THEN
+ num_synop_p = count( &
+ synop_lat(:) < lat_p_n .and. synop_lat(:) > lat_p_s .and. &
+ synop_lon(:) > lon_p_w .and. synop_lon(:) < lon_p_e .and. &
+ synop_time(:) - idate_b >= 0 .and. synop_time(:) - idate_e <= 0 .and. &
+ tref_ens_o(:,1) > 0)
+ ENDIF
+ ENDIF
+ num_obs_p = num_smap_p + num_fy3d_p + 2*num_synop_p
+
+!#############################################################################
+! 2. Perform data assimilation
+!#############################################################################
+ IF (num_obs_p > 0) THEN
+ ! allocate memory for data assimilation
+ allocate (obs_err (num_obs_p ))
+ allocate (trans (DEF_DA_ENS_NUM,DEF_DA_ENS_NUM))
+ allocate (wliq_soi_ens (nl_soil, DEF_DA_ENS_NUM ))
+ allocate (wliq_soi_ens_da(nl_soil, DEF_DA_ENS_NUM ))
+ allocate (t_soi_ens (nl_soil, DEF_DA_ENS_NUM ))
+ allocate (t_soi_ens_da (nl_soil, DEF_DA_ENS_NUM ))
+ allocate (pred_obs_p_ens (num_obs_p, DEF_DA_ENS_NUM ))
+ allocate (obs_p (num_obs_p ))
+
+
+!#############################################################################
+! 2.1. Prepare observations around target patch for each observation dataset
+!#############################################################################
+ IF (num_smap_p > 0) THEN
+ ! allocate memory
+ allocate (index_smap_p (num_smap_p ))
+ allocate (smap_lat_p (num_smap_p ))
+ allocate (smap_lon_p (num_smap_p ))
+ allocate (smap_tb_h_p (num_smap_p ))
+ allocate (smap_tb_v_p (num_smap_p ))
+ allocate (pred_smap_tb_h_p_ens (num_smap_p, DEF_DA_ENS_NUM))
+ allocate (pred_smap_tb_v_p_ens (num_smap_p, DEF_DA_ENS_NUM))
+ allocate (smap_tb_h_mean_p (num_smap_p ))
+ allocate (smap_tb_v_mean_p (num_smap_p ))
+ allocate (pred_smap_tb_h_mean_p(num_smap_p ))
+ allocate (pred_smap_tb_v_mean_p(num_smap_p ))
+ allocate (smap_err (num_smap_p ))
+ allocate (d_smap_p (num_smap_p ))
+
+ ! index of observations around target patch
+ index_smap_p = (smap_lat(:) < lat_p_n .and. smap_lat(:) > lat_p_s .and. &
+ smap_lon(:) > lon_p_w .and. smap_lon(:) < lon_p_e .and. &
+ smap_time(:) - idate_b >= 0 .and. smap_time(:) - idate_e <= 0 .and. &
+ smap_tb_h_mean(:) > 0 .and. pred_smap_tb_h_mean(:) > 0)
+
+ ! crop observations around target patch
+ smap_lat_p = pack(smap_lat , index_smap_p)
+ smap_lon_p = pack(smap_lon , index_smap_p)
+ smap_tb_h_p = pack(smap_tb_h, index_smap_p)
+ smap_tb_v_p = pack(smap_tb_v, index_smap_p)
+
+ ! crop ensemble predicted observations around target patch
+ DO i = 1, DEF_DA_ENS_NUM
+ pred_smap_tb_h_p_ens(:, i) = pack(pred_smap_tb_h_ogrid_ens(:, i), index_smap_p)
+ pred_smap_tb_v_p_ens(:, i) = pack(pred_smap_tb_v_ogrid_ens(:, i), index_smap_p)
+ ENDDO
+
+ ! crop mean values around target patch
+ smap_tb_h_mean_p = pack(smap_tb_h_mean, index_smap_p)
+ smap_tb_v_mean_p = pack(smap_tb_v_mean, index_smap_p)
+ pred_smap_tb_h_mean_p = pack(pred_smap_tb_h_mean, index_smap_p)
+ pred_smap_tb_v_mean_p = pack(pred_smap_tb_v_mean, index_smap_p)
+
+ ! scaling
+ smap_tb_h_p = smap_tb_h_p - smap_tb_h_mean_p
+ smap_tb_v_p = smap_tb_v_p - smap_tb_v_mean_p
+ DO i = 1, DEF_DA_ENS_NUM
+ pred_smap_tb_h_p_ens(:, i) = pred_smap_tb_h_p_ens(:, i) - pred_smap_tb_h_mean_p
+ pred_smap_tb_v_p_ens(:, i) = pred_smap_tb_v_p_ens(:, i) - pred_smap_tb_v_mean_p
+ ENDDO
+
+ ! calculate distance between observation and patch center
+ d_smap_p = 2*6.3781e3*asin(sqrt(sin((smap_lat_p*pi/180 - patchlatr(np))/2.0)**2 + &
+ cos(smap_lat_p*pi/180)*cos(patchlatr(np))*sin((smap_lon_p*pi/180 - patchlonr(np))/2.0)**2))
+
+ ! calculate weighted observation error
+ smap_err = static_smap_err/(exp((-d_smap_p**2)/(2*loc_r**2)))
+ ENDIF
+
+ IF (num_fy3d_p > 0) THEN
+ ! allocate memory
+ allocate (index_fy3d_p (num_fy3d_p ))
+ allocate (fy3d_lat_p (num_fy3d_p ))
+ allocate (fy3d_lon_p (num_fy3d_p ))
+ allocate (fy3d_tb_h_p (num_fy3d_p ))
+ allocate (fy3d_tb_v_p (num_fy3d_p ))
+ allocate (pred_fy3d_tb_h_p_ens (num_fy3d_p, DEF_DA_ENS_NUM))
+ allocate (pred_fy3d_tb_v_p_ens (num_fy3d_p, DEF_DA_ENS_NUM))
+ allocate (fy3d_tb_h_mean_p (num_fy3d_p ))
+ allocate (fy3d_tb_v_mean_p (num_fy3d_p ))
+ allocate (pred_fy3d_tb_h_mean_p(num_fy3d_p ))
+ allocate (pred_fy3d_tb_v_mean_p(num_fy3d_p ))
+ allocate (fy3d_err (num_fy3d_p ))
+ allocate (d_fy3d_p (num_fy3d_p ))
+
+ ! index of observations around target patch
+ index_fy3d_p = (fy3d_lat(:) < lat_p_n .and. fy3d_lat(:) > lat_p_s .and. &
+ fy3d_lon(:) > lon_p_w .and. fy3d_lon(:) < lon_p_e .and. &
+ fy3d_time(:) - idate_b >= 0 .and. fy3d_time(:) - idate_e <= 0 .and. &
+ fy3d_tb_h_mean(:) > 0 .and. pred_fy3d_tb_h_mean(:) > 0)
+
+ ! crop observations around target patch
+ fy3d_lat_p = pack(fy3d_lat , index_fy3d_p)
+ fy3d_lon_p = pack(fy3d_lon , index_fy3d_p)
+ fy3d_tb_h_p = pack(fy3d_tb_h, index_fy3d_p)
+ fy3d_tb_v_p = pack(fy3d_tb_v, index_fy3d_p)
+
+ ! crop ensemble predicted observations around target patch
+ DO i = 1, DEF_DA_ENS_NUM
+ pred_fy3d_tb_h_p_ens(:, i) = pack(pred_fy3d_tb_h_ogrid_ens(:, i), index_fy3d_p)
+ pred_fy3d_tb_v_p_ens(:, i) = pack(pred_fy3d_tb_v_ogrid_ens(:, i), index_fy3d_p)
+ ENDDO
+
+ ! crop mean values around target patch
+ fy3d_tb_h_mean_p = pack(fy3d_tb_h_mean, index_fy3d_p)
+ fy3d_tb_v_mean_p = pack(fy3d_tb_v_mean, index_fy3d_p)
+ pred_fy3d_tb_h_mean_p = pack(pred_fy3d_tb_h_mean, index_fy3d_p)
+ pred_fy3d_tb_v_mean_p = pack(pred_fy3d_tb_v_mean, index_fy3d_p)
+
+ ! scaling
+ fy3d_tb_h_p = fy3d_tb_h_p - fy3d_tb_h_mean_p
+ fy3d_tb_v_p = fy3d_tb_v_p - fy3d_tb_v_mean_p
+ DO i = 1, DEF_DA_ENS_NUM
+ pred_fy3d_tb_h_p_ens(:, i) = pred_fy3d_tb_h_p_ens(:, i) - pred_fy3d_tb_h_mean_p
+ pred_fy3d_tb_v_p_ens(:, i) = pred_fy3d_tb_v_p_ens(:, i) - pred_fy3d_tb_v_mean_p
+ ENDDO
+
+ ! calculate distance between observation and patch center
+ d_fy3d_p = 2*6.3781e3*asin(sqrt(sin((fy3d_lat_p*pi/180 - patchlatr(np))/2.0)**2 + &
+ cos(fy3d_lat_p*pi/180)*cos(patchlatr(np))*sin((fy3d_lon_p*pi/180 - patchlonr(np))/2.0)**2))
+
+ ! calculate weighted observation error
+ fy3d_err = static_fy3d_err/(exp((-d_fy3d_p**2)/(2*loc_r**2)))
+ ENDIF
+
+ IF (num_synop_p > 0) THEN
+ ! allocate memory
+ allocate (index_synop_p (num_synop_p ))
+ allocate (synop_lat_p (num_synop_p ))
+ allocate (synop_lon_p (num_synop_p ))
+ allocate (synop_qref_p (num_synop_p ))
+ allocate (synop_tref_p (num_synop_p ))
+ allocate (qref_ens_p (num_synop_p, DEF_DA_ENS_NUM ))
+ allocate (tref_ens_p (num_synop_p, DEF_DA_ENS_NUM ))
+ allocate (synop_tref_err (num_synop_p ))
+ allocate (synop_qref_err (num_synop_p ))
+ allocate (d_synop_p (num_synop_p ))
+
+ ! index of observations around target patch
+ index_synop_p = ( &
+ synop_lat(:) < lat_p_n .and. synop_lat(:) > lat_p_s .and. &
+ synop_lon(:) > lon_p_w .and. synop_lon(:) < lon_p_e .and. &
+ synop_time(:) - idate_b >= 0 .and. synop_time(:) - idate_e <= 0 .and. &
+ tref_ens_o(:,1) > 0)
+
+ ! crop observations around target patch
+ synop_lat_p = pack(synop_lat, index_synop_p)
+ synop_lon_p = pack(synop_lon, index_synop_p)
+ synop_qref_p = pack(synop_qref, index_synop_p)
+ synop_tref_p = pack(synop_tref, index_synop_p)
+
+ ! crop ensemble predicted observations around target patch
+ DO i = 1, DEF_DA_ENS_NUM
+ qref_ens_p(:, i) = pack(qref_ens_o(:, i), index_synop_p)
+ tref_ens_p(:, i) = pack(tref_ens_o(:, i), index_synop_p)
+ ENDDO
+
+ ! calculate distance between observation and patch center
+ d_synop_p = 2*6.3781e3*asin(sqrt(sin((synop_lat_p*pi/180 - patchlatr(np))/2.0)**2 + &
+ cos(synop_lat_p*pi/180)*cos(patchlatr(np))*sin((synop_lon_p*pi/180 - patchlonr(np))/2.0)**2))
+
+ ! calculate weighted observation error
+ synop_tref_err = static_synop_tref_err/(exp((-d_synop_p**2)/(2*loc_r**2)))
+ synop_qref_err = static_synop_qref_err/(exp((-d_synop_p**2)/(2*loc_r**2)))
+ ENDIF
+
+!#############################################################################
+! 2.2. Concat observations & ensemble predictions around target patch
+!#############################################################################
+ ! index of end of each observation dataset
+ end_idx(1) = num_smap_p
+ end_idx(2) = num_smap_p + num_fy3d_p
+ end_idx(3) = num_smap_p + num_fy3d_p + num_synop_p
+
+ ! concatenate ensemble predictions
+ IF (num_smap_p > 0) THEN
+ pred_obs_p_ens(1:end_idx(1),:) = pred_smap_tb_h_p_ens
+ obs_p(1:end_idx(1)) = smap_tb_h_p
+ obs_err(1:end_idx(1)) = smap_err
+ ENDIF
+ IF (num_fy3d_p > 0) THEN
+ pred_obs_p_ens(end_idx(1)+1:end_idx(2),:) = pred_fy3d_tb_h_p_ens
+ obs_p(end_idx(1)+1:end_idx(2)) = fy3d_tb_h_p
+ obs_err(end_idx(1)+1:end_idx(2)) = fy3d_err
+ ENDIF
+ IF (num_synop_p > 0) THEN
+ pred_obs_p_ens(end_idx(2)+1:end_idx(3),:) = tref_ens_p
+ pred_obs_p_ens(end_idx(3)+1:,:) = qref_ens_p
+ obs_p(end_idx(2)+1:end_idx(3)) = synop_tref_p
+ obs_p(end_idx(3)+1:) = synop_qref_p
+ obs_err(end_idx(2)+1:end_idx(3)) = synop_tref_err
+ obs_err(end_idx(3)+1:) = synop_qref_err
+ ENDIF
+ !index_nearest = minloc(d_p, dim=1)
+
+!#############################################################################
+! Perform LETKF and postprocess analysis results
+!#############################################################################
+ ! calculate transformation matrix
+ CALL letkf(DEF_DA_ENS_NUM, num_obs_p, &
+ pred_obs_p_ens, obs_p, obs_err, infl, &
+ trans)
+
+ ! calculate analysis value
+ IF (patchtype(np) < 3) THEN ! ocean, lake, ice
+ has_DA = .true.
+
+ ! soil layer
+ DO iens = 1, DEF_DA_ENS_NUM
+ wliq_soi_ens(:, iens) = wliq_soisno_ens(1:, iens, np)
+ t_soi_ens(:, iens) = t_soisno_ens(1:, iens, np)
+ ENDDO
+
+ ! analysis
+ CALL dgemm('N', 'N', nl_soil, DEF_DA_ENS_NUM, DEF_DA_ENS_NUM, 1.0_8, wliq_soi_ens, &
+ nl_soil, trans, DEF_DA_ENS_NUM, 0.0_8, wliq_soi_ens_da, nl_soil)
+ CALL dgemm('N', 'N', nl_soil, DEF_DA_ENS_NUM, DEF_DA_ENS_NUM, 1.0_8, t_soi_ens, &
+ nl_soil, trans, DEF_DA_ENS_NUM, 0.0_8, t_soi_ens_da, nl_soil)
+
+ ! save analysis results
+ wliq_soi_ens_da = max(0.0, wliq_soi_ens_da)
+ DO iens = 1, DEF_DA_ENS_NUM
+ wliq_soisno_ens(1:2, iens, np) = wliq_soi_ens_da(1:2, iens)
+ ! limit the change of t_soisno in range of [-20.0, 20.0]
+ WHERE (t_soi_ens_da(1:2,iens) > t_soisno_ens(1:2,iens,np))
+ t_soisno_ens(1:2,iens,np) = t_soisno_ens(1:2,iens,np) + min(20.0, t_soi_ens_da(1:2,iens)-t_soisno_ens(1:2,iens,np))
+ ELSEWHERE
+ t_soisno_ens(1:2,iens,np) = t_soisno_ens(1:2,iens,np) + max(-20.0, t_soi_ens_da(1:2,iens)-t_soisno_ens(1:2,iens,np))
+ ENDWHERE
+ ENDDO
+
+ ! limit the soil liquid and ice water in a reasonable range
+ DO i = 1, nl_soil
+ DO iens = 1, DEF_DA_ENS_NUM
+ ! lower bound
+ wliq_soisno_ens(i, iens, np) = max(0.0d0, wliq_soisno_ens(i, iens, np))
+ wice_soisno_ens(i, iens, np) = max(0.0d0, wice_soisno_ens(i, iens, np))
+ IF (wliq_soisno_ens(i, iens, np) == 0.0 .and. wice_soisno_ens(i, iens, np) == 0.0) THEN
+ IF (t_soisno_ens(i, iens, np)-tfrz < -5.0) THEN
+ wice_soisno_ens(i, iens, np) = 1e-10
+ ELSE
+ wliq_soisno_ens(i, iens, np) = 1e-10
+ ENDIF
+ ENDIF
+
+ ! upper bound
+ wliq_soisno_ens(i, iens, np) = min(porsl(i, np)*(dz_soi(i)*denh2o), wliq_soisno_ens(i, iens, np))
+ eff_porsl = max(0.0d0, porsl(i, np) - wliq_soisno_ens(i, iens, np)/(dz_soi(i)*denh2o))
+ wice_soisno_ens(i, iens, np) = min(eff_porsl*(dz_soi(i)*denice), wice_soisno_ens(i, iens, np))
+ ENDDO
+ ENDDO
+
+ ! move residual water to water table
+ wa_ens(:, np) = wa_ens(:, np) - sum(wliq_soisno_ens(1:, :, np) - wliq_soi_ens, dim=1)
+
+ ! update volumetric water content for diagnostic
+ DO iens = 1, DEF_DA_ENS_NUM
+ h2osoi_ens(:, iens, np) = wliq_soisno_ens(1:, iens, np)/(dz_soi(:)*denh2o) + wice_soisno_ens(1:, iens, np)/(dz_soi(:)*denice)
+ h2osoi_ens(:, iens, np) = min(1.0d0, h2osoi_ens(:, iens, np))
+ h2osoi_ens(:, iens, np) = max(0.0d0, h2osoi_ens(:, iens, np))
+ ENDDO
+ ENDIF
+ ENDIF
+
+
+!#############################################################################
+! deallocate memory changes with patch
+!#############################################################################
+ IF (allocated(trans )) deallocate (trans )
+ IF (allocated(smap_err )) deallocate (smap_err )
+ IF (allocated(d_smap_p )) deallocate (d_smap_p )
+ IF (allocated(fy3d_err )) deallocate (fy3d_err )
+ IF (allocated(d_fy3d_p )) deallocate (d_fy3d_p )
+ IF (allocated(synop_tref_err )) deallocate (synop_tref_err )
+ IF (allocated(synop_qref_err )) deallocate (synop_qref_err )
+ IF (allocated(d_synop_p )) deallocate (d_synop_p )
+ IF (allocated(pred_obs_p_ens )) deallocate (pred_obs_p_ens )
+ IF (allocated(obs_p )) deallocate (obs_p )
+ IF (allocated(obs_err )) deallocate (obs_err )
+ IF (allocated(wliq_soi_ens )) deallocate (wliq_soi_ens )
+ IF (allocated(wliq_soi_ens_da )) deallocate (wliq_soi_ens_da )
+ IF (allocated(t_soi_ens )) deallocate (t_soi_ens )
+ IF (allocated(t_soi_ens_da )) deallocate (t_soi_ens_da )
+
+ IF (allocated(index_smap_p )) deallocate (index_smap_p )
+ IF (allocated(smap_lat_p )) deallocate (smap_lat_p )
+ IF (allocated(smap_lon_p )) deallocate (smap_lon_p )
+ IF (allocated(smap_tb_h_p )) deallocate (smap_tb_h_p )
+ IF (allocated(smap_tb_v_p )) deallocate (smap_tb_v_p )
+ IF (allocated(pred_smap_tb_h_p_ens )) deallocate (pred_smap_tb_h_p_ens )
+ IF (allocated(pred_smap_tb_v_p_ens )) deallocate (pred_smap_tb_v_p_ens )
+ IF (allocated(smap_tb_h_mean_p )) deallocate (smap_tb_h_mean_p )
+ IF (allocated(pred_smap_tb_h_mean_p)) deallocate (pred_smap_tb_h_mean_p)
+ IF (allocated(smap_tb_v_mean_p )) deallocate (smap_tb_v_mean_p )
+ IF (allocated(pred_smap_tb_v_mean_p)) deallocate (pred_smap_tb_v_mean_p)
+
+ IF (allocated(index_fy3d_p )) deallocate (index_fy3d_p )
+ IF (allocated(fy3d_lat_p )) deallocate (fy3d_lat_p )
+ IF (allocated(fy3d_lon_p )) deallocate (fy3d_lon_p )
+ IF (allocated(fy3d_tb_h_p )) deallocate (fy3d_tb_h_p )
+ IF (allocated(fy3d_tb_v_p )) deallocate (fy3d_tb_v_p )
+ IF (allocated(pred_fy3d_tb_h_p_ens )) deallocate (pred_fy3d_tb_h_p_ens )
+ IF (allocated(pred_fy3d_tb_v_p_ens )) deallocate (pred_fy3d_tb_v_p_ens )
+ IF (allocated(fy3d_tb_h_mean_p )) deallocate (fy3d_tb_h_mean_p )
+ IF (allocated(pred_fy3d_tb_h_mean_p)) deallocate (pred_fy3d_tb_h_mean_p)
+ IF (allocated(fy3d_tb_v_mean_p )) deallocate (fy3d_tb_v_mean_p )
+ IF (allocated(pred_fy3d_tb_v_mean_p)) deallocate (pred_fy3d_tb_v_mean_p)
+
+ IF (allocated(index_synop_p )) deallocate (index_synop_p )
+ IF (allocated(synop_lat_p )) deallocate (synop_lat_p )
+ IF (allocated(synop_lon_p )) deallocate (synop_lon_p )
+ IF (allocated(synop_qref_p )) deallocate (synop_qref_p )
+ IF (allocated(synop_tref_p )) deallocate (synop_tref_p )
+ IF (allocated(qref_ens_p )) deallocate (qref_ens_p )
+ IF (allocated(tref_ens_p )) deallocate (tref_ens_p )
+ ENDDO
+ ENDIF
+ ENDIF
+
+
+!#############################################################################
+! Calculate ensemble brightness temperature after DA for diagnostic
+!#############################################################################
+ IF (has_DA) THEN
+ IF (p_is_compute) THEN
+ IF (DEF_DA_SM_SMAP) THEN
+ IF (DEF_DA_ENS_NUM > 1) THEN
+ DO iens = 1, DEF_DA_ENS_NUM
+ DO np = 1, numpatch
+ CALL forward(&
+ patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), &
+ forc_topo(np), htop(np), &
+ tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), &
+ wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), &
+ snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), &
+ wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), &
+ smap_theta, smap_fghz, &
+ t_brt_smap_ens(1,iens,np), t_brt_smap_ens(2,iens,np))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (DEF_DA_SM_FY) THEN
+ IF (DEF_DA_ENS_NUM > 1) THEN
+ DO iens = 1, DEF_DA_ENS_NUM
+ DO np = 1, numpatch
+ CALL forward(&
+ patchtype(np), patchclass(np), dz_sno_ens(:, iens, np), &
+ forc_topo(np), htop(np), &
+ tref_ens(iens, np), t_soisno_ens(:,iens,np), tleaf_ens(iens, np), &
+ wliq_soisno_ens(:, iens, np), wice_soisno_ens(:, iens, np), h2osoi_ens(:, iens, np), &
+ snowdp_ens(iens, np), lai_ens(iens, np), sai_ens(iens, np), &
+ wf_clay(:, np), wf_sand(:, np), wf_silt(:, np), BD_all(:, np), porsl(:, np), &
+ fy3d_theta, fy3d_fghz, &
+ t_brt_fy3d_ens(1,iens,np), t_brt_fy3d_ens(2,iens,np))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+!#############################################################################
+! Deallocate all memory
+!#############################################################################
+ IF (allocated (trans)) deallocate (trans)
+ IF (allocated (obs_err)) deallocate (obs_err)
+ IF (allocated (filter )) deallocate (filter )
+ IF (allocated (wliq_soi_ens)) deallocate (wliq_soi_ens)
+ IF (allocated (wliq_soi_ens_da)) deallocate (wliq_soi_ens_da)
+ IF (allocated (t_soi_ens)) deallocate (t_soi_ens)
+ IF (allocated (t_soi_ens_da)) deallocate (t_soi_ens_da)
+
+ IF (allocated (smap_time)) deallocate (smap_time)
+ IF (allocated (dt_b_smap)) deallocate (dt_b_smap)
+ IF (allocated (dt_e_smap)) deallocate (dt_e_smap)
+ IF (allocated (smap_lat)) deallocate (smap_lat)
+ IF (allocated (smap_lon)) deallocate (smap_lon)
+ IF (allocated (smap_tb_h)) deallocate (smap_tb_h)
+ IF (allocated (smap_tb_v)) deallocate (smap_tb_v)
+ IF (allocated (smap_ii)) deallocate (smap_ii)
+ IF (allocated (smap_jj)) deallocate (smap_jj)
+ IF (allocated (smap_tb_h_mean)) deallocate (smap_tb_h_mean)
+ IF (allocated (smap_tb_v_mean)) deallocate (smap_tb_v_mean)
+ IF (allocated (pred_smap_tb_h_mean)) deallocate (pred_smap_tb_h_mean)
+ IF (allocated (pred_smap_tb_v_mean)) deallocate (pred_smap_tb_v_mean)
+ IF (allocated (pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens)
+ IF (allocated (pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens)
+ IF (allocated (pred_smap_tb_h_ogrid_ens)) deallocate (pred_smap_tb_h_ogrid_ens)
+ IF (allocated (pred_smap_tb_v_ogrid_ens)) deallocate (pred_smap_tb_v_ogrid_ens)
+
+ IF (allocated (fy3d_time)) deallocate (fy3d_time)
+ IF (allocated (dt_b_fy3d)) deallocate (dt_b_fy3d)
+ IF (allocated (dt_e_fy3d)) deallocate (dt_e_fy3d)
+ IF (allocated (fy3d_lat)) deallocate (fy3d_lat)
+ IF (allocated (fy3d_lon)) deallocate (fy3d_lon)
+ IF (allocated (fy3d_tb_h)) deallocate (fy3d_tb_h)
+ IF (allocated (fy3d_tb_v)) deallocate (fy3d_tb_v)
+ IF (allocated (fy3d_ii)) deallocate (fy3d_ii)
+ IF (allocated (fy3d_jj)) deallocate (fy3d_jj)
+ IF (allocated (fy3d_tb_h_mean)) deallocate (fy3d_tb_h_mean)
+ IF (allocated (fy3d_tb_v_mean)) deallocate (fy3d_tb_v_mean)
+ IF (allocated (pred_fy3d_tb_h_mean)) deallocate (pred_fy3d_tb_h_mean)
+ IF (allocated (pred_fy3d_tb_v_mean)) deallocate (pred_fy3d_tb_v_mean)
+ IF (allocated (pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens)
+ IF (allocated (pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens)
+ IF (allocated (pred_fy3d_tb_h_ogrid_ens)) deallocate (pred_fy3d_tb_h_ogrid_ens)
+ IF (allocated (pred_fy3d_tb_v_ogrid_ens)) deallocate (pred_fy3d_tb_v_ogrid_ens)
+
+ IF (allocated (synop_time)) deallocate (synop_time)
+ IF (allocated (synop_lat)) deallocate (synop_lat)
+ IF (allocated (synop_lon)) deallocate (synop_lon)
+ IF (allocated (synop_qref)) deallocate (synop_qref)
+ IF (allocated (synop_tref)) deallocate (synop_tref)
+ IF (allocated (tref_ens_o)) deallocate (tref_ens_o)
+ IF (allocated (qref_ens_o)) deallocate (qref_ens_o)
+
+ IF (allocated (synop_idx)) deallocate (synop_idx)
+ IF (allocated (site_id_rank)) deallocate (site_id_rank)
+ IF (allocated (tref_ens_rank)) deallocate (tref_ens_rank)
+ IF (allocated (qref_ens_rank)) deallocate (qref_ens_rank)
+ IF (allocated (qref_ens_o)) deallocate (qref_ens_o)
+ IF (allocated (tref_ens_o)) deallocate (tref_ens_o)
+
+
+
+ END SUBROUTINE run_DA_SM
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE end_DA_SM()
+
+!-----------------------------------------------------------------------------
+ IMPLICIT NONE
+
+!-----------------------------------------------------------------------------
+ IF (allocated (trans)) deallocate (trans)
+ IF (allocated (obs_err)) deallocate (obs_err)
+ IF (allocated (filter )) deallocate (filter )
+ IF (allocated (wliq_soi_ens)) deallocate (wliq_soi_ens)
+ IF (allocated (wliq_soi_ens_da)) deallocate (wliq_soi_ens_da)
+ IF (allocated (t_soi_ens)) deallocate (t_soi_ens)
+ IF (allocated (t_soi_ens_da)) deallocate (t_soi_ens_da)
+
+ IF (allocated (smap_time)) deallocate (smap_time)
+ IF (allocated (dt_b_smap)) deallocate (dt_b_smap)
+ IF (allocated (dt_e_smap)) deallocate (dt_e_smap)
+ IF (allocated (smap_lat)) deallocate (smap_lat)
+ IF (allocated (smap_lon)) deallocate (smap_lon)
+ IF (allocated (smap_tb_h)) deallocate (smap_tb_h)
+ IF (allocated (smap_tb_v)) deallocate (smap_tb_v)
+ IF (allocated (smap_ii)) deallocate (smap_ii)
+ IF (allocated (smap_jj)) deallocate (smap_jj)
+ IF (allocated (smap_tb_h_mean)) deallocate (smap_tb_h_mean)
+ IF (allocated (smap_tb_v_mean)) deallocate (smap_tb_v_mean)
+ IF (allocated (pred_smap_tb_h_mean)) deallocate (pred_smap_tb_h_mean)
+ IF (allocated (pred_smap_tb_v_mean)) deallocate (pred_smap_tb_v_mean)
+ IF (allocated (pred_smap_tb_h_pset_ens)) deallocate (pred_smap_tb_h_pset_ens)
+ IF (allocated (pred_smap_tb_v_pset_ens)) deallocate (pred_smap_tb_v_pset_ens)
+ IF (allocated (pred_smap_tb_h_ogrid_ens)) deallocate (pred_smap_tb_h_ogrid_ens)
+ IF (allocated (pred_smap_tb_v_ogrid_ens)) deallocate (pred_smap_tb_v_ogrid_ens)
+
+ IF (allocated (fy3d_time)) deallocate (fy3d_time)
+ IF (allocated (dt_b_fy3d)) deallocate (dt_b_fy3d)
+ IF (allocated (dt_e_fy3d)) deallocate (dt_e_fy3d)
+ IF (allocated (fy3d_lat)) deallocate (fy3d_lat)
+ IF (allocated (fy3d_lon)) deallocate (fy3d_lon)
+ IF (allocated (fy3d_tb_h)) deallocate (fy3d_tb_h)
+ IF (allocated (fy3d_tb_v)) deallocate (fy3d_tb_v)
+ IF (allocated (fy3d_ii)) deallocate (fy3d_ii)
+ IF (allocated (fy3d_jj)) deallocate (fy3d_jj)
+ IF (allocated (fy3d_tb_h_mean)) deallocate (fy3d_tb_h_mean)
+ IF (allocated (fy3d_tb_v_mean)) deallocate (fy3d_tb_v_mean)
+ IF (allocated (pred_fy3d_tb_h_mean)) deallocate (pred_fy3d_tb_h_mean)
+ IF (allocated (pred_fy3d_tb_v_mean)) deallocate (pred_fy3d_tb_v_mean)
+ IF (allocated (pred_fy3d_tb_h_pset_ens)) deallocate (pred_fy3d_tb_h_pset_ens)
+ IF (allocated (pred_fy3d_tb_v_pset_ens)) deallocate (pred_fy3d_tb_v_pset_ens)
+ IF (allocated (pred_fy3d_tb_h_ogrid_ens)) deallocate (pred_fy3d_tb_h_ogrid_ens)
+ IF (allocated (pred_fy3d_tb_v_ogrid_ens)) deallocate (pred_fy3d_tb_v_ogrid_ens)
+
+ IF (allocated (synop_time)) deallocate (synop_time)
+ IF (allocated (synop_lat)) deallocate (synop_lat)
+ IF (allocated (synop_lon)) deallocate (synop_lon)
+ IF (allocated (synop_qref)) deallocate (synop_qref)
+ IF (allocated (synop_tref)) deallocate (synop_tref)
+ IF (allocated (tref_ens_o)) deallocate (tref_ens_o)
+ IF (allocated (qref_ens_o)) deallocate (qref_ens_o)
+
+ IF (allocated (synop_idx)) deallocate (synop_idx)
+ IF (allocated (site_id_rank)) deallocate (site_id_rank)
+ IF (allocated (tref_ens_rank)) deallocate (tref_ens_rank)
+ IF (allocated (qref_ens_rank)) deallocate (qref_ens_rank)
+ IF (allocated (qref_ens_o)) deallocate (qref_ens_o)
+ IF (allocated (tref_ens_o)) deallocate (tref_ens_o)
+
+
+ END SUBROUTINE end_DA_SM
+
+!-----------------------------------------------------------------------------
+END MODULE MOD_DA_SM
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90
new file mode 100644
index 0000000000..90d2e17f9a
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_TWS.F90
@@ -0,0 +1,440 @@
+#include
+
+#ifdef DataAssimilation
+MODULE MOD_DA_TWS
+!-----------------------------------------------------------------------------
+! DESCRIPTION:
+! Data assimilation of terrestrial water storge from GRACE satellite
+!
+! AUTHOR:
+! Shupeng Zhang: Initial version
+!-----------------------------------------------------------------------------
+ USE MOD_DataType
+ USE MOD_SpatialMapping
+
+ IMPLICIT NONE
+
+ PUBLIC :: init_DA_GRACE
+ PUBLIC :: run_DA_GRACE
+ PUBLIC :: end_DA_GRACE
+
+ real(r8), allocatable, PUBLIC :: fslp_k_mon (:,:) ! slope factor of runoff
+ real(r8), allocatable, PUBLIC :: fslp_k (:) ! slope factor of runoff
+
+ PRIVATE
+
+ character(len=256) :: file_grace
+ type(grid_type) :: grid_grace
+
+ real(r8), allocatable :: longrace(:)
+ real(r8), allocatable :: latgrace(:)
+
+ integer :: nobstime
+ integer, allocatable :: obsyear (:)
+ integer, allocatable :: obsmonth (:)
+
+ type (spatial_mapping_type) :: mg2p_grace
+
+ real(r8), allocatable :: lwe_obs_this (:)
+ real(r8), allocatable :: err_obs_this (:)
+
+ real(r8), allocatable :: lwe_obs_prev (:)
+ real(r8), allocatable :: err_obs_prev (:)
+
+ real(r8), allocatable :: wat_prev_m (:)
+ real(r8), allocatable :: wat_this_m (:)
+
+ real(r8), allocatable :: rnof_acc_prev_m (:)
+ real(r8), allocatable :: rnof_acc_this_m (:)
+ real(r8), allocatable :: zwt_acc_prev_m (:)
+ real(r8), allocatable :: zwt_acc_this_m (:)
+
+ real(r8), allocatable :: rnof_prev_m0 (:)
+ real(r8), allocatable :: rnof_prev_m1 (:)
+ real(r8), allocatable :: rnof_this_m (:)
+
+ logical, allocatable :: rnofmask (:)
+
+ logical :: has_prev_grace_obs
+ integer :: nac_grace_this, nac_grace_prev
+
+ integer :: year_prev, month_prev
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE init_DA_GRACE ()
+
+ USE MOD_Spmd_Task
+ USE MOD_Namelist, only : DEF_DA_obsdir
+ USE MOD_Grid
+ USE MOD_NetCDFSerial
+ USE MOD_Mesh, only : numelm
+ USE MOD_LandElm, only : landelm
+ USE MOD_LandPatch
+#ifdef CROP
+ USE MOD_LandCrop
+#endif
+ USE MOD_Pixelset
+ USE MOD_Vars_TimeInvariants, only : patchtype
+ USE MOD_Forcing, only : forcmask_pch
+ USE MOD_RangeCheck
+ IMPLICIT NONE
+
+ ! Local Variables
+
+ real(r8), allocatable :: time_real8(:)
+ integer :: itime
+
+ file_grace = trim(DEF_DA_obsdir) &
+ // '/GRACE_JPL/GRCTellus.JPL.200204_202207.GLO.RL06M.MSCNv02CRI.nc'
+
+ CALL ncio_read_bcast_serial (file_grace, 'time', time_real8)
+
+ nobstime = size(time_real8)
+ allocate (obsyear (nobstime))
+ allocate (obsmonth(nobstime))
+
+ DO itime = 1, nobstime
+ CALL retrieve_yymm_from_days (time_real8(itime), obsyear(itime), obsmonth(itime))
+ ENDDO
+
+ IF (p_is_root) THEN
+ write(*,*) 'Assimilate GRACE data at'
+ DO itime = 1, nobstime
+ write(*,*) obsyear(itime), obsmonth(itime)
+ ENDDO
+ ENDIF
+
+ CALL ncio_read_bcast_serial (file_grace, 'lon', longrace)
+ CALL ncio_read_bcast_serial (file_grace, 'lat', latgrace)
+
+ CALL grid_grace%define_by_center (latgrace,longrace)
+
+ CALL mg2p_grace%build_arealweighted (grid_grace, landelm)
+
+ IF (p_is_compute) THEN
+ IF (numelm > 0) THEN
+ allocate (lwe_obs_this (numelm))
+ allocate (err_obs_this (numelm))
+ allocate (lwe_obs_prev (numelm))
+ allocate (err_obs_prev (numelm))
+ ENDIF
+
+ IF (numpatch > 0) THEN
+ allocate (wat_prev_m (numpatch))
+ allocate (wat_this_m (numpatch))
+ allocate (rnof_acc_prev_m (numpatch))
+ allocate (rnof_acc_this_m (numpatch))
+ allocate (zwt_acc_prev_m (numpatch))
+ allocate (zwt_acc_this_m (numpatch))
+ allocate (rnof_prev_m0 (numpatch))
+ allocate (rnof_prev_m1 (numpatch))
+ allocate (rnof_this_m (numpatch))
+ allocate (rnofmask (numpatch))
+
+ allocate (fslp_k_mon (12,numpatch))
+ allocate (fslp_k (numpatch))
+ ENDIF
+ ENDIF
+
+ IF (p_is_compute) THEN
+ CALL elm_patch%build (landelm, landpatch, use_frac = .true.)
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ rnofmask = patchtype == 0
+ IF (DEF_forcing%has_missing_value) THEN
+ rnofmask = rnofmask .and. forcmask_pch
+ ENDIF
+ ENDIF
+ ENDIF
+
+
+ has_prev_grace_obs = .false.
+
+ nac_grace_this = 0
+ nac_grace_prev = 0
+
+ IF (p_is_compute) THEN
+ wat_this_m (:) = 0.
+ rnof_acc_this_m(:) = 0.
+ rnof_this_m (:) = 0.
+ zwt_acc_this_m (:) = 0.
+ fslp_k_mon (:,:) = 1.0
+ fslp_k (:) = 1.0
+ ENDIF
+
+ deallocate (time_real8)
+
+ END SUBROUTINE init_DA_GRACE
+
+ ! ----------
+ SUBROUTINE run_DA_GRACE (idate, deltim)
+
+ USE MOD_Spmd_task
+ USE MOD_TimeManager
+ USE MOD_NetCDFBlock
+ USE MOD_Mesh
+ USE MOD_LandElm
+ USE MOD_LandPatch
+ USE MOD_Vars_1DFluxes, only : rnof, rsur
+ USE MOD_Vars_TimeVariables, only : wat, wa, wdsrf, zwt
+ USE MOD_RangeCheck
+ USE MOD_UserDefFun
+ IMPLICIT NONE
+
+ integer, intent(in) :: idate(3)
+ real(r8), intent(in) :: deltim
+
+ ! Local Variables
+ logical :: is_obs_time
+ integer :: month, mday, itime, ielm, istt, iend, nextmonth
+
+ real(r8) :: sumpct
+ real(r8) :: w1, w0, r1, r0, var_o, var_m, dw_f, dw_o, dw_a, rr, zwt_ave
+ real(r8) :: fscal, fprev, fthis
+
+ type(block_data_real8_2d) :: f_grace_lwe ! unit: cm
+ type(block_data_real8_2d) :: f_grace_err ! unit: cm
+
+ character(len=256) :: sid, logfile
+
+ CALL julian2monthday (idate(1), idate(2), month, mday)
+
+ is_obs_time = any((obsyear == idate(1)) .and. (obsmonth == month))
+
+ IF (p_is_root) THEN
+ IF (is_obs_time) THEN
+ write(*,*) 'GRACE at this time.'
+ ENDIF
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ IF (has_prev_grace_obs) THEN
+
+ nac_grace_prev = nac_grace_prev + 1
+
+ rnof_acc_prev_m = rnof_acc_prev_m + rnof * deltim
+ IF (is_obs_time) THEN
+ rnof_prev_m1 = rnof_prev_m1 + rnof_acc_prev_m
+ ENDIF
+
+ zwt_acc_prev_m = zwt_acc_prev_m + zwt
+ ENDIF
+
+ IF (is_obs_time) THEN
+
+ nac_grace_this = nac_grace_this + 1
+
+ wat_this_m = wat_this_m + wat + wa + wdsrf
+
+ rnof_acc_this_m = rnof_acc_this_m + rnof * deltim
+ rnof_this_m = rnof_this_m + rnof_acc_this_m
+
+ zwt_acc_this_m = zwt_acc_this_m + zwt
+ ENDIF
+
+ ENDIF
+
+ IF (is_obs_time .and. (isendofmonth(idate, deltim))) THEN
+
+ itime = findloc_ud((obsyear == idate(1)) .and. (obsmonth == month))
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (grid_grace, f_grace_lwe)
+ CALL allocate_block_data (grid_grace, f_grace_err)
+ CALL ncio_read_block_time (file_grace, 'lwe_thickness', grid_grace, itime, f_grace_lwe)
+ CALL ncio_read_block_time (file_grace, 'uncertainty' , grid_grace, itime, f_grace_err)
+ ENDIF
+
+ CALL mg2p_grace%grid2pset (f_grace_lwe, lwe_obs_this)
+ CALL mg2p_grace%grid2pset (f_grace_err, err_obs_this)
+
+ IF (p_is_compute) THEN
+
+ lwe_obs_this = lwe_obs_this * 10.0 ! from cm to mm
+ err_obs_this = err_obs_this * 10.0 ! from cm to mm
+
+ wat_this_m = wat_this_m / nac_grace_this
+
+ zwt_acc_prev_m = zwt_acc_prev_m / nac_grace_prev
+
+ IF (has_prev_grace_obs) THEN
+ rnof_prev_m1 = rnof_prev_m1 / nac_grace_this
+ ENDIF
+
+ IF (has_prev_grace_obs .and. &
+ (((idate(1) == year_prev) .and. (month_prev == month-1)) &
+ .or. ((idate(1) == year_prev+1) .and. (month_prev == 12) .and. (month == 1)))) &
+ THEN
+
+ ! write(sid,'(I0)') p_iam_compute
+ ! logfile = 'log/grace_log_' // trim(sid) // '.txt'
+ ! open(12, file = trim(logfile), position = 'append')
+
+ DO ielm = 1, numelm
+ istt = elm_patch%substt(ielm)
+ iend = elm_patch%subend(ielm)
+
+ sumpct = sum(elm_patch%subfrc(istt:iend), mask = rnofmask(istt:iend))
+
+ IF (sumpct <= 0) THEN
+ CYCLE
+ ENDIF
+
+ w1 = sum(wat_this_m (istt:iend) * elm_patch%subfrc(istt:iend), &
+ mask = rnofmask(istt:iend)) / sumpct
+ w0 = sum(wat_prev_m (istt:iend) * elm_patch%subfrc(istt:iend), &
+ mask = rnofmask(istt:iend)) / sumpct
+ r1 = sum(rnof_prev_m1(istt:iend) * elm_patch%subfrc(istt:iend), &
+ mask = rnofmask(istt:iend)) / sumpct
+ r0 = sum(rnof_prev_m0(istt:iend) * elm_patch%subfrc(istt:iend), &
+ mask = rnofmask(istt:iend)) / sumpct
+
+ zwt_ave = sum(zwt_acc_prev_m(istt:iend) * elm_patch%subfrc(istt:iend), &
+ mask = rnofmask(istt:iend)) / sumpct
+
+
+ var_o = err_obs_this(ielm)**2 + err_obs_prev(ielm)**2
+
+ dw_f = w1 - w0
+ dw_o = lwe_obs_this(ielm) - lwe_obs_prev(ielm)
+ var_m = (dw_f-dw_o)**2 - var_o
+
+ IF (var_m > 0) THEN
+
+ dw_a = (var_o * dw_f + var_m * dw_o) / (var_m+var_o)
+
+ rr = r1 - r0
+
+ IF (rr > 0) THEN
+
+ fscal = (1-(dw_a-dw_f)/rr)
+
+ ! (2) method 2: one parameters adjusted
+ fprev = fslp_k_mon(month,istt)
+ fthis = fprev * fscal
+ fthis = min(max(fthis, fprev*0.5), fprev*2.0)
+ fslp_k_mon(month,istt:iend) = fthis
+
+ fprev = fslp_k_mon(month_prev,istt)
+ fthis = fprev * fscal
+ fthis = min(max(fthis, fprev*0.5), fprev*2.0)
+ fslp_k_mon(month_prev,istt:iend) = fthis
+
+ ! write(12,'(I4,I3,I8,8ES11.2)') idate(1), month, landelm%eindex(ielm), &
+ ! dw_o, sqrt(var_o), dw_f, sqrt(var_m), dw_a, &
+ ! rr, zwt_ave, fscal
+
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+
+ ! close(12)
+ ENDIF
+
+ lwe_obs_prev = lwe_obs_this
+ err_obs_prev = err_obs_this
+
+ wat_prev_m = wat_this_m
+ wat_this_m = 0.
+
+ rnof_acc_prev_m = rnof_acc_this_m
+ rnof_acc_this_m = 0.
+
+ zwt_acc_prev_m = zwt_acc_this_m
+ zwt_acc_this_m = 0.
+
+ rnof_prev_m0 = rnof_this_m / nac_grace_this
+ rnof_prev_m1 = 0.
+ rnof_this_m = 0.
+
+ nac_grace_prev = nac_grace_this
+ nac_grace_this = 0
+
+ ENDIF
+
+ has_prev_grace_obs = .true.
+ year_prev = idate(1)
+ month_prev = month
+
+ ENDIF
+
+ IF (isendofmonth(idate, deltim)) THEN
+ IF (p_is_compute .and. (numpatch > 0)) THEN
+ nextmonth = mod(month+1,12)+1
+ fslp_k = fslp_k_mon(nextmonth,:)
+ ENDIF
+ ENDIF
+
+
+ END SUBROUTINE run_DA_GRACE
+
+ ! ---------
+ SUBROUTINE end_DA_GRACE ()
+
+ IMPLICIT NONE
+
+ IF (allocated(lwe_obs_this)) deallocate(lwe_obs_this)
+ IF (allocated(err_obs_this)) deallocate(err_obs_this)
+ IF (allocated(lwe_obs_prev)) deallocate(lwe_obs_prev)
+ IF (allocated(err_obs_prev)) deallocate(err_obs_prev)
+ IF (allocated(wat_prev_m )) deallocate(wat_prev_m )
+ IF (allocated(wat_this_m )) deallocate(wat_this_m )
+ IF (allocated(rnof_acc_prev_m)) deallocate(rnof_acc_prev_m)
+ IF (allocated(rnof_acc_this_m)) deallocate(rnof_acc_this_m)
+ IF (allocated(rnof_prev_m0 )) deallocate(rnof_prev_m0 )
+ IF (allocated(rnof_prev_m1 )) deallocate(rnof_prev_m1 )
+ IF (allocated(rnof_this_m )) deallocate(rnof_this_m )
+ IF (allocated(rnofmask )) deallocate(rnofmask )
+
+ IF (allocated(fslp_k_mon)) deallocate(fslp_k_mon)
+ IF (allocated(fslp_k)) deallocate(fslp_k)
+
+ IF (allocated(longrace)) deallocate(longrace)
+ IF (allocated(latgrace)) deallocate(latgrace)
+
+ END SUBROUTINE end_DA_GRACE
+
+ ! ---------
+ SUBROUTINE retrieve_yymm_from_days (days, yy, mm)
+
+ IMPLICIT NONE
+ real(r8), intent(in) :: days
+ integer, intent(out) :: yy, mm
+
+ ! Local Variables
+ real(r8) :: resday
+ integer :: mdays(12)
+
+ yy = 2002
+ mm = 1
+ mdays = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)
+
+ resday = days
+ DO WHILE (resday > mdays(mm))
+
+ resday = resday - mdays(mm)
+
+ mm = mm + 1
+ IF (mm > 12) THEN
+ yy = yy + 1
+ mm = 1
+ IF( (mod(yy,4)==0 .and. mod(yy,100)/=0) .or. mod(yy,400)==0 ) THEN
+ mdays(2) = 29
+ ELSE
+ mdays(2) = 28
+ ENDIF
+ ENDIF
+
+ ENDDO
+
+ END SUBROUTINE retrieve_yymm_from_days
+
+END MODULE MOD_DA_TWS
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90
new file mode 100644
index 0000000000..eb71a15d76
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_1DFluxes.F90
@@ -0,0 +1,92 @@
+#include
+
+#ifdef DataAssimilation
+MODULE MOD_DA_Vars_1DFluxes
+!-----------------------------------------------------------------------------
+! DESCRIPTION:
+! Process fluxes variables for diagnostic for data assimilation
+!
+! AUTHOR:
+! Lu Li, 07/2025: Initial version
+!-----------------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Namelist, only: DEF_DA_ENS_NUM
+ IMPLICIT NONE
+ SAVE
+
+ ! public functions
+ PUBLIC :: allocate_1D_DAFluxes
+ PUBLIC :: deallocate_1D_DAFluxes
+
+ ! define variables
+ real(r8), allocatable :: fsena_ens (:,:) ! sensible heat from canopy height to atmosphere [W/m2]
+ real(r8), allocatable :: lfevpa_ens (:,:) ! latent heat flux from canopy height to atmosphere [W/m2]
+ real(r8), allocatable :: fevpa_ens (:,:) ! evapotranspiration from canopy to atmosphere [mm/s]
+ real(r8), allocatable :: rsur_ens (:,:) ! surface runoff (mm h2o/s)
+
+ ! save for analysis increment
+ real(r8), allocatable :: fsena_a (:) !
+ real(r8), allocatable :: fevpa_a (:) !
+ real(r8), allocatable :: lfevpa_a (:) !
+ real(r8), allocatable :: rsur_a (:) !
+
+!-----------------------------------------------------------------------------
+
+CONTAINS
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE allocate_1D_DAFluxes ()
+
+!-----------------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Vars_Global
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch
+ IMPLICIT NONE
+
+!-----------------------------------------------------------------------------
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ allocate ( fsena_ens (DEF_DA_ENS_NUM, numpatch) ) ; fsena_ens (:,:) = spval
+ allocate ( lfevpa_ens (DEF_DA_ENS_NUM, numpatch) ) ; lfevpa_ens (:,:) = spval
+ allocate ( fevpa_ens (DEF_DA_ENS_NUM, numpatch) ) ; fevpa_ens (:,:) = spval
+ allocate ( rsur_ens (DEF_DA_ENS_NUM, numpatch) ) ; rsur_ens (:,:) = spval
+
+ allocate ( fsena_a (numpatch) ) ; fsena_a (:) = spval
+ allocate ( fevpa_a (numpatch) ) ; fevpa_a (:) = spval
+ allocate ( lfevpa_a (numpatch) ) ; lfevpa_a (:) = spval
+ allocate ( rsur_a (numpatch) ) ; rsur_a (:) = spval
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE allocate_1D_DAFluxes
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE deallocate_1D_DAFluxes()
+
+!-----------------------------------------------------------------------------
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch
+
+!-----------------------------------------------------------------------------
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ deallocate ( fsena_ens )
+ deallocate ( lfevpa_ens )
+ deallocate ( fevpa_ens )
+ deallocate ( rsur_ens )
+
+ deallocate ( fsena_a )
+ deallocate ( fevpa_a )
+ deallocate ( lfevpa_a )
+ deallocate ( rsur_a )
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE deallocate_1D_DAFluxes
+
+!-----------------------------------------------------------------------------
+END MODULE MOD_DA_Vars_1DFluxes
+#endif
\ No newline at end of file
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90
new file mode 100644
index 0000000000..c082dcdfac
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/DA/MOD_DA_Vars_TimeVariables.F90
@@ -0,0 +1,716 @@
+#include
+
+#ifdef DataAssimilation
+MODULE MOD_DA_Vars_TimeVariables
+!-----------------------------------------------------------------------------
+! DESCRIPTION:
+! Process time-varying state variables for data assimilation
+!
+! AUTHOR:
+! Lu Li, 12/2024: Initial version
+! Lu Li, 07/2025: Remove unused variables and clean codes
+!-----------------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_TimeManager
+ USE MOD_Namelist, only: DEF_DA_ENS_NUM
+ IMPLICIT NONE
+ SAVE
+
+ ! public functions
+ PUBLIC :: allocate_DATimeVariables
+ PUBLIC :: deallocate_DATimeVariables
+ PUBLIC :: READ_DATimeVariables
+ PUBLIC :: WRITE_DATimeVariables
+#ifdef RangeCheck
+ PUBLIC :: check_DATimeVariables
+#endif
+
+ ! define variables
+ ! Time-varying state variables which required by restart run, used to store tha noda trajectory state variable
+ real(r8), allocatable :: z_sno_noda (:,:) ! node depth [m]
+ real(r8), allocatable :: dz_sno_noda (:,:) ! interface depth [m]
+ real(r8), allocatable :: t_soisno_noda (:,:) ! soil temperature [K]
+ real(r8), allocatable :: wliq_soisno_noda (:,:) ! liquid water in layers [kg/m2]
+ real(r8), allocatable :: wice_soisno_noda (:,:) ! ice lens in layers [kg/m2]
+ real(r8), allocatable :: smp_noda (:,:) ! soil matrix potential [mm]
+ real(r8), allocatable :: hk_noda (:,:) ! hydraulic conductivity [mm h2o/s]
+ real(r8), allocatable :: t_grnd_noda (:) ! ground surface temperature [K]
+ real(r8), allocatable :: tleaf_noda (:) ! leaf temperature [K]
+ real(r8), allocatable :: ldew_noda (:) ! depth of water on foliage [mm]
+ real(r8), allocatable :: ldew_rain_noda (:) ! depth of rain on foliage [mm]
+ real(r8), allocatable :: ldew_snow_noda (:) ! depth of rain on foliage [mm]
+ real(r8), allocatable :: fwet_snow_noda (:) ! vegetation snow fractional cover [-]
+ real(r8), allocatable :: sag_noda (:) ! non dimensional snow age [-]
+ real(r8), allocatable :: scv_noda (:) ! snow cover, water equivalent [mm]
+ real(r8), allocatable :: snowdp_noda (:) ! snow depth [meter]
+ real(r8), allocatable :: fveg_noda (:) ! fraction of vegetation cover
+ real(r8), allocatable :: fsno_noda (:) ! fraction of snow cover on ground
+ real(r8), allocatable :: sigf_noda (:) ! fraction of veg cover, excluding snow-covered veg [-]
+ real(r8), allocatable :: green_noda (:) ! leaf greenness
+ real(r8), allocatable :: tlai_noda (:) ! leaf area index
+ real(r8), allocatable :: lai_noda (:) ! leaf area index
+ real(r8), allocatable :: tsai_noda (:) ! stem area index
+ real(r8), allocatable :: sai_noda (:) ! stem area index
+ real(r8), allocatable :: alb_noda (:,:,:) ! averaged albedo [-]
+ real(r8), allocatable :: ssun_noda (:,:,:) ! sunlit canopy absorption for solar radiation (0-1)
+ real(r8), allocatable :: ssha_noda (:,:,:) ! shaded canopy absorption for solar radiation (0-1)
+ real(r8), allocatable :: ssoi_noda (:,:,:) ! soil absorption for solar radiation (0-1)
+ real(r8), allocatable :: ssno_noda (:,:,:) ! snow absorption for solar radiation (0-1)
+ real(r8), allocatable :: thermk_noda (:) ! canopy gap fraction for tir radiation
+ real(r8), allocatable :: extkb_noda (:) ! (k, g(mu)/mu) direct solar extinction coefficient
+ real(r8), allocatable :: extkd_noda (:) ! diffuse and scattered diffuse PAR extinction coefficient
+ real(r8), allocatable :: zwt_noda (:) ! the depth to water table [m]
+ real(r8), allocatable :: wdsrf_noda (:) ! depth of surface water [mm]
+ real(r8), allocatable :: wa_noda (:) ! water storage in aquifer [mm]
+ real(r8), allocatable :: wetwat_noda (:) ! water storage in wetland [mm]
+ real(r8), allocatable :: t_lake_noda (:,:) ! lake layer teperature [K]
+ real(r8), allocatable :: lake_icefrac_noda(:,:) ! lake mass fraction of lake layer that is frozen
+ real(r8), allocatable :: savedtke1_noda (:) ! top level eddy conductivity (W/m K)
+
+ ! diagnostic variables for RTM forward operator
+ real(r8), allocatable :: tref_noda (:) ! 2 m height air temperature [kelvin]
+ real(r8), allocatable :: h2osoi_noda (:,:) ! volumetric soil water in layers [m3/m3]
+
+ ! Time-varying state variables which required by restart run
+ real(r8), allocatable :: z_sno_ens (:,:,:) ! node depth [m]
+ real(r8), allocatable :: dz_sno_ens (:,:,:) ! interface depth [m]
+ real(r8), allocatable :: t_soisno_ens (:,:,:) ! soil temperature [K]
+ real(r8), allocatable :: wliq_soisno_ens (:,:,:) ! liquid water in layers [kg/m2]
+ real(r8), allocatable :: wice_soisno_ens (:,:,:) ! ice lens in layers [kg/m2]
+ real(r8), allocatable :: smp_ens (:,:,:) ! soil matrix potential [mm]
+ real(r8), allocatable :: hk_ens (:,:,:) ! hydraulic conductivity [mm h2o/s]
+ real(r8), allocatable :: t_grnd_ens (:,:) ! ground surface temperature [K]
+ real(r8), allocatable :: tleaf_ens (:,:) ! leaf temperature [K]
+ real(r8), allocatable :: ldew_ens (:,:) ! depth of water on foliage [mm]
+ real(r8), allocatable :: ldew_rain_ens (:,:) ! depth of rain on foliage [mm]
+ real(r8), allocatable :: ldew_snow_ens (:,:) ! depth of rain on foliage [mm]
+ real(r8), allocatable :: fwet_snow_ens (:,:) ! vegetation snow fractional cover [-]
+ real(r8), allocatable :: sag_ens (:,:) ! non dimensional snow age [-]
+ real(r8), allocatable :: scv_ens (:,:) ! snow cover, water equivalent [mm]
+ real(r8), allocatable :: snowdp_ens (:,:) ! snow depth [meter]
+ real(r8), allocatable :: fveg_ens (:,:) ! fraction of vegetation cover
+ real(r8), allocatable :: fsno_ens (:,:) ! fraction of snow cover on ground
+ real(r8), allocatable :: sigf_ens (:,:) ! fraction of veg cover, excluding snow-covered veg [-]
+ real(r8), allocatable :: green_ens (:,:) ! leaf greenness
+ real(r8), allocatable :: tlai_ens (:,:) ! leaf area index
+ real(r8), allocatable :: lai_ens (:,:) ! leaf area index
+ real(r8), allocatable :: tsai_ens (:,:) ! stem area index
+ real(r8), allocatable :: sai_ens (:,:) ! stem area index
+ real(r8), allocatable :: alb_ens (:,:,:,:) ! averaged albedo [-]
+ real(r8), allocatable :: ssun_ens (:,:,:,:) ! sunlit canopy absorption for solar radiation (0-1)
+ real(r8), allocatable :: ssha_ens (:,:,:,:) ! shaded canopy absorption for solar radiation (0-1)
+ real(r8), allocatable :: ssoi_ens (:,:,:,:) ! soil absorption for solar radiation (0-1)
+ real(r8), allocatable :: ssno_ens (:,:,:,:) ! snow absorption for solar radiation (0-1)
+ real(r8), allocatable :: thermk_ens (:,:) ! canopy gap fraction for tir radiation
+ real(r8), allocatable :: extkb_ens (:,:) ! (k, g(mu)/mu) direct solar extinction coefficient
+ real(r8), allocatable :: extkd_ens (:,:) ! diffuse and scattered diffuse PAR extinction coefficient
+ real(r8), allocatable :: zwt_ens (:,:) ! the depth to water table [m]
+ real(r8), allocatable :: wdsrf_ens (:,:) ! depth of surface water [mm]
+ real(r8), allocatable :: wa_ens (:,:) ! water storage in aquifer [mm]
+ real(r8), allocatable :: wetwat_ens (:,:) ! water storage in wetland [mm]
+ real(r8), allocatable :: t_lake_ens (:,:,:) ! lake layer teperature [K]
+ real(r8), allocatable :: lake_icefrac_ens(:,:,:) ! lake mass fraction of lake layer that is frozen
+ real(r8), allocatable :: savedtke1_ens (:,:) ! top level eddy conductivity (W/m K)
+
+ ! diagnostic variables for DA
+ real(r8), allocatable :: h2osoi_ens (:,:,:) ! volumetric soil water in layers [m3/m3]
+ real(r8), allocatable :: t_brt_smap_ens (:,:,:) ! brightness temperature for radiance calculation [K]
+ real(r8), allocatable :: t_brt_fy3d_ens (:,:,:) ! brightness temperature for radiance calculation [K]
+ real(r8), allocatable :: t_brt_smap (:,:) ! brightness temperature for radiance calculation [K]
+ real(r8), allocatable :: t_brt_fy3d (:,:) ! brightness temperature for radiance calculation [K]
+ real(r8), allocatable :: trad_ens (:,:) ! radiative temperature of surface [K]
+ real(r8), allocatable :: tref_ens (:,:) ! 2 m height air temperature [kelvin]
+ real(r8), allocatable :: qref_ens (:,:) ! 2 m height air specific humidity
+ real(r8), allocatable :: rhref_ens (:,:) ! 2 m height air relative humidity
+ real(r8), allocatable :: ustar_ens (:,:) ! u* in similarity theory [m/s]
+ real(r8), allocatable :: qstar_ens (:,:) ! q* in similarity theory [kg/kg]
+ real(r8), allocatable :: tstar_ens (:,:) ! t* in similarity theory [K]
+ real(r8), allocatable :: fm_ens (:,:) ! integral of profile FUNCTION for momentum
+ real(r8), allocatable :: fh_ens (:,:) ! integral of profile FUNCTION for heat
+ real(r8), allocatable :: fq_ens (:,:) ! integral of profile FUNCTION for moisture
+
+ ! ensemble forcing variables used for ensemble DA
+ real(r8), allocatable :: forc_t_ens (:,:) ! temperature [K]
+ real(r8), allocatable :: forc_frl_ens (:,:) ! atmospheric infrared (longwave) radiation [W/m2]
+ real(r8), allocatable :: forc_prc_ens (:,:) ! convective precipitation [mm/s]
+ real(r8), allocatable :: forc_prl_ens (:,:) ! large scale precipitation [mm/s]
+ real(r8), allocatable :: forc_sols_ens (:,:) ! atm vis direct beam solar rad onto srf [W/m2]
+ real(r8), allocatable :: forc_soll_ens (:,:) ! atm nir direct beam solar rad onto srf [W/m2]
+ real(r8), allocatable :: forc_solsd_ens (:,:) ! atm vis diffuse solar rad onto srf [W/m2]
+ real(r8), allocatable :: forc_solld_ens (:,:) ! atm nir diffuse solar rad onto srf [W/m2]
+
+ ! save for analysis increment
+ real(r8), allocatable :: t_soisno_a (:,:) !
+ real(r8), allocatable :: wliq_soisno_a (:,:) !
+ real(r8), allocatable :: wice_soisno_a (:,:) !
+ real(r8), allocatable :: t_grnd_a (:) !
+ real(r8), allocatable :: tleaf_a (:) !
+ real(r8), allocatable :: snowdp_a (:) !
+ real(r8), allocatable :: h2osoi_a (:,:) !
+ real(r8), allocatable :: t_brt_smap_a (:,:) !
+ real(r8), allocatable :: t_brt_fy3d_a (:,:) !
+ real(r8), allocatable :: trad_a (:) !
+ real(r8), allocatable :: tref_a (:) !
+ real(r8), allocatable :: qref_a (:) !
+ real(r8), allocatable :: ustar_a (:) !
+ real(r8), allocatable :: qstar_a (:) !
+ real(r8), allocatable :: tstar_a (:) !
+ real(r8), allocatable :: fm_a (:) !
+ real(r8), allocatable :: fh_a (:) !
+ real(r8), allocatable :: fq_a (:) !
+
+!-----------------------------------------------------------------------------
+
+CONTAINS
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE allocate_DATimeVariables()
+
+!-----------------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Vars_Global
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+!-----------------------------------------------------------------------------
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ allocate (z_sno_noda (maxsnl+1:0, numpatch)); z_sno_noda (:,:) = spval
+ allocate (dz_sno_noda (maxsnl+1:0, numpatch)); dz_sno_noda (:,:) = spval
+ allocate (t_soisno_noda (maxsnl+1:nl_soil,numpatch)); t_soisno_noda (:,:) = spval
+ allocate (wliq_soisno_noda(maxsnl+1:nl_soil,numpatch)); wliq_soisno_noda (:,:) = spval
+ allocate (wice_soisno_noda(maxsnl+1:nl_soil,numpatch)); wice_soisno_noda (:,:) = spval
+ allocate (smp_noda (1:nl_soil,numpatch)); smp_noda (:,:) = spval
+ allocate (hk_noda (1:nl_soil,numpatch)); hk_noda (:,:) = spval
+ allocate (t_grnd_noda (numpatch)); t_grnd_noda (:) = spval
+ allocate (tleaf_noda (numpatch)); tleaf_noda (:) = spval
+ allocate (ldew_noda (numpatch)); ldew_noda (:) = spval
+ allocate (ldew_rain_noda (numpatch)); ldew_rain_noda (:) = spval
+ allocate (ldew_snow_noda (numpatch)); ldew_snow_noda (:) = spval
+ allocate (fwet_snow_noda (numpatch)); fwet_snow_noda (:) = spval
+ allocate (sag_noda (numpatch)); sag_noda (:) = spval
+ allocate (scv_noda (numpatch)); scv_noda (:) = spval
+ allocate (snowdp_noda (numpatch)); snowdp_noda (:) = spval
+ allocate (fveg_noda (numpatch)); fveg_noda (:) = spval
+ allocate (fsno_noda (numpatch)); fsno_noda (:) = spval
+ allocate (sigf_noda (numpatch)); sigf_noda (:) = spval
+ allocate (green_noda (numpatch)); green_noda (:) = spval
+ allocate (tlai_noda (numpatch)); tlai_noda (:) = spval
+ allocate (lai_noda (numpatch)); lai_noda (:) = spval
+ allocate (tsai_noda (numpatch)); tsai_noda (:) = spval
+ allocate (sai_noda (numpatch)); sai_noda (:) = spval
+ allocate (alb_noda (2,2,numpatch)); alb_noda (:,:,:) = spval
+ allocate (ssun_noda (2,2,numpatch)); ssun_noda (:,:,:) = spval
+ allocate (ssha_noda (2,2,numpatch)); ssha_noda (:,:,:) = spval
+ allocate (ssoi_noda (2,2,numpatch)); ssoi_noda (:,:,:) = spval
+ allocate (ssno_noda (2,2,numpatch)); ssno_noda (:,:,:) = spval
+ allocate (thermk_noda (numpatch)); thermk_noda (:) = spval
+ allocate (extkb_noda (numpatch)); extkb_noda (:) = spval
+ allocate (extkd_noda (numpatch)); extkd_noda (:) = spval
+ allocate (zwt_noda (numpatch)); zwt_noda (:) = spval
+ allocate (wdsrf_noda (numpatch)); wdsrf_noda (:) = spval
+ allocate (wa_noda (numpatch)); wa_noda (:) = spval
+ allocate (wetwat_noda (numpatch)); wetwat_noda (:) = spval
+ allocate (t_lake_noda (nl_lake,numpatch)); t_lake_noda (:,:) = spval
+ allocate (lake_icefrac_noda (nl_lake,numpatch)); lake_icefrac_noda(:,:) = spval
+ allocate (savedtke1_noda (numpatch)); savedtke1_noda (:) = spval
+
+ ! diagnostic variables for DA
+ allocate (h2osoi_noda (1:nl_soil,numpatch)); h2osoi_noda (:,:) = spval
+ allocate (tref_noda (numpatch)); tref_noda (:) = spval
+
+ ! allocate all time-varying state variables
+ allocate (z_sno_ens (maxsnl+1:0, DEF_DA_ENS_NUM,numpatch)); z_sno_ens (:,:,:) = spval
+ allocate (dz_sno_ens (maxsnl+1:0, DEF_DA_ENS_NUM,numpatch)); dz_sno_ens (:,:,:) = spval
+ allocate (t_soisno_ens (maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)); t_soisno_ens (:,:,:) = spval
+ allocate (wliq_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)); wliq_soisno_ens (:,:,:) = spval
+ allocate (wice_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch)); wice_soisno_ens (:,:,:) = spval
+ allocate (smp_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)); smp_ens (:,:,:) = spval
+ allocate (hk_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)); hk_ens (:,:,:) = spval
+ allocate (t_grnd_ens (DEF_DA_ENS_NUM,numpatch)); t_grnd_ens (:,:) = spval
+ allocate (tleaf_ens (DEF_DA_ENS_NUM,numpatch)); tleaf_ens (:,:) = spval
+ allocate (ldew_ens (DEF_DA_ENS_NUM,numpatch)); ldew_ens (:,:) = spval
+ allocate (ldew_rain_ens (DEF_DA_ENS_NUM,numpatch)); ldew_rain_ens (:,:) = spval
+ allocate (ldew_snow_ens (DEF_DA_ENS_NUM,numpatch)); ldew_snow_ens (:,:) = spval
+ allocate (fwet_snow_ens (DEF_DA_ENS_NUM,numpatch)); fwet_snow_ens (:,:) = spval
+ allocate (sag_ens (DEF_DA_ENS_NUM,numpatch)); sag_ens (:,:) = spval
+ allocate (scv_ens (DEF_DA_ENS_NUM,numpatch)); scv_ens (:,:) = spval
+ allocate (snowdp_ens (DEF_DA_ENS_NUM,numpatch)); snowdp_ens (:,:) = spval
+ allocate (fveg_ens (DEF_DA_ENS_NUM,numpatch)); fveg_ens (:,:) = spval
+ allocate (fsno_ens (DEF_DA_ENS_NUM,numpatch)); fsno_ens (:,:) = spval
+ allocate (sigf_ens (DEF_DA_ENS_NUM,numpatch)); sigf_ens (:,:) = spval
+ allocate (green_ens (DEF_DA_ENS_NUM,numpatch)); green_ens (:,:) = spval
+ allocate (tlai_ens (DEF_DA_ENS_NUM,numpatch)); tlai_ens (:,:) = spval
+ allocate (lai_ens (DEF_DA_ENS_NUM,numpatch)); lai_ens (:,:) = spval
+ allocate (tsai_ens (DEF_DA_ENS_NUM,numpatch)); tsai_ens (:,:) = spval
+ allocate (sai_ens (DEF_DA_ENS_NUM,numpatch)); sai_ens (:,:) = spval
+ allocate (alb_ens (2,2,DEF_DA_ENS_NUM,numpatch)); alb_ens (:,:,:,:) = spval
+ allocate (ssun_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssun_ens (:,:,:,:) = spval
+ allocate (ssha_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssha_ens (:,:,:,:) = spval
+ allocate (ssoi_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssoi_ens (:,:,:,:) = spval
+ allocate (ssno_ens (2,2,DEF_DA_ENS_NUM,numpatch)); ssno_ens (:,:,:,:) = spval
+ allocate (thermk_ens (DEF_DA_ENS_NUM,numpatch)); thermk_ens (:,:) = spval
+ allocate (extkb_ens (DEF_DA_ENS_NUM,numpatch)); extkb_ens (:,:) = spval
+ allocate (extkd_ens (DEF_DA_ENS_NUM,numpatch)); extkd_ens (:,:) = spval
+ allocate (zwt_ens (DEF_DA_ENS_NUM,numpatch)); zwt_ens (:,:) = spval
+ allocate (wdsrf_ens (DEF_DA_ENS_NUM,numpatch)); wdsrf_ens (:,:) = spval
+ allocate (wa_ens (DEF_DA_ENS_NUM,numpatch)); wa_ens (:,:) = spval
+ allocate (wetwat_ens (DEF_DA_ENS_NUM,numpatch)); wetwat_ens (:,:) = spval
+ allocate (t_lake_ens (nl_lake,DEF_DA_ENS_NUM,numpatch)); t_lake_ens (:,:,:) = spval
+ allocate (lake_icefrac_ens (nl_lake,DEF_DA_ENS_NUM,numpatch)); lake_icefrac_ens(:,:,:) = spval
+ allocate (savedtke1_ens (DEF_DA_ENS_NUM,numpatch)); savedtke1_ens (:,:) = spval
+
+ ! diagnostic variables for DA
+ allocate (h2osoi_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch)); h2osoi_ens (:,:,:) = spval
+ allocate (t_brt_smap_ens (2,DEF_DA_ENS_NUM,numpatch)); t_brt_smap_ens (:,:,:) = spval
+ allocate (t_brt_fy3d_ens (2,DEF_DA_ENS_NUM,numpatch)); t_brt_fy3d_ens (:,:,:) = spval
+ allocate (t_brt_smap (2,numpatch)); t_brt_smap (:,:) = spval
+ allocate (t_brt_fy3d (2,numpatch)); t_brt_fy3d (:,:) = spval
+ allocate (trad_ens (DEF_DA_ENS_NUM,numpatch)); trad_ens (:,:) = spval
+ allocate (tref_ens (DEF_DA_ENS_NUM,numpatch)); tref_ens (:,:) = spval
+ allocate (qref_ens (DEF_DA_ENS_NUM,numpatch)); qref_ens (:,:) = spval
+ allocate (rhref_ens (DEF_DA_ENS_NUM,numpatch)); rhref_ens (:,:) = spval
+ allocate (ustar_ens (DEF_DA_ENS_NUM,numpatch)); ustar_ens (:,:) = spval
+ allocate (qstar_ens (DEF_DA_ENS_NUM,numpatch)); qstar_ens (:,:) = spval
+ allocate (tstar_ens (DEF_DA_ENS_NUM,numpatch)); tstar_ens (:,:) = spval
+ allocate (fm_ens (DEF_DA_ENS_NUM,numpatch)); fm_ens (:,:) = spval
+ allocate (fh_ens (DEF_DA_ENS_NUM,numpatch)); fh_ens (:,:) = spval
+ allocate (fq_ens (DEF_DA_ENS_NUM,numpatch)); fq_ens (:,:) = spval
+
+ ! ensemble forcing variables used for ensemble DA
+ allocate (forc_t_ens (DEF_DA_ENS_NUM,numpatch)); forc_t_ens (:,:) = spval
+ allocate (forc_frl_ens (DEF_DA_ENS_NUM,numpatch)); forc_frl_ens (:,:) = spval
+ allocate (forc_prc_ens (DEF_DA_ENS_NUM,numpatch)); forc_prc_ens (:,:) = spval
+ allocate (forc_prl_ens (DEF_DA_ENS_NUM,numpatch)); forc_prl_ens (:,:) = spval
+ allocate (forc_sols_ens (DEF_DA_ENS_NUM,numpatch)); forc_sols_ens (:,:) = spval
+ allocate (forc_soll_ens (DEF_DA_ENS_NUM,numpatch)); forc_soll_ens (:,:) = spval
+ allocate (forc_solsd_ens (DEF_DA_ENS_NUM,numpatch)); forc_solsd_ens (:,:) = spval
+ allocate (forc_solld_ens (DEF_DA_ENS_NUM,numpatch)); forc_solld_ens (:,:) = spval
+
+ ! allocate variables for analysis increment
+ allocate (t_soisno_a (maxsnl+1:nl_soil,numpatch)); t_soisno_a (:,:) = spval
+ allocate (wliq_soisno_a (maxsnl+1:nl_soil,numpatch)); wliq_soisno_a (:,:) = spval
+ allocate (wice_soisno_a (maxsnl+1:nl_soil,numpatch)); wice_soisno_a (:,:) = spval
+ allocate (t_grnd_a (numpatch)); t_grnd_a (:) = spval
+ allocate (tleaf_a (numpatch)); tleaf_a (:) = spval
+ allocate (snowdp_a (numpatch)); snowdp_a (:) = spval
+ allocate (h2osoi_a (1:nl_soil,numpatch)); h2osoi_a (:,:) = spval
+ allocate (t_brt_smap_a (2,numpatch)); t_brt_smap_a (:,:) = spval
+ allocate (t_brt_fy3d_a (2,numpatch)); t_brt_fy3d_a (:,:) = spval
+
+ allocate (trad_a (numpatch)); trad_a (:) = spval
+ allocate (tref_a (numpatch)); tref_a (:) = spval
+ allocate (qref_a (numpatch)); qref_a (:) = spval
+ allocate (ustar_a (numpatch)); ustar_a (:) = spval
+ allocate (qstar_a (numpatch)); qstar_a (:) = spval
+ allocate (tstar_a (numpatch)); tstar_a (:) = spval
+ allocate (fm_a (numpatch)); fm_a (:) = spval
+ allocate (fh_a (numpatch)); fh_a (:) = spval
+ allocate (fq_a (numpatch)); fq_a (:) = spval
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE allocate_DATimeVariables
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE deallocate_DATimeVariables()
+
+!-----------------------------------------------------------------------------
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+!-----------------------------------------------------------------------------
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ deallocate (z_sno_noda )
+ deallocate (dz_sno_noda )
+ deallocate (t_soisno_noda )
+ deallocate (wliq_soisno_noda )
+ deallocate (wice_soisno_noda )
+ deallocate (smp_noda )
+ deallocate (hk_noda )
+ deallocate (t_grnd_noda )
+ deallocate (tleaf_noda )
+ deallocate (ldew_noda )
+ deallocate (ldew_rain_noda )
+ deallocate (ldew_snow_noda )
+ deallocate (fwet_snow_noda )
+ deallocate (sag_noda )
+ deallocate (scv_noda )
+ deallocate (snowdp_noda )
+ deallocate (fveg_noda )
+ deallocate (fsno_noda )
+ deallocate (sigf_noda )
+ deallocate (green_noda )
+ deallocate (tlai_noda )
+ deallocate (lai_noda )
+ deallocate (tsai_noda )
+ deallocate (sai_noda )
+ deallocate (alb_noda )
+ deallocate (ssun_noda )
+ deallocate (ssha_noda )
+ deallocate (ssoi_noda )
+ deallocate (ssno_noda )
+ deallocate (thermk_noda )
+ deallocate (extkb_noda )
+ deallocate (extkd_noda )
+ deallocate (zwt_noda )
+ deallocate (wdsrf_noda )
+ deallocate (wa_noda )
+ deallocate (wetwat_noda )
+ deallocate (t_lake_noda )
+ deallocate (lake_icefrac_noda )
+ deallocate (savedtke1_noda )
+
+ deallocate (tref_noda )
+ deallocate (h2osoi_noda )
+
+ deallocate (z_sno_ens )
+ deallocate (dz_sno_ens )
+ deallocate (t_soisno_ens )
+ deallocate (wliq_soisno_ens )
+ deallocate (wice_soisno_ens )
+ deallocate (smp_ens )
+ deallocate (hk_ens )
+ deallocate (t_grnd_ens )
+ deallocate (tleaf_ens )
+ deallocate (ldew_ens )
+ deallocate (ldew_rain_ens )
+ deallocate (ldew_snow_ens )
+ deallocate (fwet_snow_ens )
+ deallocate (sag_ens )
+ deallocate (scv_ens )
+ deallocate (snowdp_ens )
+ deallocate (fveg_ens )
+ deallocate (fsno_ens )
+ deallocate (sigf_ens )
+ deallocate (green_ens )
+ deallocate (tlai_ens )
+ deallocate (lai_ens )
+ deallocate (tsai_ens )
+ deallocate (sai_ens )
+ deallocate (alb_ens )
+ deallocate (ssun_ens )
+ deallocate (ssha_ens )
+ deallocate (ssoi_ens )
+ deallocate (ssno_ens )
+ deallocate (thermk_ens )
+ deallocate (extkb_ens )
+ deallocate (extkd_ens )
+ deallocate (zwt_ens )
+ deallocate (wdsrf_ens )
+ deallocate (wa_ens )
+ deallocate (wetwat_ens )
+ deallocate (t_lake_ens )
+ deallocate (lake_icefrac_ens )
+ deallocate (savedtke1_ens )
+
+ deallocate (h2osoi_ens )
+ deallocate (t_brt_smap_ens )
+ deallocate (t_brt_fy3d_ens )
+ deallocate (t_brt_smap )
+ deallocate (t_brt_fy3d )
+ deallocate (trad_ens )
+ deallocate (tref_ens )
+ deallocate (qref_ens )
+ deallocate (rhref_ens )
+ deallocate (ustar_ens )
+ deallocate (qstar_ens )
+ deallocate (tstar_ens )
+ deallocate (fm_ens )
+ deallocate (fh_ens )
+ deallocate (fq_ens )
+
+ deallocate (forc_t_ens )
+ deallocate (forc_frl_ens )
+ deallocate (forc_prc_ens )
+ deallocate (forc_prl_ens )
+ deallocate (forc_sols_ens )
+ deallocate (forc_soll_ens )
+ deallocate (forc_solsd_ens )
+ deallocate (forc_solld_ens )
+
+ deallocate (t_soisno_a )
+ deallocate (wliq_soisno_a )
+ deallocate (wice_soisno_a )
+ deallocate (t_grnd_a )
+ deallocate (tleaf_a )
+ deallocate (snowdp_a )
+ deallocate (h2osoi_a )
+ deallocate (t_brt_smap_a )
+ deallocate (t_brt_fy3d_a )
+ deallocate (trad_a )
+ deallocate (tref_a )
+ deallocate (qref_a )
+ deallocate (ustar_a )
+ deallocate (qstar_a )
+ deallocate (tstar_a )
+ deallocate (fm_a )
+ deallocate (fh_a )
+ deallocate (fq_a )
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE deallocate_DATimeVariables
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE WRITE_DATimeVariables (idate, lc_year, site, dir_restart)
+
+!-----------------------------------------------------------------------------
+ USE MOD_SPMD_Task
+ USE MOD_Namelist, only : DEF_REST_CompressLevel, DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, &
+ DEF_USE_IRRIGATION, DEF_USE_Dynamic_Lake
+ USE MOD_LandPatch
+ USE MOD_NetCDFVector
+ USE MOD_Vars_Global
+ IMPLICIT NONE
+
+!------------------------ Dummy Arguments ------------------------------------
+ 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=14) :: cdate
+ character(len=256) :: cyear ! character for lc_year
+ integer :: compress
+ integer :: i
+
+!-----------------------------------------------------------------------------
+ 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 (p_is_root) THEN
+ CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate))
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_DA_'//trim(cdate)//'_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, '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, 'band', 2)
+ CALL ncio_define_dimension_vector (file_restart, landpatch, 'rtyp', 2)
+ CALL ncio_define_dimension_vector (file_restart, landpatch, 'ens', DEF_DA_ENS_NUM)
+
+ ! Time-varying state variables which reaquired by restart run
+ CALL ncio_write_vector (file_restart, 'z_sno ' , 'snow', -maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, z_sno_ens, compress) ! node depth [m]
+ CALL ncio_write_vector (file_restart, 'dz_sno ' , 'snow', -maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, dz_sno_ens, compress) ! interface depth [m]
+ CALL ncio_write_vector (file_restart, 't_soisno' , 'soilsnow', nl_soil-maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, t_soisno_ens, compress) ! soil temperature [K]
+ CALL ncio_write_vector (file_restart, 'wliq_soisno', 'soilsnow', nl_soil-maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wliq_soisno_ens, compress) ! liquid water in layers [kg/m2]
+ CALL ncio_write_vector (file_restart, 'wice_soisno', 'soilsnow', nl_soil-maxsnl, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wice_soisno_ens, compress) ! ice lens in layers [kg/m2]
+ CALL ncio_write_vector (file_restart, 'smp', 'soil', nl_soil, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, smp_ens, compress) ! soil matrix potential [mm]
+ CALL ncio_write_vector (file_restart, 'hk', 'soil', nl_soil, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, hk_ens, compress) ! hydraulic conductivity [mm h2o/s]
+ CALL ncio_write_vector (file_restart, 't_grnd', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, t_grnd_ens, compress) ! ground surface temperature [K]
+ CALL ncio_write_vector (file_restart, 'tleaf', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, tleaf_ens, compress) ! leaf temperature [K]
+ CALL ncio_write_vector (file_restart, 'ldew', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ldew_ens, compress) ! depth of water on foliage [mm]
+ CALL ncio_write_vector (file_restart, 'ldew_rain', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ldew_rain_ens, compress) ! depth of water on foliage [mm]
+ CALL ncio_write_vector (file_restart, 'ldew_snow', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ldew_snow_ens, compress) ! depth of water on foliage [mm]
+ CALL ncio_write_vector (file_restart, 'fwet_snow', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, fwet_snow_ens, compress) ! vegetation snow fractional cover [-]
+ CALL ncio_write_vector (file_restart, 'sag', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, sag_ens, compress) ! non dimensional snow age [-]
+ CALL ncio_write_vector (file_restart, 'scv', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, scv_ens, compress) ! snow cover, water equivalent [mm]
+ CALL ncio_write_vector (file_restart, 'snowdp', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, snowdp_ens, compress) ! snow depth [meter]
+ CALL ncio_write_vector (file_restart, 'fveg', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, fveg_ens, compress) ! fraction of vegetation cover
+ CALL ncio_write_vector (file_restart, 'fsno', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, fsno_ens, compress) ! fraction of snow cover on ground
+ CALL ncio_write_vector (file_restart, 'sigf', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, sigf_ens, compress) ! fraction of veg cover, excluding snow-covered veg [-]
+ CALL ncio_write_vector (file_restart, 'green', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, green_ens, compress) ! leaf greenness
+ CALL ncio_write_vector (file_restart, 'tlai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, tlai_ens, compress) ! leaf area index
+ CALL ncio_write_vector (file_restart, 'lai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, lai_ens, compress) ! leaf area index
+ CALL ncio_write_vector (file_restart, 'tsai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, tsai_ens, compress) ! stem area index
+ CALL ncio_write_vector (file_restart, 'sai', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, sai_ens, compress) ! stem area index
+ CALL ncio_write_vector (file_restart, 'alb', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, alb_ens, compress) ! averaged albedo [-]
+ CALL ncio_write_vector (file_restart, 'ssun', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssun_ens, compress) ! sunlit canopy absorption for solar radiation (0-1)
+ CALL ncio_write_vector (file_restart, 'ssha', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssha_ens, compress) ! shaded canopy absorption for solar radiation (0-1)
+ CALL ncio_write_vector (file_restart, 'ssoi', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssoi_ens, compress) ! shaded canopy absorption for solar radiation (0-1)
+ CALL ncio_write_vector (file_restart, 'ssno', 'band', 2, 'rtyp', 2, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, ssno_ens, compress) ! shaded canopy absorption for solar radiation (0-1)
+ CALL ncio_write_vector (file_restart, 'thermk', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, thermk_ens, compress) ! canopy gap fraction for tir radiation
+ CALL ncio_write_vector (file_restart, 'extkb', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, extkb_ens, compress) ! (k, g(mu)/mu) direct solar extinction coefficient
+ CALL ncio_write_vector (file_restart, 'extkd', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, extkd_ens, compress) ! diffuse and scattered diffuse PAR extinction coefficient
+ CALL ncio_write_vector (file_restart, 'zwt', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, zwt_ens, compress) ! the depth to water table [m]
+ CALL ncio_write_vector (file_restart, 'wdsrf', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wdsrf_ens, compress) ! depth of surface water [mm]
+ CALL ncio_write_vector (file_restart, 'wa', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wa_ens, compress) ! water storage in aquifer [mm]
+ CALL ncio_write_vector (file_restart, 'wetwat', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, wetwat_ens, compress) ! water storage in wetland [mm]
+ CALL ncio_write_vector (file_restart, 't_lake', 'lake', nl_lake, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, t_lake_ens, compress)
+ CALL ncio_write_vector (file_restart, 'lake_icefrc', 'lake', nl_lake, 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, lake_icefrac_ens, compress)
+ CALL ncio_write_vector (file_restart, 'savedtke1', 'ens', DEF_DA_ENS_NUM, 'patch', landpatch, savedtke1_ens, compress)
+
+ END SUBROUTINE WRITE_DATimeVariables
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE READ_DATimeVariables (idate, lc_year, site, dir_restart)
+
+!-----------------------------------------------------------------------------
+ USE MOD_Namelist
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFVector
+#ifdef RangeCheck
+ USE MOD_RangeCheck
+#endif
+ USE MOD_LandPatch
+ USE MOD_Vars_Global
+ IMPLICIT NONE
+
+!------------------------ Dummy Arguments ------------------------------------
+ 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=14) :: cdate, cyear
+
+!-----------------------------------------------------------------------------
+#ifdef USEMPI
+ CALL mpi_barrier(p_comm_glb, p_err)
+#endif
+
+ IF (p_is_root) THEN
+ write (*, *) 'Loading DA Time Variables ...'
+ END IF
+
+ ! 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_DA_'//trim(cdate)//'_lc'//trim(cyear)//'.nc'
+
+ ! Time-varying state variables which reaquired by restart run
+ CALL ncio_read_vector(file_restart, 'z_sno ', -maxsnl, DEF_DA_ENS_NUM, landpatch, z_sno_ens) ! node depth [m]
+ CALL ncio_read_vector(file_restart, 'dz_sno ', -maxsnl, DEF_DA_ENS_NUM, landpatch, dz_sno_ens) ! interface depth [m]
+ CALL ncio_read_vector(file_restart, 't_soisno', nl_soil - maxsnl, DEF_DA_ENS_NUM, landpatch, t_soisno_ens) ! soil temperature [K]
+ CALL ncio_read_vector(file_restart, 'wliq_soisno', nl_soil - maxsnl, DEF_DA_ENS_NUM, landpatch, wliq_soisno_ens)! liquid water in layers [kg/m2]
+ CALL ncio_read_vector(file_restart, 'wice_soisno', nl_soil - maxsnl, DEF_DA_ENS_NUM, landpatch, wice_soisno_ens)! ice lens in layers [kg/m2]
+ CALL ncio_read_vector(file_restart, 'smp', nl_soil, DEF_DA_ENS_NUM, landpatch, smp_ens) ! soil matrix potential [mm]
+ CALL ncio_read_vector(file_restart, 'hk', nl_soil, DEF_DA_ENS_NUM, landpatch, hk_ens) ! hydraulic conductivity [mm h2o/s]
+ CALL ncio_read_vector(file_restart, 't_grnd ', DEF_DA_ENS_NUM, landpatch, t_grnd_ens) ! ground surface temperature [K]
+ CALL ncio_read_vector(file_restart, 'tleaf ', DEF_DA_ENS_NUM, landpatch, tleaf_ens) ! leaf temperature [K]
+ CALL ncio_read_vector(file_restart, 'ldew ', DEF_DA_ENS_NUM, landpatch, ldew_ens) ! depth of water on foliage [mm]
+ CALL ncio_read_vector(file_restart, 'ldew_rain', DEF_DA_ENS_NUM, landpatch, ldew_rain_ens) ! depth of water on foliage [mm]
+ CALL ncio_read_vector(file_restart, 'ldew_snow', DEF_DA_ENS_NUM, landpatch, ldew_snow_ens) ! depth of water on foliage [mm]
+ CALL ncio_read_vector(file_restart, 'fwet_snow', DEF_DA_ENS_NUM, landpatch, fwet_snow_ens) ! vegetation snow fractional cover [-]
+ CALL ncio_read_vector(file_restart, 'sag ', DEF_DA_ENS_NUM, landpatch, sag_ens) ! non dimensional snow age [-]
+ CALL ncio_read_vector(file_restart, 'scv ', DEF_DA_ENS_NUM, landpatch, scv_ens) ! snow cover, water equivalent [mm]
+ CALL ncio_read_vector(file_restart, 'snowdp ', DEF_DA_ENS_NUM, landpatch, snowdp_ens) ! snow depth [meter]
+ CALL ncio_read_vector(file_restart, 'fveg ', DEF_DA_ENS_NUM, landpatch, fveg_ens) ! fraction of vegetation cover
+ CALL ncio_read_vector(file_restart, 'fsno ', DEF_DA_ENS_NUM, landpatch, fsno_ens) ! fraction of snow cover on ground
+ CALL ncio_read_vector(file_restart, 'sigf ', DEF_DA_ENS_NUM, landpatch, sigf_ens) ! fraction of veg cover, excluding snow-covered veg [-]
+ CALL ncio_read_vector(file_restart, 'green ', DEF_DA_ENS_NUM, landpatch, green_ens) ! leaf greenness
+ CALL ncio_read_vector(file_restart, 'lai ', DEF_DA_ENS_NUM, landpatch, lai_ens) ! leaf area index
+ CALL ncio_read_vector(file_restart, 'tlai ', DEF_DA_ENS_NUM, landpatch, tlai_ens) ! leaf area index
+ CALL ncio_read_vector(file_restart, 'sai ', DEF_DA_ENS_NUM, landpatch, sai_ens) ! stem area index
+ CALL ncio_read_vector(file_restart, 'tsai ', DEF_DA_ENS_NUM, landpatch, tsai_ens) ! stem area index
+ CALL ncio_read_vector(file_restart, 'alb ', 2, 2, DEF_DA_ENS_NUM, landpatch, alb_ens) ! averaged albedo [-]
+ CALL ncio_read_vector(file_restart, 'ssun ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssun_ens) ! sunlit canopy absorption for solar radiation (0-1)
+ CALL ncio_read_vector(file_restart, 'ssha ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssha_ens) ! shaded canopy absorption for solar radiation (0-1)
+ CALL ncio_read_vector(file_restart, 'ssoi ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssoi_ens) ! soil absorption for solar radiation (0-1)
+ CALL ncio_read_vector(file_restart, 'ssno ', 2, 2, DEF_DA_ENS_NUM, landpatch, ssno_ens) ! snow absorption for solar radiation (0-1)
+ CALL ncio_read_vector(file_restart, 'thermk ', DEF_DA_ENS_NUM, landpatch, thermk_ens) ! canopy gap fraction for tir radiation
+ CALL ncio_read_vector(file_restart, 'extkb ', DEF_DA_ENS_NUM, landpatch, extkb_ens) ! (k, g(mu)/mu) direct solar extinction coefficient
+ CALL ncio_read_vector(file_restart, 'extkd ', DEF_DA_ENS_NUM, landpatch, extkd_ens) ! diffuse and scattered diffuse PAR extinction coefficient
+ CALL ncio_read_vector(file_restart, 'zwt ', DEF_DA_ENS_NUM, landpatch, zwt_ens) ! the depth to water table [m]
+ CALL ncio_read_vector(file_restart, 'wdsrf ', DEF_DA_ENS_NUM, landpatch, wdsrf_ens) ! depth of surface water [mm]
+ CALL ncio_read_vector(file_restart, 'wa ', DEF_DA_ENS_NUM, landpatch, wa_ens) ! water storage in aquifer [mm]
+ CALL ncio_read_vector(file_restart, 'wetwat ', DEF_DA_ENS_NUM, landpatch, wetwat_ens) ! water storage in wetland [mm]
+ CALL ncio_read_vector(file_restart, 't_lake ', nl_lake, DEF_DA_ENS_NUM, landpatch, t_lake_ens) ! lake temperature [K]
+ CALL ncio_read_vector(file_restart, 'lake_icefrc', nl_lake, DEF_DA_ENS_NUM, landpatch, lake_icefrac_ens) ! lake ice fraction [-]
+ CALL ncio_read_vector(file_restart, 'savedtke1 ', DEF_DA_ENS_NUM, landpatch, savedtke1_ens) ! saved tke1 [m2/s2]
+
+#ifdef RangeCheck
+ CALL check_DATimeVariables
+#endif
+
+ IF (p_is_root) THEN
+ write (*, *) 'Loading DA Time Variables done.'
+ END IF
+
+ END SUBROUTINE READ_DATimeVariables
+
+#ifdef RangeCheck
+!-----------------------------------------------------------------------
+
+ SUBROUTINE check_DATimeVariables ()
+
+!-----------------------------------------------------------------------
+ USE MOD_SPMD_Task
+ USE MOD_RangeCheck
+ USE MOD_Namelist, only: DEF_USE_PLANTHYDRAULICS, DEF_USE_OZONESTRESS, DEF_USE_IRRIGATION, &
+ DEF_USE_SNICAR, DEF_USE_Dynamic_Lake
+ IMPLICIT NONE
+
+#ifdef USEMPI
+ CALL mpi_barrier(p_comm_glb, p_err)
+#endif
+ IF (p_is_root) THEN
+ write (*, *) 'Checking DA Time Variables ...'
+ END IF
+
+ CALL check_vector_data ('z_sno [m] ', z_sno_ens ) ! node depth [m]
+ CALL check_vector_data ('dz_sno [m] ', dz_sno_ens ) ! interface depth [m]
+ CALL check_vector_data ('t_soisno [K] ', t_soisno_ens ) ! soil temperature [K]
+ CALL check_vector_data ('wliq_soisno [kg/m2]', wliq_soisno_ens ) ! liquid water in layers [kg/m2]
+ CALL check_vector_data ('wice_soisno [kg/m2]', wice_soisno_ens ) ! ice lens in layers [kg/m2]
+ CALL check_vector_data ('smp [mm] ', smp_ens ) ! soil matrix potential [mm]
+ CALL check_vector_data ('hk [mm/s] ', hk_ens ) ! hydraulic conductivity [mm h2o/s]
+ CALL check_vector_data ('t_grnd [K] ', t_grnd_ens ) ! ground surface temperature [K]
+ CALL check_vector_data ('tleaf [K] ', tleaf_ens ) ! leaf temperature [K]
+ CALL check_vector_data ('ldew [mm] ', ldew_ens ) ! depth of water on foliage [mm]
+ CALL check_vector_data ('ldew_rain [mm] ', ldew_rain_ens ) ! depth of rain on foliage [mm]
+ CALL check_vector_data ('ldew_snow [mm] ', ldew_snow_ens ) ! depth of snow on foliage [mm]
+ CALL check_vector_data ('fwet_snow [mm] ', fwet_snow_ens ) ! vegetation snow fractional cover [-]
+ CALL check_vector_data ('sag [-] ', sag_ens ) ! non dimensional snow age [-]
+ CALL check_vector_data ('scv [mm] ', scv_ens ) ! snow cover, water equivalent [mm]
+ CALL check_vector_data ('snowdp [m] ', snowdp_ens ) ! snow depth [meter]
+ CALL check_vector_data ('fveg [-] ', fveg_ens ) ! fraction of vegetation cover
+ CALL check_vector_data ('fsno [-] ', fsno_ens ) ! fraction of snow cover on ground
+ CALL check_vector_data ('sigf [-] ', sigf_ens ) ! fraction of veg cover, excluding snow-covered veg [-]
+ CALL check_vector_data ('green [-] ', green_ens ) ! leaf greenness
+ CALL check_vector_data ('lai [-] ', lai_ens ) ! leaf area index
+ CALL check_vector_data ('tlai [-] ', tlai_ens ) ! leaf area index
+ CALL check_vector_data ('sai [-] ', sai_ens ) ! stem area index
+ CALL check_vector_data ('tsai [-] ', tsai_ens ) ! stem area index
+ CALL check_vector_data ('alb [-] ', alb_ens ) ! averaged albedo [-]
+ CALL check_vector_data ('ssun [-] ', ssun_ens ) ! sunlit canopy absorption for solar radiation (0-1)
+ CALL check_vector_data ('ssha [-] ', ssha_ens ) ! shaded canopy absorption for solar radiation (0-1)
+ CALL check_vector_data ('ssoi [-] ', ssoi_ens ) ! soil absorption for solar radiation (0-1)
+ CALL check_vector_data ('ssno [-] ', ssno_ens ) ! snow absorption for solar radiation (0-1)
+ CALL check_vector_data ('thermk [-] ', thermk_ens ) ! canopy gap fraction for tir radiation
+ CALL check_vector_data ('extkb [-] ', extkb_ens ) ! (k, g(mu)/mu) direct solar extinction coefficient
+ CALL check_vector_data ('extkd [-] ', extkd_ens ) ! diffuse and scattered diffuse PAR extinction coefficient
+ CALL check_vector_data ('zwt [m] ', zwt_ens ) ! the depth to water table [m]
+ CALL check_vector_data ('wdsrf [mm] ', wdsrf_ens ) ! depth of surface water [mm]
+ CALL check_vector_data ('wa [mm] ', wa_ens ) ! water storage in aquifer [mm]
+ CALL check_vector_data ('wetwat [mm] ', wetwat_ens ) ! water storage in wetland [mm]
+ CALL check_vector_data ('t_lake [K] ', t_lake_ens ) ! lake temperature [K]
+ CALL check_vector_data ('lake_icefrc [-] ', lake_icefrac_ens) ! lake ice fraction [-]
+ CALL check_vector_data ('savedtke1 [W/m K]', savedtke1_ens ) ! saved tke1 [m2/s2]
+
+#ifdef USEMPI
+ CALL mpi_barrier(p_comm_glb, p_err)
+#endif
+
+ END SUBROUTINE check_DATimeVariables
+!-----------------------------------------------------------------------------
+#endif
+
+END MODULE MOD_DA_Vars_TimeVariables
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90
new file mode 100644
index 0000000000..5a864c2a8b
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_BasinNetwork.F90
@@ -0,0 +1,494 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_BasinNetwork
+!--------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Created by Shupeng Zhang, Feb 2025
+!--------------------------------------------------------------------------------
+
+ USE MOD_Pixelset
+ USE MOD_ComputePushData
+ IMPLICIT NONE
+
+ ! -- instances --
+ integer :: numbasin
+ integer, allocatable :: basinindex(:)
+
+ integer :: numbsnhru
+ type(subset_type) :: basin_hru
+
+ integer :: numrivmth
+ integer, allocatable :: rivermouth(:)
+
+ integer :: numlake, numresv
+ integer, allocatable :: lake_id (:)
+ integer, allocatable :: lake_type(:) ! lake type:
+ ! 0: not lake; 1: natural lake;
+ ! 2: reservoir; 3: controlled lake.
+ integer, allocatable :: bsn2lake (:)
+ integer, allocatable :: bsn2resv (:)
+
+ type(compute_pushdata_type) :: push_elm2bsn
+ type(compute_pushdata_type) :: push_bsn2elm
+
+ type(compute_pushdata_type) :: push_elmhru2bsnhru
+ type(compute_pushdata_type) :: push_bsnhru2elmhru
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE build_basin_network ()
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Utils
+ USE MOD_NetCDFSerial
+ USE MOD_Mesh, only: numelm
+ USE MOD_LandElm, only: landelm
+ USE MOD_LandHRU, only: elm_hru
+ IMPLICIT NONE
+
+ ! Local Variables
+ character(len=256) :: basin_file
+ integer, allocatable :: basindown(:)
+
+ integer, allocatable :: nups_nst(:), iups_nst(:), nups_all(:), b_up2down(:), orderbsn(:)
+
+ integer , allocatable :: nb_rs(:), irank_rs(:), nrank_rs(:), nave_rs(:), nb_rank(:)
+ real(r8), allocatable :: wtbsn(:), wt_rs (:), wt_rank (:)
+
+ integer :: totalnumbasin, ibasin, nbasin, iriv
+ integer :: irank, irankdsp, mesg(2), isrc, nrecv
+ integer :: iloc, i, j, ithis
+ real(r8) :: sumwt
+
+ integer, allocatable :: bindex(:), addrbasin(:), elmindex(:)
+
+ ! lake and reservoir
+ character(len=256) :: lake_info_file
+ integer, allocatable :: all_lake_id (:), all_lake_type (:), order(:), icache(:)
+ integer, allocatable :: lake_id_resv(:), lake_type_resv(:)
+ integer :: ilake, iresv
+
+
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ basin_file = DEF_CatchmentMesh_data
+
+ ! read in parameters from file.
+ IF (p_is_root) THEN
+ CALL ncio_read_serial (basin_file, 'basin_downstream', basindown)
+ totalnumbasin = size(basindown)
+ ENDIF
+
+#ifdef USEMPI
+ ! divide basins into groups and assign to ranks
+ IF (p_is_root) THEN
+
+ IF (ncio_var_exist(basin_file, 'weightbasin')) THEN
+ CALL ncio_read_serial (basin_file, 'weightbasin', wtbsn)
+ ELSE
+ allocate (wtbsn (totalnumbasin)); wtbsn(:) = 1.
+ ENDIF
+
+ ! sort basins from up to down, recorded by "b_up2down"
+
+ allocate (nups_nst (totalnumbasin)); nups_nst(:) = 0
+ allocate (iups_nst (totalnumbasin)); iups_nst(:) = 0
+ allocate (b_up2down(totalnumbasin))
+
+ DO i = 1, totalnumbasin
+ j = basindown(i)
+ IF (j > 0) THEN
+ nups_nst(j) = nups_nst(j) + 1
+ ENDIF
+ ENDDO
+
+ ithis = 0
+ DO i = 1, totalnumbasin
+ IF (iups_nst(i) == nups_nst(i)) THEN
+
+ ithis = ithis + 1
+ b_up2down(ithis) = i
+ iups_nst(i) = -1
+
+ j = basindown(i)
+ DO WHILE (j > 0)
+
+ iups_nst(j) = iups_nst(j) + 1
+
+ IF (iups_nst(j) == nups_nst(j)) THEN
+ ithis = ithis + 1
+ b_up2down(ithis) = j
+ iups_nst(j) = -1
+
+ j = basindown(j)
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ deallocate (nups_nst)
+ deallocate (iups_nst)
+
+ allocate (rivermouth (totalnumbasin))
+ numrivmth = 0
+ DO i = totalnumbasin, 1, -1
+ j = basindown(b_up2down(i))
+ IF (j <= 0) THEN
+ numrivmth = numrivmth + 1
+ rivermouth(b_up2down(i)) = numrivmth
+ ELSE
+ rivermouth(b_up2down(i)) = rivermouth(j)
+ ENDIF
+ ENDDO
+
+ allocate (nb_rs (numrivmth)); nb_rs(:) = 0
+ allocate (wt_rs (numrivmth)); wt_rs(:) = 0
+ DO i = 1, totalnumbasin
+ nb_rs(rivermouth(i)) = nb_rs(rivermouth(i)) + 1
+ wt_rs(rivermouth(i)) = wt_rs(rivermouth(i)) + wtbsn(i)
+ ENDDO
+
+ sumwt = sum(wt_rs)
+
+ allocate (irank_rs (numrivmth))
+ allocate (nrank_rs (numrivmth))
+ allocate (nave_rs (numrivmth))
+
+ irankdsp = -1
+ DO i = 1, numrivmth
+ nrank_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute)
+ IF (nrank_rs(i) > 1) THEN
+
+ nave_rs(i) = nb_rs(i) / nrank_rs(i)
+ IF (mod(nb_rs(i), nrank_rs(i)) /= 0) THEN
+ nave_rs(i) = nave_rs(i) + 1
+ ENDIF
+
+ irank_rs(i) = irankdsp + 1
+ irankdsp = irankdsp + nrank_rs(i)
+ ENDIF
+ ENDDO
+
+ allocate (nups_all (totalnumbasin)); nups_all(:) = 1
+
+ DO i = 1, totalnumbasin
+ j = basindown(b_up2down(i))
+ IF (j > 0) THEN
+ nups_all(j) = nups_all(j) + nups_all(b_up2down(i))
+ ENDIF
+ ENDDO
+
+ allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1
+
+ allocate (wt_rank (0:p_np_compute-1)); wt_rank(:) = 0
+ allocate (nb_rank (0:p_np_compute-1)); nb_rank(:) = 0
+
+ allocate (orderbsn(totalnumbasin))
+ orderbsn(b_up2down) = (/(i, i = 1, totalnumbasin)/)
+
+ ithis = totalnumbasin
+ DO WHILE (ithis > 0)
+
+ i = b_up2down(ithis)
+
+ IF (addrbasin(i) >= 0) THEN
+ ithis = ithis - 1
+ CYCLE
+ ENDIF
+
+ j = basindown(i)
+ IF (j > 0) THEN
+ IF (addrbasin(j) >= 0) THEN
+ addrbasin(i) = addrbasin(j)
+ ithis = ithis - 1
+ CYCLE
+ ENDIF
+ ENDIF
+
+ iriv = rivermouth(i)
+ IF (nrank_rs(iriv) > 1) THEN
+ irank = irank_rs(iriv)
+ IF (nups_all(i) <= nave_rs(iriv)-nb_rank(irank)) THEN
+
+ addrbasin(i) = p_address_compute(irank)
+
+ nb_rank(irank) = nb_rank(irank) + nups_all(i)
+ IF (nb_rank(irank) == nave_rs(iriv)) THEN
+ irank_rs(iriv) = irank_rs(iriv) + 1
+ ENDIF
+
+ j = basindown(i)
+ IF (j > 0) THEN
+ DO WHILE (j > 0)
+ nups_all(j) = nups_all(j) - nups_all(i)
+ ithis = orderbsn(j)
+ j = basindown(j)
+ ENDDO
+ ELSE
+ ithis = ithis - 1
+ ENDIF
+ ELSE
+ ithis = ithis - 1
+ ENDIF
+ ELSE
+ irank = minloc(wt_rank(irankdsp+1:p_np_compute-1), dim=1) + irankdsp
+
+ addrbasin(i) = p_address_compute(irank)
+
+ wt_rank(irank) = wt_rank(irank) + wt_rs(iriv)
+ ithis = ithis - 1
+ ENDIF
+
+ ENDDO
+
+ deallocate (basindown)
+ deallocate (wtbsn )
+ deallocate (b_up2down)
+ deallocate (nups_all )
+ deallocate (orderbsn )
+ deallocate (nb_rs )
+ deallocate (wt_rs )
+ deallocate (irank_rs )
+ deallocate (nrank_rs )
+ deallocate (nave_rs )
+ deallocate (wt_rank )
+ deallocate (nb_rank )
+
+ ENDIF
+
+
+ ! send basin index to ranks
+ IF (p_is_root) THEN
+
+ allocate(basinindex (totalnumbasin))
+ basinindex = (/(i, i = 1, totalnumbasin)/)
+
+ DO irank = 0, p_np_compute-1
+
+ nbasin = count(addrbasin == p_address_compute(irank))
+ CALL mpi_send (nbasin, 1, MPI_INTEGER, p_address_compute(irank), mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (nbasin > 0) THEN
+ allocate (bindex (nbasin))
+
+ bindex = pack(basinindex, mask = (addrbasin == p_address_compute(irank)))
+ CALL mpi_send (bindex, nbasin, MPI_INTEGER, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (bindex)
+ ENDIF
+
+ ENDDO
+
+ deallocate (basinindex)
+
+ ELSEIF (p_is_compute) THEN
+
+ CALL mpi_recv (numbasin, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ IF (numbasin > 0) THEN
+
+ allocate (basinindex (numbasin))
+ CALL mpi_recv (basinindex, numbasin, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ ENDIF
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ numbasin = totalnumbasin
+ allocate(basinindex (totalnumbasin))
+ basinindex = (/(i, i = 1, totalnumbasin)/)
+#endif
+
+
+ IF (p_is_compute) THEN
+ IF (numelm > 0) THEN
+ allocate (elmindex (numelm))
+ elmindex = landelm%eindex
+ ENDIF
+ ENDIF
+
+ CALL build_compute_pushdata (numelm, elmindex, numbasin, basinindex, push_elm2bsn)
+ CALL build_compute_pushdata (numbasin, basinindex, numelm, elmindex, push_bsn2elm)
+
+ CALL build_compute_pushdata_subset ( &
+ numelm, numbasin, push_elm2bsn, elm_hru, push_elmhru2bsnhru, basin_hru, numbsnhru)
+
+ CALL build_compute_pushdata_subset ( &
+ numbasin, numelm, push_bsn2elm, basin_hru, push_bsnhru2elmhru)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (allocated(addrbasin)) deallocate(addrbasin)
+ IF (allocated(elmindex )) deallocate(elmindex )
+
+
+ IF (p_is_root) THEN
+
+ lake_info_file = DEF_CatchmentMesh_data
+ CALL ncio_read_serial (lake_info_file, 'lake_id', all_lake_id)
+
+ lake_info_file = trim(DEF_dir_runtime)//'/HydroLAKES_Reservoir.nc'
+ CALL ncio_read_serial (lake_info_file, 'hylak_id', lake_id_resv )
+ CALL ncio_read_serial (lake_info_file, 'lake_type', lake_type_resv)
+
+ allocate (order (size(lake_id_resv)))
+ order = (/(iresv, iresv=1,size(lake_id_resv))/)
+
+ CALL quicksort (size(lake_id_resv), lake_id_resv, order)
+
+ lake_type_resv = lake_type_resv(order)
+
+ allocate (all_lake_type (size(all_lake_id)))
+ all_lake_type(:) = 0
+
+ DO ibasin = 1, size(all_lake_id)
+ IF (all_lake_id(ibasin) > 0) THEN
+ all_lake_type(ibasin) = 1
+ iresv = find_in_sorted_list1 (all_lake_id(ibasin), size(lake_id_resv), lake_id_resv)
+ IF (iresv > 0) THEN
+ all_lake_type(ibasin) = lake_type_resv(iresv)
+ ENDIF
+ ENDIF
+ ENDDO
+
+ deallocate (lake_id_resv )
+ deallocate (lake_type_resv)
+ deallocate (order)
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numbasin > 0) THEN
+ allocate (lake_id (numbasin)); lake_id (:) = 0
+ allocate (lake_type (numbasin)); lake_type(:) = 0
+ ENDIF
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+ IF (p_is_compute) THEN
+ mesg = (/p_iam_glb, numbasin/)
+ CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (numbasin > 0) THEN
+ CALL mpi_send (basinindex, numbasin, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+
+ CALL mpi_recv (lake_id, numbasin, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ CALL mpi_recv (lake_type, numbasin, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+ DO irank = 0, p_np_compute-1
+
+ CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = mesg(1)
+ nbasin = mesg(2)
+ IF (nbasin > 0) THEN
+
+ allocate(bindex (nbasin))
+ CALL mpi_recv (bindex, nbasin, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate(icache (nbasin))
+
+ icache = all_lake_id (bindex)
+ CALL mpi_send (icache, nbasin, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_err)
+
+ icache = all_lake_type(bindex)
+ CALL mpi_send (icache, nbasin, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (bindex)
+ deallocate (icache)
+ ENDIF
+
+ ENDDO
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ lake_id = all_lake_id (basinindex)
+ lake_type = all_lake_type(basinindex)
+#endif
+
+ IF (p_is_compute) THEN
+ IF (numbasin > 0) THEN
+ numlake = count(lake_type /= 0)
+ numresv = count(lake_type >= 2)
+ ELSE
+ numlake = 0
+ numresv = 0
+ ENDIF
+
+ IF (numlake > 0) THEN
+ allocate (bsn2lake (numbasin))
+ ilake = 0
+ DO ibasin = 1, numbasin
+ IF (lake_type(ibasin) /= 0) THEN
+ ilake = ilake + 1
+ bsn2lake(ibasin) = ilake
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (numresv > 0) THEN
+ allocate (bsn2resv (numbasin))
+ iresv = 0
+ DO ibasin = 1, numbasin
+ IF (lake_type(ibasin) >= 2) THEN
+ iresv = iresv + 1
+ bsn2resv(ibasin) = iresv
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (allocated(all_lake_id )) deallocate(all_lake_id )
+ IF (allocated(all_lake_type)) deallocate(all_lake_type)
+
+
+ END SUBROUTINE build_basin_network
+
+ ! ---------
+ SUBROUTINE basin_network_final ()
+
+ IMPLICIT NONE
+
+ IF (allocated(basinindex)) deallocate(basinindex)
+ IF (allocated(rivermouth)) deallocate(rivermouth)
+
+ IF (allocated(lake_id )) deallocate(lake_id )
+ IF (allocated(lake_type )) deallocate(lake_type )
+
+ IF (allocated(bsn2lake )) deallocate(bsn2lake )
+ IF (allocated(bsn2resv )) deallocate(bsn2resv )
+
+ END SUBROUTINE basin_network_final
+
+END MODULE MOD_Catch_BasinNetwork
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90
new file mode 100644
index 0000000000..fdcff24d4c
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeFlow.F90
@@ -0,0 +1,310 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_HillslopeFlow
+!-------------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Shallow water equation solver over hillslopes.
+!
+! References
+! [1] Toro EF. Shock-capturing methods for free-surface shallow flows.
+! Chichester: John Wiley & Sons; 2001.
+! [2] Liang, Q., Borthwick, A. G. L. (2009). Adaptive quadtree simulation of shallow
+! flows with wet-dry fronts over complex topography.
+! Computers and Fluids, 38(2), 221-234.
+! [3] Audusse, E., Bouchut, F., Bristeau, M.-O., Klein, R., Perthame, B. (2004).
+! A Fast and Stable Well-Balanced Scheme with Hydrostatic Reconstruction for
+! Shallow Water Flows. SIAM Journal on Scientific Computing, 25(6), 2050-2065.
+!
+! Created by Shupeng Zhang, May 2023
+!-------------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ IMPLICIT NONE
+
+ ! -- Parameters --
+ real(r8), parameter :: PONDMIN = 1.e-4
+ real(r8), parameter :: nmanning_hslp = 0.3
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE hillslope_flow (dt)
+
+ USE MOD_SPMD_Task
+ USE MOD_Catch_BasinNetwork
+ USE MOD_Catch_HillslopeNetwork
+ USE MOD_Catch_RiverLakeNetwork
+ USE MOD_Catch_Vars_TimeVariables
+ USE MOD_Catch_Vars_1DFluxes
+ USE MOD_Const_Physical, only: grav
+
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: dt
+
+ ! Local Variables
+ integer :: nhru, hs, he, ibasin, i, j
+
+ type(hillslope_network_type), pointer :: hillslope
+
+ real(r8), allocatable :: wdsrf_h (:) ! [m]
+ real(r8), allocatable :: momen_h (:) ! [m^2/s]
+ real(r8), allocatable :: veloc_h (:) ! [m/s]
+
+ real(r8), allocatable :: sum_hflux_h (:)
+ real(r8), allocatable :: sum_mflux_h (:)
+ real(r8), allocatable :: sum_zgrad_h (:)
+
+ real(r8) :: hand_fc, wdsrf_fc, veloc_fc, hflux_fc, mflux_fc
+ real(r8) :: wdsrf_up, wdsrf_dn, vwave_up, vwave_dn
+ real(r8) :: hflux_up, hflux_dn, mflux_up, mflux_dn
+
+ real(r8), allocatable :: xsurf_h (:) ! [m/s]
+
+ real(r8) :: friction
+ real(r8) :: dt_res, dt_this
+
+ logical, allocatable :: mask(:)
+ real(r8) :: srfbsn, dvol, nextl, nexta, nextv, ddep
+
+ IF (p_is_compute) THEN
+
+ DO ibasin = 1, numbasin
+
+ hs = basin_hru%substt(ibasin)
+ he = basin_hru%subend(ibasin)
+
+ IF (lake_id(ibasin) > 0) THEN
+ veloc_bsnhru(hs:he) = 0
+ momen_bsnhru(hs:he) = 0
+ CYCLE ! skip lakes
+ ELSE
+ DO i = hs, he
+ ! momentum is less or equal than the momentum at last time step.
+ momen_bsnhru(i) = min(wdsrf_bsnhru_prev(i), wdsrf_bsnhru(i)) * veloc_bsnhru(i)
+ ENDDO
+ ENDIF
+
+ hillslope => hillslope_basin(ibasin)
+
+ nhru = hillslope%nhru
+
+ allocate (wdsrf_h (nhru))
+ allocate (veloc_h (nhru))
+ allocate (momen_h (nhru))
+
+ allocate (sum_hflux_h (nhru))
+ allocate (sum_mflux_h (nhru))
+ allocate (sum_zgrad_h (nhru))
+
+ allocate (xsurf_h (nhru))
+
+ DO i = 1, nhru
+ wdsrf_h(i) = wdsrf_bsnhru(hillslope%ihru(i))
+ momen_h(i) = momen_bsnhru(hillslope%ihru(i))
+ IF (wdsrf_h(i) > 0.) THEN
+ veloc_h(i) = momen_h(i) / wdsrf_h(i)
+ ELSE
+ veloc_h(i) = 0.
+ ENDIF
+ ENDDO
+
+ dt_res = dt
+ DO WHILE (dt_res > 0.)
+
+ DO i = 1, nhru
+ sum_hflux_h(i) = 0.
+ sum_mflux_h(i) = 0.
+ sum_zgrad_h(i) = 0.
+ ENDDO
+
+ dt_this = dt_res
+
+ DO i = 1, nhru
+
+ j = hillslope%inext(i)
+
+ IF (j <= 0) CYCLE ! lowest HRUs
+
+ ! dry HRU
+ IF ((wdsrf_h(i) < PONDMIN) .and. (wdsrf_h(j) < PONDMIN)) THEN
+ CYCLE
+ ENDIF
+
+ ! reconstruction of height of water near interface
+ hand_fc = max(hillslope%hand(i), hillslope%hand(j))
+ wdsrf_up = max(0., hillslope%hand(i)+wdsrf_h(i) - hand_fc)
+ wdsrf_dn = max(0., hillslope%hand(j)+wdsrf_h(j) - hand_fc)
+
+ ! velocity at hydrounit downstream face
+ veloc_fc = 0.5 * (veloc_h(i) + veloc_h(j)) &
+ + sqrt(grav * wdsrf_up) - sqrt(grav * wdsrf_dn)
+
+ ! depth of water at downstream face
+ wdsrf_fc = 1/grav * (0.5*(sqrt(grav*wdsrf_up) + sqrt(grav*wdsrf_dn)) &
+ + 0.25 * (veloc_h(i) - veloc_h(j)))**2.0
+
+ IF (wdsrf_up > 0) THEN
+ vwave_up = min(veloc_h(i)-sqrt(grav*wdsrf_up), veloc_fc-sqrt(grav*wdsrf_fc))
+ ELSE
+ vwave_up = veloc_h(j) - 2.0 * sqrt(grav*wdsrf_dn)
+ ENDIF
+
+ IF (wdsrf_dn > 0) THEN
+ vwave_dn = max(veloc_h(j)+sqrt(grav*wdsrf_dn), veloc_fc+sqrt(grav*wdsrf_fc))
+ ELSE
+ vwave_dn = veloc_h(i) + 2.0 * sqrt(grav*wdsrf_up)
+ ENDIF
+
+ hflux_up = veloc_h(i) * wdsrf_up
+ hflux_dn = veloc_h(j) * wdsrf_dn
+ mflux_up = veloc_h(i)**2 * wdsrf_up + 0.5*grav * wdsrf_up**2
+ mflux_dn = veloc_h(j)**2 * wdsrf_dn + 0.5*grav * wdsrf_dn**2
+
+ IF (vwave_up >= 0.) THEN
+ hflux_fc = hillslope%flen(i) * hflux_up
+ mflux_fc = hillslope%flen(i) * mflux_up
+ ELSEIF (vwave_dn <= 0.) THEN
+ hflux_fc = hillslope%flen(i) * hflux_dn
+ mflux_fc = hillslope%flen(i) * mflux_dn
+ ELSE
+ hflux_fc = hillslope%flen(i) * (vwave_dn*hflux_up - vwave_up*hflux_dn &
+ + vwave_up*vwave_dn*(wdsrf_dn-wdsrf_up)) / (vwave_dn-vwave_up)
+ mflux_fc = hillslope%flen(i) * (vwave_dn*mflux_up - vwave_up*mflux_dn &
+ + vwave_up*vwave_dn*(hflux_dn-hflux_up)) / (vwave_dn-vwave_up)
+ ENDIF
+
+ sum_hflux_h(i) = sum_hflux_h(i) + hflux_fc
+ sum_hflux_h(j) = sum_hflux_h(j) - hflux_fc
+
+ sum_mflux_h(i) = sum_mflux_h(i) + mflux_fc
+ sum_mflux_h(j) = sum_mflux_h(j) - mflux_fc
+
+ sum_zgrad_h(i) = sum_zgrad_h(i) + hillslope%flen(i) * 0.5*grav * wdsrf_up**2
+ sum_zgrad_h(j) = sum_zgrad_h(j) - hillslope%flen(i) * 0.5*grav * wdsrf_dn**2
+
+ ENDDO
+
+ DO i = 1, nhru
+ ! constraint 1: CFL condition
+ IF (hillslope%inext(i) > 0) THEN
+ IF ((veloc_h(i) /= 0.) .or. (wdsrf_h(i) > 0.)) THEN
+ dt_this = min(dt_this, hillslope%plen(i)/(abs(veloc_h(i)) + sqrt(grav*wdsrf_h(i)))*0.8)
+ ENDIF
+ ENDIF
+
+ ! constraint 2: Avoid negative values of water
+ xsurf_h(i) = sum_hflux_h(i) / hillslope%area(i)
+ IF (xsurf_h(i) > 0) THEN
+ dt_this = min(dt_this, wdsrf_h(i) / xsurf_h(i))
+ ENDIF
+
+ ! constraint 3: Avoid change of flow direction
+ IF ((abs(veloc_h(i)) > 0.1) &
+ .and. (veloc_h(i) * (sum_mflux_h(i) - sum_zgrad_h(i)) > 0)) THEN
+ dt_this = min(dt_this, &
+ abs(momen_h(i) * hillslope%area(i) / (sum_mflux_h(i) - sum_zgrad_h(i))))
+ ENDIF
+ ENDDO
+
+ DO i = 1, nhru
+
+ wdsrf_h(i) = max(0., wdsrf_h(i) - xsurf_h(i) * dt_this)
+
+ IF (wdsrf_h(i) < PONDMIN) THEN
+ momen_h(i) = 0
+ ELSE
+ friction = grav * nmanning_hslp**2 * abs(momen_h(i)) / wdsrf_h(i)**(7.0/3.0)
+ momen_h(i) = (momen_h(i) - &
+ (sum_mflux_h(i) - sum_zgrad_h(i)) / hillslope%area(i) * dt_this) &
+ / (1 + friction * dt_this)
+
+ IF (hillslope%inext(i) <= 0) THEN
+ momen_h(i) = min(momen_h(i), 0.)
+ ENDIF
+
+ IF (all(hillslope%inext /= i)) THEN
+ momen_h(i) = max(momen_h(i), 0.)
+ ENDIF
+ ENDIF
+
+ ENDDO
+
+ IF (hillslope%indx(1) == 0) THEN
+ srfbsn = minval(hillslope%hand + wdsrf_h)
+ IF (srfbsn < wdsrf_h(1)) THEN
+ allocate (mask (hillslope%nhru))
+ dvol = (wdsrf_h(1) - srfbsn) * hillslope%area(1)
+ momen_h(1) = srfbsn/wdsrf_h(1) * momen_h(1)
+ wdsrf_h(1) = srfbsn
+ DO WHILE (dvol > 0)
+ mask = hillslope%hand + wdsrf_h > srfbsn
+ nexta = sum(hillslope%area, mask = (.not. mask))
+ IF (any(mask)) THEN
+ nextl = minval(hillslope%hand + wdsrf_h, mask = mask)
+ nextv = nexta*(nextl-srfbsn)
+ IF (dvol > nextv) THEN
+ ddep = nextl - srfbsn
+ dvol = dvol - nextv
+ ELSE
+ ddep = dvol/nexta
+ dvol = 0.
+ ENDIF
+ ELSE
+ ddep = dvol/nexta
+ dvol = 0.
+ ENDIF
+
+ srfbsn = srfbsn + ddep
+
+ WHERE (.not. mask)
+ wdsrf_h = wdsrf_h + ddep
+ END WHERE
+ ENDDO
+ deallocate(mask)
+ ENDIF
+ ENDIF
+
+ DO i = 1, nhru
+ IF (wdsrf_h(i) < PONDMIN) THEN
+ veloc_h(i) = 0
+ ELSE
+ veloc_h(i) = momen_h(i) / wdsrf_h(i)
+ ENDIF
+
+ wdsrf_bsnhru_ta(hillslope%ihru(i)) = wdsrf_bsnhru_ta(hillslope%ihru(i)) + wdsrf_h(i) * dt_this
+ momen_bsnhru_ta(hillslope%ihru(i)) = momen_bsnhru_ta(hillslope%ihru(i)) + momen_h(i) * dt_this
+ ENDDO
+
+ dt_res = dt_res - dt_this
+
+ ENDDO
+
+ ! SAVE depth of surface water
+ DO i = 1, nhru
+ wdsrf_bsnhru(hillslope%ihru(i)) = wdsrf_h(i)
+ veloc_bsnhru(hillslope%ihru(i)) = veloc_h(i)
+ ENDDO
+
+ deallocate (wdsrf_h)
+ deallocate (veloc_h)
+ deallocate (momen_h)
+
+ deallocate (sum_hflux_h)
+ deallocate (sum_mflux_h)
+ deallocate (sum_zgrad_h)
+
+ deallocate (xsurf_h)
+
+ ENDDO
+
+ IF (numbsnhru > 0) wdsrf_bsnhru_prev(:) = wdsrf_bsnhru(:)
+
+ ENDIF
+
+ END SUBROUTINE hillslope_flow
+
+END MODULE MOD_Catch_HillslopeFlow
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90
new file mode 100644
index 0000000000..92ab560435
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_HillslopeNetwork.F90
@@ -0,0 +1,381 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_HillslopeNetwork
+!--------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Surface networks (hillslope bands): data and communication subroutines.
+!
+! Created by Shupeng Zhang, May 2023
+!--------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ IMPLICIT NONE
+
+ ! -- data type --
+ type :: hillslope_network_type
+ integer :: nhru
+ integer , pointer :: ihru (:) ! location of HRU in global vector "landhru"
+ integer , pointer :: indx (:) ! index of HRU
+ real(r8), pointer :: area (:) ! area of HRU [m^2]
+ real(r8), pointer :: agwt (:) ! water area only including (patchtype <= 2) [m^2]
+ real(r8), pointer :: hand (:) ! height above nearest drainage [m]
+ real(r8), pointer :: elva (:) ! elevation [m]
+ real(r8), pointer :: plen (:) ! average drainage path length to downstream HRU [m]
+ real(r8), pointer :: flen (:) ! interface length between this and downstream HRU [m]
+ integer , pointer :: inext(:) ! location of next HRU in this basin
+ real(r8), pointer :: fldprof (:,:) ! flood area profile
+ CONTAINS
+ final :: hillslope_network_free_mem
+ END type hillslope_network_type
+
+ integer :: nfldstep
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE hillslope_network_init (ne, elmindex, hillslope_network)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_NetCDFSerial
+ USE MOD_UserDefFun
+ IMPLICIT NONE
+
+ integer, intent(in) :: ne
+ integer, intent(in) :: elmindex (:)
+ type(hillslope_network_type), pointer :: hillslope_network(:)
+
+ ! Local Variables
+ character(len=256) :: hillslope_network_file
+
+ integer :: maxnumhru, ie, nhru, hs, i, j
+ integer :: irank, mesg(2), nrecv, irecv, isrc, idest
+
+ integer , allocatable :: eid (:)
+
+ integer , allocatable :: nhru_all(:), nhru_in_bsn(:)
+
+ integer , allocatable :: indxhru (:,:)
+ real(r8), allocatable :: handhru (:,:)
+ real(r8), allocatable :: elvahru (:,:)
+ real(r8), allocatable :: plenhru (:,:)
+ real(r8), allocatable :: lfachru (:,:)
+ integer , allocatable :: nexthru (:,:)
+ real(r8), allocatable :: fldstep (:,:,:)
+
+ integer , allocatable :: icache (:,:)
+ real(r8), allocatable :: rcache (:,:), rcache2(:,:,:)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ hillslope_network_file = DEF_CatchmentMesh_data
+
+ IF (p_is_root) THEN
+
+ CALL ncio_read_serial (hillslope_network_file, 'basin_numhru', nhru_all)
+ CALL ncio_read_serial (hillslope_network_file, 'hydrounit_index', indxhru)
+ CALL ncio_read_serial (hillslope_network_file, 'hydrounit_hand', handhru)
+ CALL ncio_read_serial (hillslope_network_file, 'hydrounit_elva', elvahru)
+ CALL ncio_read_serial (hillslope_network_file, 'hydrounit_pathlen', plenhru)
+ CALL ncio_read_serial (hillslope_network_file, 'hydrounit_facelen', lfachru)
+ CALL ncio_read_serial (hillslope_network_file, 'hydrounit_downstream', nexthru)
+ CALL ncio_read_serial (hillslope_network_file, 'hydrounit_flood_step', fldstep)
+
+ ENDIF
+
+ IF (p_is_root) maxnumhru = size(indxhru,1)
+ IF (p_is_root) nfldstep = size(fldstep,1)
+#ifdef USEMPI
+ CALL mpi_bcast (maxnumhru, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ CALL mpi_bcast (nfldstep, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+#endif
+
+ hillslope_network => null()
+
+ IF (p_is_root) THEN
+#ifdef USEMPI
+ DO irank = 1, p_np_compute
+ CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ nrecv = mesg(2)
+ isrc = mesg(1)
+
+ IF (nrecv > 0) THEN
+
+ allocate (eid (nrecv))
+ allocate (nhru_in_bsn (nrecv))
+ allocate (icache (maxnumhru,nrecv))
+ allocate (rcache (maxnumhru,nrecv))
+
+ CALL mpi_recv (eid, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ idest = isrc
+
+ nhru_in_bsn = nhru_all(eid)
+ CALL mpi_send (nhru_in_bsn, nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ DO irecv = 1, nrecv
+ icache(:,irecv) = indxhru(:,eid(irecv))
+ ENDDO
+ CALL mpi_send (icache, maxnumhru*nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ DO irecv = 1, nrecv
+ rcache(:,irecv) = handhru(:,eid(irecv))
+ ENDDO
+ CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ DO irecv = 1, nrecv
+ rcache(:,irecv) = elvahru(:,eid(irecv))
+ ENDDO
+ CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ DO irecv = 1, nrecv
+ rcache(:,irecv) = plenhru(:,eid(irecv))
+ ENDDO
+ CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ DO irecv = 1, nrecv
+ rcache(:,irecv) = lfachru(:,eid(irecv))
+ ENDDO
+ CALL mpi_send (rcache, maxnumhru*nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ DO irecv = 1, nrecv
+ icache(:,irecv) = nexthru(:,eid(irecv))
+ ENDDO
+ CALL mpi_send (icache, maxnumhru*nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ allocate (rcache2 (nfldstep,maxnumhru,nrecv))
+
+ DO irecv = 1, nrecv
+ rcache2(:,:,irecv) = fldstep(:,:,eid(irecv))
+ ENDDO
+ CALL mpi_send (rcache2, nfldstep*maxnumhru*nrecv, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (eid)
+ deallocate (nhru_in_bsn)
+ deallocate (icache)
+ deallocate (rcache)
+ deallocate (rcache2)
+ ENDIF
+ ENDDO
+#else
+ IF (ne > 0) THEN
+
+ allocate (nhru_in_bsn (ne))
+ allocate (icache (maxnumhru,ne))
+ allocate (rcache (maxnumhru,ne))
+
+ nhru_in_bsn = nhru_all(elmindex)
+
+ DO ie = 1, ne
+ icache(:,ie) = indxhru(:,elmindex(ie))
+ ENDDO
+ indxhru = icache
+
+ DO ie = 1, ne
+ rcache(:,ie) = handhru(:,elmindex(ie))
+ ENDDO
+ handhru = rcache
+
+ DO ie = 1, ne
+ rcache(:,ie) = elvahru(:,elmindex(ie))
+ ENDDO
+ elvahru = rcache
+
+ DO ie = 1, ne
+ rcache(:,ie) = plenhru(:,elmindex(ie))
+ ENDDO
+ plenhru = rcache
+
+ DO ie = 1, ne
+ rcache(:,ie) = lfachru(:,elmindex(ie))
+ ENDDO
+ lfachru = rcache
+
+ DO ie = 1, ne
+ icache(:,ie) = nexthru(:,elmindex(ie))
+ ENDDO
+ nexthru = icache
+
+ deallocate (icache)
+ deallocate (rcache)
+
+ allocate (rcache2 (nfldstep,maxnumhru,ne))
+
+ DO ie = 1, ne
+ rcache2(:,:,ie) = fldstep(:,:,elmindex(ie))
+ ENDDO
+ fldstep = rcache2
+
+ deallocate (rcache2)
+
+ ENDIF
+#endif
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+#ifdef USEMPI
+ mesg(1:2) = (/p_iam_glb, ne/)
+ CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (ne > 0) THEN
+
+ CALL mpi_send (elmindex, ne, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+
+ allocate (nhru_in_bsn (ne))
+ CALL mpi_recv (nhru_in_bsn, ne, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (indxhru (maxnumhru,ne))
+ CALL mpi_recv (indxhru, maxnumhru*ne, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (handhru (maxnumhru,ne))
+ CALL mpi_recv (handhru, maxnumhru*ne, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (elvahru (maxnumhru,ne))
+ CALL mpi_recv (elvahru, maxnumhru*ne, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (plenhru (maxnumhru,ne))
+ CALL mpi_recv (plenhru, maxnumhru*ne, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (lfachru (maxnumhru,ne))
+ CALL mpi_recv (lfachru, maxnumhru*ne, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (nexthru (maxnumhru,ne))
+ CALL mpi_recv (nexthru, maxnumhru*ne, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (fldstep (nfldstep,maxnumhru,ne))
+ CALL mpi_recv (fldstep, nfldstep*maxnumhru*ne, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+#endif
+
+ IF (ne > 0) THEN
+ allocate( hillslope_network (ne))
+ ENDIF
+
+ hs = 0
+
+ DO ie = 1, ne
+
+ nhru = count(indxhru(:,ie) >= 0)
+
+ IF (nhru > 0) THEN
+
+ IF (nhru /= nhru_in_bsn(ie)) THEN
+ write(*,*) 'Warning : numbers of hydro units from file mismatch!'
+ ENDIF
+
+ allocate (hillslope_network(ie)%ihru (nhru))
+ allocate (hillslope_network(ie)%indx (nhru))
+ allocate (hillslope_network(ie)%area (nhru))
+ allocate (hillslope_network(ie)%agwt (nhru))
+ allocate (hillslope_network(ie)%hand (nhru))
+ allocate (hillslope_network(ie)%elva (nhru))
+ allocate (hillslope_network(ie)%plen (nhru))
+ allocate (hillslope_network(ie)%flen (nhru))
+ allocate (hillslope_network(ie)%inext (nhru))
+
+ hillslope_network(ie)%indx = indxhru(1:nhru,ie)
+ hillslope_network(ie)%hand = handhru(1:nhru,ie) ! m
+ hillslope_network(ie)%elva = elvahru(1:nhru,ie) ! m
+ hillslope_network(ie)%plen = plenhru(1:nhru,ie) * 1.0e3 ! km to m
+ hillslope_network(ie)%flen = lfachru(1:nhru,ie) * 1.0e3 ! km to m
+
+ hillslope_network(ie)%ihru = (/ (i, i = hs+1, hs+nhru) /)
+
+ allocate (hillslope_network(ie)%fldprof (nfldstep,nhru))
+
+ DO i = 1, nhru
+ DO j = 1, nfldstep
+ IF (j == 1) THEN
+ hillslope_network(ie)%fldprof(j,i) = max(fldstep(j,i,ie) * (j-0.5)/nfldstep, 1.e-3)
+ ELSE
+ hillslope_network(ie)%fldprof(j,i) = hillslope_network(ie)%fldprof(j-1,i) &
+ + (fldstep(j,i,ie) - fldstep(j-1,i,ie)) * (j-0.5)/nfldstep
+ ENDIF
+ ENDDO
+ ENDDO
+
+ DO i = 1, nhru
+ IF (nexthru(i,ie) >= 0) THEN
+ j = findloc_ud(indxhru(1:nhru,ie) == nexthru(i,ie))
+ hillslope_network(ie)%inext(i) = j
+ ELSE
+ hillslope_network(ie)%inext(i) = -1
+ ENDIF
+ ENDDO
+
+ ELSE
+ ! for lake
+ hillslope_network(ie)%ihru => null()
+ hillslope_network(ie)%indx => null()
+ hillslope_network(ie)%area => null()
+ hillslope_network(ie)%agwt => null()
+ hillslope_network(ie)%hand => null()
+ hillslope_network(ie)%elva => null()
+ hillslope_network(ie)%plen => null()
+ hillslope_network(ie)%flen => null()
+ hillslope_network(ie)%inext => null()
+ ENDIF
+
+ hillslope_network(ie)%nhru = nhru_in_bsn(ie)
+ hs = hs + nhru_in_bsn(ie)
+
+ ENDDO
+
+ ENDIF
+
+ IF (allocated(nhru_all )) deallocate(nhru_all )
+ IF (allocated(nhru_in_bsn)) deallocate(nhru_in_bsn)
+
+ IF (allocated(indxhru)) deallocate(indxhru)
+ IF (allocated(handhru)) deallocate(handhru)
+ IF (allocated(elvahru)) deallocate(elvahru)
+ IF (allocated(plenhru)) deallocate(plenhru)
+ IF (allocated(lfachru)) deallocate(lfachru)
+ IF (allocated(nexthru)) deallocate(nexthru)
+ IF (allocated(fldstep)) deallocate(fldstep)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+ IF (p_is_root) write(*,'(A)') 'Read hillslope network information done.'
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ END SUBROUTINE hillslope_network_init
+
+ ! ---------
+ SUBROUTINE hillslope_network_free_mem (this)
+
+ IMPLICIT NONE
+ type(hillslope_network_type) :: this
+
+ IF (associated(this%ihru )) deallocate(this%ihru )
+ IF (associated(this%indx )) deallocate(this%indx )
+ IF (associated(this%area )) deallocate(this%area )
+ IF (associated(this%agwt )) deallocate(this%agwt )
+ IF (associated(this%hand )) deallocate(this%hand )
+ IF (associated(this%elva )) deallocate(this%elva )
+ IF (associated(this%plen )) deallocate(this%plen )
+ IF (associated(this%flen )) deallocate(this%flen )
+ IF (associated(this%inext )) deallocate(this%inext )
+ IF (associated(this%fldprof)) deallocate(this%fldprof)
+
+ END SUBROUTINE hillslope_network_free_mem
+
+END MODULE MOD_Catch_HillslopeNetwork
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90
new file mode 100644
index 0000000000..b773a0d304
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Hist.F90
@@ -0,0 +1,490 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_Hist
+!--------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Write out model results in lateral hydrological processes to history files.
+!
+! Created by Shupeng Zhang, May 2023
+!--------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Namelist
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_Vars_Global, only: spval
+
+ USE MOD_Mesh, only: numelm
+ USE MOD_LandHRU, only: numhru
+ USE MOD_Catch_BasinNetwork, only: numbasin, numbsnhru
+ USE MOD_Catch_Reservoir
+ USE MOD_Catch_Vars_1DFluxes
+ USE MOD_Vector_ReadWrite
+
+ ! -- ACC Fluxes --
+ integer :: nac_basin
+
+ real(r8), allocatable :: a_wdsrf_bsnhru (:)
+ real(r8), allocatable :: a_veloc_bsnhru (:)
+
+ real(r8), allocatable :: a_wdsrf_hru (:)
+ real(r8), allocatable :: a_veloc_hru (:)
+
+ real(r8), allocatable :: a_wdsrf_bsn (:)
+ real(r8), allocatable :: a_veloc_riv (:)
+ real(r8), allocatable :: a_discharge (:)
+
+ real(r8), allocatable :: a_wdsrf_elm (:)
+ real(r8), allocatable :: a_veloc_elm (:)
+ real(r8), allocatable :: a_dschg_elm (:)
+
+ real(r8), allocatable :: a_xsubs_elm (:)
+ real(r8), allocatable :: a_xsubs_hru (:)
+
+ real(r8), allocatable :: a_volresv (:)
+ real(r8), allocatable :: a_qresv_in (:)
+ real(r8), allocatable :: a_qresv_out (:)
+
+ real(r8), allocatable :: ntacc_elm (:)
+
+ ! -- PUBLIC SUBROUTINEs --
+ PUBLIC :: hist_basin_init
+ PUBLIC :: hist_basin_out
+ PUBLIC :: hist_basin_final
+
+!--------------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE hist_basin_init
+
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+ IF (numbsnhru > 0) THEN
+ allocate (a_wdsrf_bsnhru (numbsnhru))
+ allocate (a_veloc_bsnhru (numbsnhru))
+ ENDIF
+
+ IF (numbasin > 0) THEN
+ allocate (a_wdsrf_bsn (numbasin))
+ allocate (a_veloc_riv (numbasin))
+ allocate (a_discharge (numbasin))
+ ENDIF
+
+ IF (numelm > 0) allocate (a_xsubs_elm (numelm))
+ IF (numhru > 0) allocate (a_xsubs_hru (numhru))
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (numresv > 0) allocate (a_volresv (numresv))
+ IF (numresv > 0) allocate (a_qresv_in (numresv))
+ IF (numresv > 0) allocate (a_qresv_out (numresv))
+ ENDIF
+ ENDIF
+
+ CALL FLUSH_acc_fluxes_basin ()
+
+ END SUBROUTINE hist_basin_init
+
+ !--------------------------------------
+ SUBROUTINE hist_basin_final ()
+
+ IMPLICIT NONE
+
+ IF (allocated(a_wdsrf_bsnhru)) deallocate(a_wdsrf_bsnhru)
+ IF (allocated(a_veloc_bsnhru)) deallocate(a_veloc_bsnhru)
+
+ IF (allocated(a_wdsrf_bsn)) deallocate(a_wdsrf_bsn)
+ IF (allocated(a_veloc_riv)) deallocate(a_veloc_riv)
+ IF (allocated(a_discharge)) deallocate(a_discharge)
+
+ IF (allocated(a_xsubs_elm)) deallocate(a_xsubs_elm)
+ IF (allocated(a_xsubs_hru)) deallocate(a_xsubs_hru)
+
+ IF (allocated(a_volresv )) deallocate(a_volresv )
+ IF (allocated(a_qresv_in )) deallocate(a_qresv_in )
+ IF (allocated(a_qresv_out)) deallocate(a_qresv_out)
+
+ END SUBROUTINE hist_basin_final
+
+ !---------------------------------------
+ SUBROUTINE hist_basin_out (file_hist, idate)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_ElmVector
+ USE MOD_HRUVector
+ USE MOD_LandHRU
+ USE MOD_Catch_BasinNetwork
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: file_hist
+ integer, intent(in) :: idate(3)
+
+ ! Local variables
+ character(len=256) :: file_hist_basin
+ logical :: fexists
+ integer :: itime_in_file
+ logical, allocatable :: filter (:)
+ real(r8), allocatable :: varhist(:)
+ integer :: i
+
+ IF (p_is_root) THEN
+
+ i = len_trim (file_hist)
+ DO WHILE (file_hist(i:i) /= '_')
+ i = i - 1
+ ENDDO
+ file_hist_basin = file_hist(1:i) // 'basin_' // file_hist(i+1:)
+
+ inquire (file=file_hist_basin, exist=fexists)
+ IF (.not. fexists) THEN
+ CALL ncio_create_file (trim(file_hist_basin))
+ CALL ncio_define_dimension(file_hist_basin, 'time', 0)
+ CALL ncio_define_dimension(file_hist_basin, 'basin', totalnumelm)
+ CALL ncio_define_dimension(file_hist_basin, 'hydrounit', totalnumhru)
+
+ CALL ncio_write_serial (file_hist_basin, 'basin', eindex_glb, 'basin')
+ CALL ncio_put_attr (file_hist_basin, 'basin', 'long_name', 'basin index')
+
+ CALL ncio_write_serial (file_hist_basin, 'basin_hru', eindx_hru, 'hydrounit')
+ CALL ncio_put_attr (file_hist_basin, 'basin_hru', 'long_name', &
+ 'basin index of hydrological units')
+
+ CALL ncio_write_serial (file_hist_basin, 'hru_type' , htype_hru, 'hydrounit')
+ CALL ncio_put_attr (file_hist_basin, 'hru_type' , 'long_name', &
+ 'index of hydrological units inside basin')
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (numresv_uniq > 0) THEN
+ CALL ncio_define_dimension(file_hist_basin, 'reservoir', numresv_uniq)
+ CALL ncio_write_serial (file_hist_basin, 'resv_hylak_id' , resv_hylak_id, 'reservoir')
+ CALL ncio_put_attr (file_hist_basin, 'resv_hylak_id' , 'long_name', &
+ 'HydroLAKE ID of reservoirs')
+ ENDIF
+ ENDIF
+ ENDIF
+
+ CALL ncio_write_time (file_hist_basin, 'time', idate, itime_in_file, DEF_HIST_FREQ)
+
+ ENDIF
+
+
+ IF (p_is_compute) THEN
+ IF (numhru > 0) THEN
+ allocate (a_wdsrf_hru (numhru))
+ allocate (a_veloc_hru (numhru))
+ ENDIF
+
+ IF (numelm > 0) THEN
+ allocate (a_wdsrf_elm (numelm))
+ allocate (a_veloc_elm (numelm))
+ allocate (a_dschg_elm (numelm))
+ allocate (ntacc_elm (numelm))
+ ENDIF
+ ENDIF
+
+ ! ----- water depth in basin -----
+ IF (DEF_hist_vars%riv_height) THEN
+ IF ((p_is_compute) .and. allocated(a_wdsrf_bsn)) THEN
+ WHERE(a_wdsrf_bsn /= spval)
+ a_wdsrf_bsn = a_wdsrf_bsn / nac_basin
+ END WHERE
+ ENDIF
+
+ CALL compute_push_data (push_bsn2elm, a_wdsrf_bsn, a_wdsrf_elm, spval)
+
+ CALL vector_gather_and_write (&
+ a_wdsrf_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_wdsrf_bsn', 'basin', &
+ itime_in_file, 'River Height', 'm')
+ ENDIF
+
+ ! ----- water velocity in river -----
+ IF (DEF_hist_vars%riv_veloct) THEN
+ IF ((p_is_compute) .and. allocated(a_veloc_riv)) THEN
+ WHERE(a_veloc_riv /= spval)
+ a_veloc_riv = a_veloc_riv / nac_basin
+ END WHERE
+ ENDIF
+
+ CALL compute_push_data (push_bsn2elm, a_veloc_riv, a_veloc_elm, spval)
+
+ CALL vector_gather_and_write (&
+ a_veloc_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_veloc_riv', 'basin', &
+ itime_in_file, 'River Velocity', 'm/s')
+ ENDIF
+
+ ! ----- discharge in river -----
+ IF (DEF_hist_vars%discharge) THEN
+ IF ((p_is_compute) .and. allocated(a_discharge)) THEN
+ WHERE(a_discharge /= spval)
+ a_discharge = a_discharge / nac_basin
+ END WHERE
+ ENDIF
+
+ CALL compute_push_data (push_bsn2elm, a_discharge, a_dschg_elm, spval)
+
+ CALL vector_gather_and_write (&
+ a_dschg_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_discharge', 'basin', &
+ itime_in_file, 'River Discharge', 'm^3/s')
+ ENDIF
+
+ ! ----- number of time steps for each basin -----
+ CALL compute_push_data (push_bsn2elm, ntacc_bsn, ntacc_elm, spval)
+
+ CALL vector_gather_and_write (&
+ ntacc_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'timesteps', 'basin', &
+ itime_in_file, 'Number of accumulated timesteps for each basin', '-')
+
+ IF (p_is_compute .and. (numbasin > 0)) ntacc_bsn(:) = 0.
+
+ ! ----- water depth in hydro unit -----
+ IF (DEF_hist_vars%wdsrf_hru) THEN
+ IF ((p_is_compute) .and. allocated(a_wdsrf_bsnhru)) THEN
+ WHERE(a_wdsrf_bsnhru /= spval)
+ a_wdsrf_bsnhru = a_wdsrf_bsnhru / nac_basin
+ END WHERE
+ ENDIF
+
+ CALL compute_push_data (push_bsnhru2elmhru, a_wdsrf_bsnhru, a_wdsrf_hru, spval)
+
+ CALL vector_gather_and_write (&
+ a_wdsrf_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_wdsrf_hru', 'hydrounit', &
+ itime_in_file, 'Depth of Surface Water in Hydro unit', 'm')
+ ENDIF
+
+ ! ----- water velocity in hydro unit -----
+ IF (DEF_hist_vars%veloc_hru) THEN
+ IF ((p_is_compute) .and. allocated(a_veloc_bsnhru)) THEN
+ WHERE(a_veloc_bsnhru /= spval)
+ a_veloc_bsnhru = a_veloc_bsnhru / nac_basin
+ END WHERE
+ ENDIF
+
+ CALL compute_push_data (push_bsnhru2elmhru, a_veloc_bsnhru, a_veloc_hru, spval)
+
+ CALL vector_gather_and_write (&
+ a_veloc_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_veloc_hru', 'hydrounit', &
+ itime_in_file, 'Surface Flow Velocity in Hydro unit', 'm/s')
+ ENDIF
+
+ ! ----- subsurface water flow between elements -----
+ IF (DEF_hist_vars%xsubs_bsn) THEN
+ IF (p_is_compute) THEN
+ WHERE(a_xsubs_elm /= spval)
+ a_xsubs_elm = a_xsubs_elm / nac_basin
+ END WHERE
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ a_xsubs_elm, numelm, totalnumelm, elm_data_address, file_hist_basin, 'v_xsubs_bsn', 'basin', &
+ itime_in_file, 'Subsurface lateral flow between basins', 'm/s')
+ ENDIF
+
+ ! ----- subsurface water flow between hydro units -----
+ IF (DEF_hist_vars%xsubs_hru) THEN
+ IF (p_is_compute) THEN
+ WHERE(a_xsubs_hru /= spval)
+ a_xsubs_hru = a_xsubs_hru / nac_basin
+ END WHERE
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ a_xsubs_hru, numhru, totalnumhru, hru_data_address, file_hist_basin, 'v_xsubs_hru', 'hydrounit', &
+ itime_in_file, 'SubSurface lateral flow between HRUs', 'm/s')
+ ENDIF
+
+ ! ----- reservoir variables -----
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (numresv_uniq > 0) THEN
+
+ allocate (varhist (numresv_uniq))
+
+ IF (DEF_hist_vars%volresv) THEN
+
+ IF (p_is_compute) THEN
+ IF (numresv > 0) THEN
+ WHERE (a_volresv /= spval)
+ a_volresv = a_volresv / nac_basin
+ END WHERE
+ ENDIF
+ ENDIF
+
+ CALL reservoir_gather_var (a_volresv, varhist)
+
+ IF (p_is_root) THEN
+ CALL ncio_write_serial_time (file_hist_basin, 'volresv', &
+ itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel)
+ IF (itime_in_file == 1) THEN
+ CALL ncio_put_attr (file_hist_basin, 'volresv', 'long_name', 'reservoir water volume')
+ CALL ncio_put_attr (file_hist_basin, 'volresv', 'units', 'm^3')
+ CALL ncio_put_attr (file_hist_basin, 'volresv', 'missing_value', spval)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (DEF_hist_vars%qresv_in) THEN
+
+ IF (p_is_compute) THEN
+ IF (numresv > 0) THEN
+ WHERE (a_qresv_in /= spval)
+ a_qresv_in = a_qresv_in / nac_basin
+ END WHERE
+ ENDIF
+ ENDIF
+
+ CALL reservoir_gather_var (a_qresv_in, varhist)
+
+ IF (p_is_root) THEN
+ CALL ncio_write_serial_time (file_hist_basin, 'qresv_in', &
+ itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel)
+ IF (itime_in_file == 1) THEN
+ CALL ncio_put_attr (file_hist_basin, 'qresv_in', 'long_name', 'reservoir inflow')
+ CALL ncio_put_attr (file_hist_basin, 'qresv_in', 'units', 'm^3/s')
+ CALL ncio_put_attr (file_hist_basin, 'qresv_in', 'missing_value', spval)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (DEF_hist_vars%qresv_out) THEN
+
+ IF (p_is_compute) THEN
+ IF (numresv > 0) THEN
+ WHERE (a_qresv_out /= spval)
+ a_qresv_out = a_qresv_out / nac_basin
+ END WHERE
+ ENDIF
+ ENDIF
+
+ CALL reservoir_gather_var (a_qresv_out, varhist)
+
+ IF (p_is_root) THEN
+ CALL ncio_write_serial_time (file_hist_basin, 'qresv_out', &
+ itime_in_file, varhist, 'reservoir', 'time', DEF_HIST_CompressLevel)
+ IF (itime_in_file == 1) THEN
+ CALL ncio_put_attr (file_hist_basin, 'qresv_out', 'long_name', 'reservoir outflow')
+ CALL ncio_put_attr (file_hist_basin, 'qresv_out', 'units', 'm^3/s')
+ CALL ncio_put_attr (file_hist_basin, 'qresv_out', 'missing_value', spval)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ deallocate (varhist)
+
+ ENDIF
+ ENDIF
+
+
+ CALL FLUSH_acc_fluxes_basin ()
+
+ IF (allocated(a_wdsrf_hru)) deallocate(a_wdsrf_hru)
+ IF (allocated(a_veloc_hru)) deallocate(a_veloc_hru)
+
+ IF (allocated(a_wdsrf_elm)) deallocate(a_wdsrf_elm)
+ IF (allocated(a_veloc_elm)) deallocate(a_veloc_elm)
+ IF (allocated(a_dschg_elm)) deallocate(a_dschg_elm)
+ IF (allocated(ntacc_elm )) deallocate(ntacc_elm )
+
+
+ END SUBROUTINE hist_basin_out
+
+ !-----------------------
+ SUBROUTINE FLUSH_acc_fluxes_basin ()
+
+ USE MOD_SPMD_Task
+ USE MOD_Mesh, only: numelm
+ USE MOD_LandHRU, only: numhru
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+
+ nac_basin = 0
+
+ IF (numbasin > 0) THEN
+ a_wdsrf_bsn(:) = spval
+ a_veloc_riv(:) = spval
+ a_discharge(:) = spval
+ ENDIF
+
+ IF (numelm > 0) a_xsubs_elm (:) = spval
+
+ IF (numbsnhru > 0) THEN
+ a_wdsrf_bsnhru(:) = spval
+ a_veloc_bsnhru(:) = spval
+ ENDIF
+
+ IF (numhru > 0) a_xsubs_hru(:) = spval
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (numresv > 0) a_volresv (:) = spval
+ IF (numresv > 0) a_qresv_in (:) = spval
+ IF (numresv > 0) a_qresv_out(:) = spval
+ ENDIF
+
+ ENDIF
+
+ END SUBROUTINE FLUSH_acc_fluxes_basin
+
+ ! -------
+ SUBROUTINE accumulate_fluxes_basin
+
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+
+ nac_basin = nac_basin + 1
+
+ IF (numbasin > 0) THEN
+ CALL acc1d_basin (wdsrf_bsn_ta, a_wdsrf_bsn)
+ CALL acc1d_basin (veloc_riv_ta, a_veloc_riv)
+ CALL acc1d_basin (discharge_ta, a_discharge )
+ ENDIF
+
+ IF (numelm > 0) CALL acc1d_basin (xsubs_elm, a_xsubs_elm)
+
+ IF (numbsnhru > 0) THEN
+ CALL acc1d_basin (wdsrf_bsnhru_ta, a_wdsrf_bsnhru)
+ CALL acc1d_basin (veloc_bsnhru_ta, a_veloc_bsnhru)
+ ENDIF
+
+ IF (numhru > 0) CALL acc1d_basin (xsubs_hru, a_xsubs_hru)
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (numresv > 0) CALL acc1d_basin (volresv_ta, a_volresv )
+ IF (numresv > 0) CALL acc1d_basin (qresv_in_ta, a_qresv_in )
+ IF (numresv > 0) CALL acc1d_basin (qresv_out_ta, a_qresv_out)
+ ENDIF
+
+ ENDIF
+
+ END SUBROUTINE accumulate_fluxes_basin
+
+ ! -------
+ SUBROUTINE acc1d_basin (var, s)
+
+ USE MOD_Precision
+ USE MOD_Vars_Global, only: spval
+
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: var(:)
+ real(r8), intent(inout) :: s (:)
+ ! Local variables
+ integer :: i
+
+ 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
+
+ END SUBROUTINE acc1d_basin
+
+END MODULE MOD_Catch_Hist
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90
new file mode 100644
index 0000000000..6f078ba38c
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_LateralFlow.F90
@@ -0,0 +1,496 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_LateralFlow
+!-------------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Lateral flow.
+!
+! Lateral flows in CoLM include
+! 1. Surface flow over hillslopes;
+! 2. Routing flow in rivers;
+! 3. Groundwater (subsurface) lateral flow.
+!
+! Water exchanges between
+! 1. surface flow and rivers;
+! 2. subsurface flow and rivers.
+!
+! Created by Shupeng Zhang, May 2023
+!-------------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Catch_Vars_TimeVariables
+ USE MOD_ElementNeighbour
+ USE MOD_Catch_BasinNetwork
+ USE MOD_Catch_RiverLakeNetwork
+ USE MOD_Catch_HillslopeNetwork
+ USE MOD_Catch_HillslopeFlow
+ USE MOD_Catch_SubsurfaceFlow
+ USE MOD_Catch_RiverLakeFlow
+ USE MOD_Catch_Reservoir
+ USE MOD_Vars_TimeVariables
+ USE MOD_Vars_Global, only: dz_soi
+ USE MOD_Const_Physical, only: denice, denh2o
+ IMPLICIT NONE
+
+ integer, parameter :: nsubstep = 20
+ real(r8) :: dt_average
+
+ real(r8) :: landarea
+ real(r8), allocatable :: patcharea (:) ! m^2
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE lateral_flow_init (lc_year)
+
+#ifdef CoLMDEBUG
+ USE MOD_SPMD_Task
+ USE MOD_Mesh
+ USE MOD_Pixel
+ USE MOD_LandPatch
+ USE MOD_Utils
+#endif
+ USE MOD_Catch_WriteParameters
+ IMPLICIT NONE
+
+ integer, intent(in) :: lc_year ! which year of land cover data used
+
+ integer :: ip, ie, ipxl
+
+ IF (p_is_compute) THEN
+
+ IF (numpatch > 0) THEN
+ allocate (patcharea (numpatch))
+ patcharea(:) = 0.
+ DO ip = 1, numpatch
+ ie = landpatch%ielm(ip)
+ DO ipxl = landpatch%ipxstt(ip), landpatch%ipxend(ip)
+ patcharea(ip) = patcharea(ip) + 1.0e6 * 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 (landpatch%has_shared) THEN
+ patcharea(ip) = patcharea(ip) * landpatch%pctshared(ip)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ landarea = 0.
+ IF (numpatch > 0) landarea = sum(patcharea)
+#ifdef USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, landarea, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err)
+#endif
+ ENDIF
+
+ CALL element_neighbour_init (patcharea, lc_year)
+ CALL river_lake_network_init (patcharea)
+ CALL subsurface_network_init (patcharea)
+ CALL reservoir_init ()
+
+ CALL write_catch_parameters ()
+
+
+ END SUBROUTINE lateral_flow_init
+
+ ! ----------
+ SUBROUTINE lateral_flow (year, deltime)
+
+ USE MOD_Namelist, only: DEF_Reservoir_Method, DEF_USE_Dynamic_Lake
+ USE MOD_Mesh, only: numelm
+ USE MOD_LandHRU, only: landhru, numhru, elm_hru
+ USE MOD_LandPatch, only: numpatch, elm_patch, hru_patch
+
+ USE MOD_Vars_Global, only: nl_lake
+ USE MOD_Const_Physical, only: tfrz
+ USE MOD_Vars_TimeVariables, only: wdsrf, t_lake, lake_icefrac, t_soisno
+ USE MOD_Vars_TimeInvariants, only: lakedepth, dz_lake
+ USE MOD_Vars_1DFluxes, only: rsur, rsub, rnof
+ USE MOD_Catch_Vars_1DFluxes
+ USE MOD_Catch_Vars_TimeVariables
+ USE MOD_Catch_RiverLakeNetwork
+
+ USE MOD_Lake, only: adjust_lake_layer
+
+ USE MOD_UserDefFun, only : findloc_ud
+ USE MOD_RangeCheck
+ IMPLICIT NONE
+
+ integer, intent(in) :: year
+ real(r8), intent(in) :: deltime
+
+ ! Local Variables
+ integer :: i, j, j0, h, ps, pe, istep, s
+ real(r8) :: rnofsrf, sumarea
+ real(r8), allocatable :: wdsrf_p (:), wdsrf_hru_p (:)
+#ifdef CoLMDEBUG
+ real(r8) :: dtolw, tolwat, toldis, maxdvol, maxdvol_g, sumdvol
+ integer :: hs, he, imax, bidmax
+ real(r8), allocatable :: wdsrf_bsnhru_p(:), delvol(:)
+#endif
+
+ IF (p_is_compute) THEN
+
+ ! a) The smallest unit in surface lateral flow (including hillslope flow and river-lake flow)
+ ! is HRU and the main prognostic variable is "wdsrf_bsnhru" (surface water depth).
+ ! b) "wdsrf_bsnhru" is updated by aggregating water depths in patches.
+ ! c) Water surface in a basin ("wdsrf_bsn", defined as the lowest surface water in the basin)
+ ! is derived from "wdsrf_bsnhru".
+ DO i = 1, numhru
+ ps = hru_patch%substt(i)
+ pe = hru_patch%subend(i)
+ wdsrf_hru(i) = sum(wdsrf(ps:pe) * hru_patch%subfrc(ps:pe))
+ wdsrf_hru(i) = wdsrf_hru(i) / 1.0e3 ! mm to m
+ ENDDO
+
+ IF (numhru > 0) THEN
+ allocate (wdsrf_hru_p (numhru))
+ wdsrf_hru_p = wdsrf_hru
+ ENDIF
+
+ IF (numpatch > 0) THEN
+ allocate (wdsrf_p (numpatch))
+ wdsrf_p = wdsrf
+ ENDIF
+
+ dt_average = 0.
+
+ IF (numbasin > 0) wdsrf_bsn_ta (:) = 0.
+ IF (numbasin > 0) momen_riv_ta (:) = 0.
+ IF (numbasin > 0) discharge_ta (:) = 0.
+ IF (numbsnhru > 0) wdsrf_bsnhru_ta (:) = 0.
+ IF (numbsnhru > 0) momen_bsnhru_ta (:) = 0.
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (numresv > 0) volresv_ta (:) = 0.
+ IF (numresv > 0) qresv_in_ta (:) = 0.
+ IF (numresv > 0) qresv_out_ta(:) = 0.
+ ENDIF
+
+ CALL compute_push_data (push_elmhru2bsnhru, wdsrf_hru, wdsrf_bsnhru, spval)
+
+#ifdef CoLMDEBUG
+ IF (numbsnhru > 0) THEN
+ allocate (wdsrf_bsnhru_p (numbsnhru))
+ wdsrf_bsnhru_p = wdsrf_bsnhru
+ ENDIF
+#endif
+
+ DO istep = 1, nsubstep
+
+ ! (1) ------------------- Surface flow over hillslopes. -------------------
+ CALL hillslope_flow (deltime/nsubstep)
+
+ ! (2) ----------------------- River and Lake flow. ------------------------
+ CALL river_lake_flow (year, deltime/nsubstep)
+
+ dt_average = dt_average + deltime/nsubstep/ntimestep_riverlake
+
+ ENDDO
+
+ IF (numbasin > 0) THEN
+ wdsrf_bsn_ta(:) = wdsrf_bsn_ta(:) / deltime
+ momen_riv_ta(:) = momen_riv_ta(:) / deltime
+
+ WHERE (wdsrf_bsn_ta > 0)
+ veloc_riv_ta = momen_riv_ta / wdsrf_bsn_ta
+ ELSE WHERE
+ veloc_riv_ta = 0
+ END WHERE
+
+ discharge_ta = discharge_ta / deltime
+ ENDIF
+
+ IF (numbsnhru > 0) THEN
+ wdsrf_bsnhru_ta(:) = wdsrf_bsnhru_ta(:) / deltime
+ momen_bsnhru_ta(:) = momen_bsnhru_ta(:) / deltime
+
+ WHERE (wdsrf_bsnhru_ta > 0)
+ veloc_bsnhru_ta = momen_bsnhru_ta / wdsrf_bsnhru_ta
+ ELSE WHERE
+ veloc_bsnhru_ta = 0.
+ END WHERE
+ ENDIF
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ DO i = 1, numresv
+ IF (year >= dam_build_year(i)) THEN
+ volresv_ta (i) = volresv_ta (i) / deltime
+ qresv_in_ta (i) = qresv_in_ta (i) / deltime
+ qresv_out_ta(i) = qresv_out_ta(i) / deltime
+ ELSE
+ volresv_ta (i) = spval
+ qresv_in_ta (i) = spval
+ qresv_out_ta(i) = spval
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ! update surface water depth on patches
+ CALL compute_push_data (push_bsnhru2elmhru, wdsrf_bsnhru, wdsrf_hru, spval)
+ DO i = 1, numhru
+ wdsrf_hru(i) = max(0., wdsrf_hru(i))
+ ps = hru_patch%substt(i)
+ pe = hru_patch%subend(i)
+ wdsrf(ps:pe) = wdsrf_hru(i) * 1.0e3 ! m to mm
+ ENDDO
+
+ IF (numpatch > 0) THEN
+ xwsur(:) = (wdsrf_p(:) - wdsrf(:)) / deltime
+ ENDIF
+
+ ! update surface runoff from hillslope to river
+ IF (numpatch > 0) rsur(:) = 0.
+ DO i = 1, numelm
+ IF (lake_id_elm(i) <= 0) THEN
+
+ rnofsrf = 0.
+ sumarea = 0.
+
+ IF (lake_id_elm(i) == 0) THEN
+ j0 = 2 ! regular catchment with river
+ ELSE
+ j0 = 1 ! catchment directly to lake
+ ENDIF
+
+ DO j = j0, hillslope_element(i)%nhru
+ h = hillslope_element(i)%ihru(j)
+ rnofsrf = rnofsrf + (wdsrf_hru_p(h) - wdsrf_hru(h)) * hillslope_element(i)%area(j)
+ sumarea = sumarea + hillslope_element(i)%area(j)
+ ENDDO
+
+ IF (sumarea > 0.) THEN
+ rnofsrf = rnofsrf / sumarea * 1.e3 / deltime ! unit: mm/s
+ DO j = j0, hillslope_element(i)%nhru
+ h = hillslope_element(i)%ihru(j)
+ ps = hru_patch%substt(h)
+ pe = hru_patch%subend(h)
+ rsur(ps:pe) = rnofsrf
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDDO
+
+ ! update fraction of flooded area
+ DO i = 1, numelm
+ IF (lake_id_elm(i) <= 0) THEN
+ DO j = 1, hillslope_element(i)%nhru
+ h = hillslope_element(i)%ihru(j)
+ ps = hru_patch%substt(h)
+ pe = hru_patch%subend(h)
+
+ IF (hillslope_element(i)%indx(j) == 0) THEN
+ fldarea(ps:pe) = 1.0 ! river
+ ELSE
+ s = findloc_ud(hillslope_element(i)%fldprof(:,j) <= wdsrf_hru(h), back = .true.)
+ IF (s == nfldstep) THEN
+ fldarea(ps:pe) = 1.0
+ ELSEIF (s == 0) THEN
+ fldarea(ps:pe) = sqrt(wdsrf_hru(h)/hillslope_element(i)%fldprof(1,j) * 1./nfldstep**2)
+ ELSE
+ fldarea(ps:pe) = sqrt( (wdsrf_hru(h)-hillslope_element(i)%fldprof(s,j)) &
+ / (hillslope_element(i)%fldprof(s+1,j)-hillslope_element(i)%fldprof(s,j)) &
+ * real(2*s+1) / nfldstep**2 + real(s**2)/nfldstep**2 )
+ ENDIF
+ ENDIF
+ ENDDO
+ ELSE
+ ps = elm_patch%substt(i)
+ pe = elm_patch%subend(i)
+ fldarea(ps:pe) = 1.0 ! lake
+ ENDIF
+ ENDDO
+
+#ifdef CoLMDEBUG
+ IF (numbasin > 0) THEN
+
+ allocate (delvol (numbasin))
+
+ delvol(:) = 0
+ DO i = numbasin, 1, -1
+ hs = basin_hru%substt(i)
+ he = basin_hru%subend(i)
+
+ IF (lake_id(i) <= 0) THEN
+ delvol(i) = delvol(i) &
+ + sum((wdsrf_bsnhru_p(hs:he) - wdsrf_bsnhru(hs:he))* hillslope_basin(i)%area)
+ ELSE
+ delvol(i) = delvol(i) &
+ + sum((wdsrf_bsnhru_p(hs:he) - wdsrf_bsnhru(hs:he))* lakeinfo(i)%area0)
+ ENDIF
+
+ IF ((riverdown(i) == 0) .or. (riverdown(i) == -3)) THEN
+ delvol(i) = delvol(i) - discharge_ta(i) * deltime
+ ENDIF
+
+ IF (riversystem == -1) THEN
+ j0 = i; j = ilocdown(i)
+ DO WHILE (j > 0)
+
+ delvol(j) = delvol(j) + delvol(j0)
+ delvol(j0) = 0
+
+ IF ((j > i) .and. (ilocdown(j) > 0)) THEN
+ j0 = j; j = ilocdown(j)
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ sumdvol = sum(delvol)
+
+ IF (riversystem /= -1) THEN
+ maxdvol = sum(delvol)
+#ifdef USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, maxdvol, 1, MPI_REAL8, MPI_SUM, p_comm_rivsys, p_err)
+ maxdvol = abs(maxdvol)
+ imax = findloc_ud(riverdown <= 0)
+ IF (imax > 0) THEN
+ bidmax = basinindex(imax)
+ ELSE
+ bidmax = 0
+ ENDIF
+ CALL mpi_allreduce (MPI_IN_PLACE, bidmax, 1, MPI_INTEGER, MPI_MAX, p_comm_rivsys, p_err)
+#endif
+ ELSE
+ imax = maxloc(abs(delvol),dim=1)
+ maxdvol = abs(delvol(imax))
+ bidmax = basinindex(imax)
+ ENDIF
+
+ ELSE
+ maxdvol = 0.
+ bidmax = 0
+ sumdvol = 0.
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_allreduce (maxdvol, maxdvol_g, 1, MPI_REAL8, MPI_MAX, p_comm_compute, p_err)
+ IF (maxdvol < maxdvol_g) THEN
+ bidmax = 0
+ ENDIF
+ CALL mpi_allreduce (MPI_IN_PLACE, bidmax, 1, MPI_INTEGER, MPI_MAX, p_comm_compute, p_err)
+ CALL mpi_allreduce (MPI_IN_PLACE, sumdvol, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err)
+#else
+ maxdvol_g = maxdvol
+#endif
+
+ IF (allocated(wdsrf_bsnhru_p)) deallocate(wdsrf_bsnhru_p)
+ IF (allocated(delvol )) deallocate(delvol )
+#endif
+
+ ! (3) ------------------- Subsurface lateral flow -------------------
+ CALL subsurface_flow (deltime)
+
+ DO i = 1, numpatch
+ h2osoi(:,i) = wliq_soisno(1:,i)/(dz_soi(1:)*denh2o) + wice_soisno(1:,i)/(dz_soi(1:)*denice)
+ wat(i) = sum(wice_soisno(1:,i)+wliq_soisno(1:,i)) + ldew(i) + scv(i) + wetwat(i)
+ ENDDO
+
+ IF (numpatch > 0) rnof = rsur + rsub
+
+ ! (4) ---------------- vertical layers adjustment ---------------------
+ IF (DEF_USE_Dynamic_Lake) THEN
+ DO i = 1, numpatch
+ IF (wdsrf_p(i) >= 100.) THEN
+ ! wet previously
+ dz_lake(:,i) = dz_lake(:,i) * wdsrf(i)*1.e-3/sum(dz_lake(:,i))
+ ELSE
+ ! dry previously
+ dz_lake(:,i) = wdsrf(i)*1.e-3/nl_lake
+ t_lake (:,i) = t_soisno(1,i)
+ IF (t_soisno(1,i) >= tfrz) THEN
+ lake_icefrac(:,i) = 0.
+ ELSE
+ lake_icefrac(:,i) = 1.
+ ENDIF
+ ENDIF
+
+ IF (wdsrf(i) >= 100.) THEN
+ CALL adjust_lake_layer (nl_lake, dz_lake(:,i), t_lake(:,i), lake_icefrac(:,i))
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ENDIF
+
+#ifdef RangeCheck
+ IF (p_is_compute .and. (p_iam_compute == 0)) THEN
+ write(*,'(/,A)') 'Checking Lateral Flow Variables ...'
+ write(*,'(A,F12.5,A)') 'River Lake Flow minimum average timestep: ', &
+ dt_average/nsubstep, ' seconds'
+ ENDIF
+
+ CALL check_vector_data ('Basin Water Depth [m] ', wdsrf_bsn)
+ CALL check_vector_data ('River Velocity [m/s]', veloc_riv)
+ CALL check_vector_data ('HRU Water Depth [m] ', wdsrf_bsnhru)
+ CALL check_vector_data ('HRU Water Velocity [m/s]', veloc_bsnhru)
+ CALL check_vector_data ('Subsurface bt basin [m/s]', xsubs_elm)
+ CALL check_vector_data ('Subsurface bt HRU [m/s]', xsubs_hru)
+ CALL check_vector_data ('Subsurface bt patch [m/s]', xsubs_pch)
+
+#ifdef CoLMDEBUG
+ IF (p_is_compute) THEN
+
+ dtolw = 0
+ toldis = 0
+
+ IF (numpatch > 0) THEN
+ dtolw = sum(patcharea * xwsur ) / 1.e3 * deltime
+ tolwat = sum(patcharea * wdsrf_p) / 1.e3
+ ENDIF
+ IF (numbasin > 0) THEN
+ toldis = sum(discharge_ta*deltime, mask = (riverdown == 0) .or. (riverdown == -3))
+ dtolw = dtolw - toldis
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err)
+ CALL mpi_allreduce (MPI_IN_PLACE, tolwat, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err)
+ CALL mpi_allreduce (MPI_IN_PLACE, toldis, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err)
+#endif
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,E9.2,A,I0,A,E9.2,A)') 'River system error: max ', maxdvol_g, &
+ ' m^3 in river mouth ', bidmax, ', total ', sumdvol, ' m^3'
+ write(*,'(A,F12.2,A,ES8.1,A,ES10.3,A)') 'Total surface water error: ', dtolw, &
+ ' m^3 of total ', tolwat, ' m^3, discharge ', toldis, ' m^3'
+ ENDIF
+
+ dtolw = 0
+ IF (numpatch > 0) dtolw = sum(patcharea * xwsub) / 1.e3 * deltime
+#ifdef USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, dtolw, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err)
+#endif
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,F12.2,A,ES8.1,A)') 'Total ground water error: ', dtolw, &
+ ' m^3 in area ', landarea, ' m^2'
+ ENDIF
+ ENDIF
+#endif
+#endif
+
+ IF (allocated(wdsrf_p )) deallocate(wdsrf_p )
+ IF (allocated(wdsrf_hru_p)) deallocate(wdsrf_hru_p)
+
+ END SUBROUTINE lateral_flow
+
+ ! ----------
+ SUBROUTINE lateral_flow_final ()
+
+ IMPLICIT NONE
+
+ CALL river_lake_network_final ()
+ CALL subsurface_network_final ()
+ CALL basin_network_final ()
+ CALL reservoir_final ()
+
+ IF (allocated(patcharea)) deallocate(patcharea)
+
+ END SUBROUTINE lateral_flow_final
+
+END MODULE MOD_Catch_LateralFlow
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90
new file mode 100644
index 0000000000..62e2a12557
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Reservoir.F90
@@ -0,0 +1,497 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_Reservoir
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Reservoir module in catchment mesh.
+!
+! Created by Shupeng Zhang, July 2025
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_Catch_BasinNetwork, only : numbasin, basinindex, numresv, bsn2resv, lake_id, lake_type
+
+ real(r8), allocatable :: dam_elv (:) ! dam elevation [m]
+
+ ! parameters
+ 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_mean (:) ! mean natural reservoir outflow [m^3/s]
+ 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]
+
+ integer, allocatable :: dam_build_year(:) ! year in which the dam/barrier was built
+
+ ! time variables
+ real(r8), allocatable :: volresv (:) ! reservoir water volume [m^3]
+ real(r8), allocatable :: qresv_in (:) ! reservoir inflow [m^3/s]
+ real(r8), allocatable :: qresv_out (:) ! reservoir outflow [m^3/s]
+
+ ! time average variables for output
+ real(r8), allocatable :: volresv_ta (:) ! reservoir water volume [m^3]
+ real(r8), allocatable :: qresv_in_ta (:) ! inflow to reservoir [m^3/s]
+ real(r8), allocatable :: qresv_out_ta (:) ! outflow from reservoir [m^3/s]
+
+ integer :: numresv_uniq
+ integer, allocatable :: resv_hylak_id (:) ! HydroLAKE ID of reservoir
+ integer, allocatable :: resv_loc2glb (:) ! global index of reservoir
+
+ ! -- PUBLIC SUBROUTINEs --
+ PUBLIC :: reservoir_init
+ PUBLIC :: reservoir_operation
+ PUBLIC :: reservoir_gather_var
+ PUBLIC :: reservoir_final
+
+CONTAINS
+
+ ! -------
+ SUBROUTINE reservoir_init ( )
+
+ USE MOD_Vars_Global, only: spval
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_NetCDFSerial
+ USE MOD_Utils
+ USE MOD_Catch_RiverLakeNetwork, only : wtsrfelv, bedelv, lakeinfo
+
+ IMPLICIT NONE
+
+ ! Local variables
+ character(len=256) :: basin_info_file, resv_info_file
+ integer :: maxlakeid, mesg(2), isrc, idest, irank
+
+ integer, allocatable :: lake_id_basin (:), ilat_outlet_basin(:), ilon_outlet_basin(:)
+ integer, allocatable :: lake_id_resv (:), ilat_outlet_resv (:), ilon_outlet_resv (:)
+ integer, allocatable :: lake_type_resv(:), lake_id2typ (:)
+ integer, allocatable :: resv_bsn_id (:), idlist (:)
+ integer, allocatable :: all_year_basin(:), all_year_resv (:)
+
+ real(r8), allocatable :: all_vol_basin (:), all_qmean_basin (:), all_qflood_basin (:)
+ real(r8), allocatable :: all_vol_resv (:), all_qmean_resv (:), all_qflood_resv (:)
+ real(r8), allocatable :: all_dhgt_basin(:), all_dhgt_resv (:), dam_height (:)
+
+ real(r8), allocatable :: rcache(:)
+ integer, allocatable :: icache(:)
+ integer :: nbasin, ibasin, irsv, nrecv, nrsv, iloc
+
+
+ IF (p_is_compute) THEN
+
+ IF (numresv > 0) THEN
+
+ allocate (dam_elv (numresv))
+
+ allocate (volresv_total (numresv))
+ allocate (volresv_emerg (numresv))
+ allocate (volresv_adjust(numresv))
+ allocate (volresv_normal(numresv))
+
+ allocate (qresv_mean (numresv))
+ allocate (qresv_flood (numresv))
+ allocate (qresv_adjust (numresv))
+ allocate (qresv_normal (numresv))
+
+ allocate (volresv (numresv))
+ allocate (qresv_in (numresv))
+ allocate (qresv_out (numresv))
+
+ allocate (volresv_ta (numresv))
+ allocate (qresv_in_ta (numresv))
+ allocate (qresv_out_ta (numresv))
+
+ allocate (dam_build_year(numresv))
+
+ allocate (dam_height (numresv))
+
+ ENDIF
+ ENDIF
+
+ ! read in parameters from file.
+ IF (p_is_root) THEN
+
+ basin_info_file = DEF_CatchmentMesh_data
+ CALL ncio_read_serial (basin_info_file, 'lake_id', lake_id_basin )
+ CALL ncio_read_serial (basin_info_file, 'ilat_outlet', ilat_outlet_basin)
+ CALL ncio_read_serial (basin_info_file, 'ilon_outlet', ilon_outlet_basin)
+
+ maxlakeid = maxval(lake_id_basin)
+ IF (maxlakeid > 0) THEN
+
+ resv_info_file = trim(DEF_dir_runtime)//'/HydroLAKES_Reservoir.nc'
+ CALL ncio_read_serial (resv_info_file, 'hylak_id', lake_id_resv )
+ CALL ncio_read_serial (resv_info_file, 'lake_type', lake_type_resv )
+ CALL ncio_read_serial (resv_info_file, 'ilat_outlet', ilat_outlet_resv)
+ CALL ncio_read_serial (resv_info_file, 'ilon_outlet', ilon_outlet_resv)
+ CALL ncio_read_serial (resv_info_file, 'volresv', all_vol_resv )
+ CALL ncio_read_serial (resv_info_file, 'qmean', all_qmean_resv )
+ CALL ncio_read_serial (resv_info_file, 'qflood', all_qflood_resv)
+
+ CALL ncio_read_serial (resv_info_file, 'build_year', all_year_resv)
+ CALL ncio_read_serial (resv_info_file, 'dam_height', all_dhgt_resv)
+
+ allocate (lake_id2typ (-1:maxlakeid))
+ lake_id2typ(:) = 0
+
+ DO irsv = 1, size(lake_id_resv)
+ IF (lake_id_resv(irsv) <= maxlakeid) THEN
+ lake_id2typ(lake_id_resv(irsv)) = lake_type_resv(irsv)
+ ENDIF
+ ENDDO
+
+
+ nbasin = size(lake_id_basin)
+
+ allocate(all_vol_basin (nbasin)); all_vol_basin (:) = spval
+ allocate(all_qmean_basin (nbasin)); all_qmean_basin (:) = spval
+ allocate(all_qflood_basin (nbasin)); all_qflood_basin(:) = spval
+ allocate(all_year_basin (nbasin)); all_year_basin (:) = -99
+ allocate(all_dhgt_basin (nbasin)); all_dhgt_basin (:) = spval
+
+ DO ibasin = 1, nbasin
+ IF (lake_id2typ(lake_id_basin(ibasin)) >= 2) THEN
+ DO irsv = 1, size(lake_id_resv)
+ IF (lake_id_basin(ibasin) == lake_id_resv(irsv)) THEN
+ IF (ilat_outlet_basin(ibasin) == ilat_outlet_resv(irsv)) THEN
+ IF (ilon_outlet_basin(ibasin) == ilon_outlet_resv(irsv)) THEN
+ all_vol_basin (ibasin) = all_vol_resv (irsv)
+ all_qmean_basin (ibasin) = all_qmean_resv (irsv)
+ all_qflood_basin(ibasin) = all_qflood_resv(irsv)
+ all_year_basin (ibasin) = all_year_resv (irsv)
+ all_dhgt_basin (ibasin) = all_dhgt_resv (irsv)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numresv > 0) THEN
+ allocate (resv_bsn_id (numresv))
+ resv_bsn_id = pack(basinindex, lake_type >= 2)
+ ENDIF
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_root) THEN
+ DO irank = 0, p_np_compute-1
+
+ CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ isrc = mesg(1)
+ nrecv = mesg(2)
+
+ IF (nrecv > 0) THEN
+
+ allocate (resv_bsn_id (nrecv))
+ allocate (rcache (nrecv))
+ allocate (icache (nrecv))
+
+ CALL mpi_recv (resv_bsn_id, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ idest = isrc
+
+ rcache = all_vol_basin(resv_bsn_id)
+ CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ rcache = all_qmean_basin(resv_bsn_id)
+ CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ rcache = all_qflood_basin(resv_bsn_id)
+ CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ icache = all_year_basin(resv_bsn_id)
+ CALL mpi_send (icache, nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ rcache = all_dhgt_basin(resv_bsn_id)
+ CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (resv_bsn_id)
+ deallocate (rcache)
+ deallocate (icache)
+
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ mesg(1:2) = (/p_iam_glb, numresv/)
+ CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (numresv > 0) THEN
+ CALL mpi_send (resv_bsn_id, numresv, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+
+ CALL mpi_recv (volresv_total, numresv, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ CALL mpi_recv (qresv_mean, numresv, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ CALL mpi_recv (qresv_flood, numresv, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ CALL mpi_recv (dam_build_year, numresv, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ CALL mpi_recv (dam_height, numresv, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+ ENDIF
+#else
+ IF (numresv > 0) THEN
+ volresv_total = all_vol_basin (resv_bsn_id)
+ qresv_mean = all_qmean_basin (resv_bsn_id)
+ qresv_flood = all_qflood_basin(resv_bsn_id)
+ dam_build_year = all_year_basin (resv_bsn_id)
+ dam_height = all_dhgt_basin (resv_bsn_id)
+ ENDIF
+#endif
+
+ IF (p_is_compute) THEN
+ DO ibasin = 1, numbasin
+ IF (lake_type(ibasin) >= 2) THEN
+
+ irsv = bsn2resv(ibasin)
+
+ dam_height(irsv) = max(dam_height(irsv), wtsrfelv(ibasin)-bedelv(ibasin))
+ dam_height(irsv) = max(dam_height(irsv), lakeinfo(ibasin)%surface(volresv_total(irsv)))
+ dam_height(irsv) = min(dam_height(irsv), 335.)
+
+ dam_elv (irsv) = bedelv(ibasin) + dam_height(irsv)
+ volresv_total (irsv) = lakeinfo(ibasin)%volume( dam_height(irsv) )
+
+ volresv_emerg (irsv) = volresv_total(irsv) * 0.94
+ volresv_adjust(irsv) = volresv_total(irsv) * 0.77
+ volresv_normal(irsv) = volresv_total(irsv) * 0.7
+
+ qresv_normal (irsv) = volresv_normal(irsv)*0.7/(180*86400) + qresv_mean(irsv)*0.25
+ qresv_adjust (irsv) = (qresv_normal(irsv) + qresv_flood(irsv)) * 0.5
+ ENDIF
+ ENDDO
+ ENDIF
+
+
+ IF (p_is_root) THEN
+
+ nrsv = count(lake_id2typ(lake_id_basin) >= 2)
+
+ IF (nrsv > 0) THEN
+
+ allocate (idlist (nrsv))
+
+ numresv_uniq = 0
+ DO ibasin = 1, size(lake_id_basin)
+ IF (lake_id2typ(lake_id_basin(ibasin)) >= 2) THEN
+ CALL insert_into_sorted_list1 ( &
+ lake_id_basin(ibasin), numresv_uniq, idlist, iloc)
+ ENDIF
+ ENDDO
+
+ allocate (resv_hylak_id (numresv_uniq))
+ resv_hylak_id = idlist(1:numresv_uniq)
+
+ deallocate (idlist)
+
+ ELSE
+ numresv_uniq = 0
+ ENDIF
+
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_bcast (numresv_uniq, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+
+ IF (numresv_uniq > 0) THEN
+ IF (.not. p_is_root) allocate (resv_hylak_id (numresv_uniq))
+ CALL mpi_bcast (resv_hylak_id, numresv_uniq, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ ENDIF
+#endif
+
+ IF (p_is_compute) THEN
+ IF (numresv > 0) THEN
+ allocate (resv_loc2glb (numresv))
+ DO ibasin = 1, numbasin
+ IF (lake_type(ibasin) >= 2) THEN
+ resv_loc2glb(bsn2resv(ibasin)) = &
+ find_in_sorted_list1 (lake_id(ibasin), numresv_uniq, resv_hylak_id)
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+
+ IF (allocated(lake_id2typ )) deallocate (lake_id2typ )
+ IF (allocated(lake_id_basin )) deallocate (lake_id_basin )
+ IF (allocated(ilat_outlet_basin)) deallocate (ilat_outlet_basin)
+ IF (allocated(ilon_outlet_basin)) deallocate (ilon_outlet_basin)
+ IF (allocated(lake_id_resv )) deallocate (lake_id_resv )
+ IF (allocated(lake_type_resv )) deallocate (lake_type_resv )
+ IF (allocated(ilat_outlet_resv )) deallocate (ilat_outlet_resv )
+ IF (allocated(ilon_outlet_resv )) deallocate (ilon_outlet_resv )
+ IF (allocated(all_qmean_basin )) deallocate (all_qmean_basin )
+ IF (allocated(all_qflood_basin )) deallocate (all_qflood_basin )
+ IF (allocated(all_qmean_resv )) deallocate (all_qmean_resv )
+ IF (allocated(all_qflood_resv )) deallocate (all_qflood_resv )
+ IF (allocated(all_year_basin )) deallocate (all_year_basin )
+ IF (allocated(all_year_resv )) deallocate (all_year_resv )
+ IF (allocated(all_dhgt_basin )) deallocate (all_dhgt_basin )
+ IF (allocated(all_dhgt_resv )) deallocate (all_dhgt_resv )
+ IF (allocated(dam_height )) deallocate (dam_height )
+ IF (allocated(resv_bsn_id )) deallocate (resv_bsn_id )
+
+
+ END SUBROUTINE reservoir_init
+
+
+ SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout)
+
+ 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 (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_gather_var (varin, varout)
+
+ USE MOD_SPMD_Task
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: varin (:)
+ real(r8), intent(out) :: varout (:)
+
+ ! local variables
+ integer :: irsv, irank
+ real(r8), allocatable :: varall (:,:)
+
+ IF (numresv_uniq == 0) RETURN
+
+ IF (p_is_compute) THEN
+ varout(:) = spval
+ DO irsv = 1, numresv
+ IF (varin(irsv) /= spval) THEN
+ IF (varout(resv_loc2glb(irsv)) /= spval) THEN
+ varout(resv_loc2glb(irsv)) = varout(resv_loc2glb(irsv)) + varin(irsv)
+ ELSE
+ varout(resv_loc2glb(irsv)) = varin(irsv)
+ ENDIF
+ ENDIF
+ ENDDO
+#ifdef USEMPI
+ IF (p_iam_compute == p_root) THEN
+ allocate (varall (numresv_uniq,0:p_np_compute-1))
+ ENDIF
+
+ CALL mpi_gather (varout, numresv_uniq, MPI_REAL8, &
+ varall, numresv_uniq, MPI_REAL8, p_root, p_comm_compute, p_err)
+
+ IF (p_iam_compute == p_root) THEN
+
+ DO irsv = 1, numresv_uniq
+ DO irank = 0, p_np_compute-1
+ IF (irank /= p_root) THEN
+ IF (varall(irsv,irank) /= spval) THEN
+ IF (varout(irsv) /= spval) THEN
+ varout(irsv) = varout(irsv) + varall(irsv,irank)
+ ELSE
+ varout(irsv) = varall(irsv,irank)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+
+ deallocate (varall)
+ ENDIF
+#endif
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_iam_compute == p_root) THEN
+ CALL mpi_send (varout, numresv_uniq, MPI_REAL8, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ IF (p_is_root) THEN
+ CALL mpi_recv (varout, numresv_uniq, MPI_REAL8, p_address_compute(p_root), &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+#endif
+
+ END SUBROUTINE reservoir_gather_var
+
+
+ SUBROUTINE reservoir_final ()
+
+ IMPLICIT NONE
+
+ IF (allocated(dam_elv )) deallocate (dam_elv )
+
+ IF (allocated(resv_hylak_id )) deallocate (resv_hylak_id )
+ IF (allocated(resv_loc2glb )) deallocate (resv_loc2glb )
+
+ 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_mean )) deallocate (qresv_mean )
+ IF (allocated(qresv_flood )) deallocate (qresv_flood )
+ IF (allocated(qresv_adjust )) deallocate (qresv_adjust )
+ IF (allocated(qresv_normal )) deallocate (qresv_normal )
+
+ IF (allocated(dam_build_year)) deallocate (dam_build_year)
+
+ IF (allocated(volresv )) deallocate (volresv )
+ IF (allocated(qresv_in )) deallocate (qresv_in )
+ IF (allocated(qresv_out )) deallocate (qresv_out )
+
+ IF (allocated(volresv_ta )) deallocate (volresv_ta )
+ IF (allocated(qresv_in_ta )) deallocate (qresv_in_ta )
+ IF (allocated(qresv_out_ta )) deallocate (qresv_out_ta )
+
+ END SUBROUTINE reservoir_final
+
+END MODULE MOD_Catch_Reservoir
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90
new file mode 100644
index 0000000000..f0c83ba2d8
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeFlow.F90
@@ -0,0 +1,596 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_RiverLakeFlow
+!-------------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Shallow water equation solver in rivers.
+!
+! References
+! [1] Toro EF. Shock-capturing methods for free-surface shallow flows.
+! Chichester: John Wiley & Sons; 2001.
+! [2] Liang, Q., Borthwick, A. G. L. (2009). Adaptive quadtree simulation of shallow
+! flows with wet-dry fronts over complex topography.
+! Computers and Fluids, 38(2), 221-234.
+! [3] Audusse, E., Bouchut, F., Bristeau, M.-O., Klein, R., Perthame, B. (2004).
+! A Fast and Stable Well-Balanced Scheme with Hydrostatic Reconstruction for
+! Shallow Water Flows. SIAM Journal on Scientific Computing, 25(6), 2050-2065.
+!
+! Created by Shupeng Zhang, May 2023
+!-------------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ IMPLICIT NONE
+
+ real(r8), parameter :: nmanning_riv = 0.03
+
+ real(r8), parameter :: RIVERMIN = 1.e-5_r8
+ real(r8), parameter :: VOLUMEMIN = 1.e-5_r8
+
+ integer :: ntimestep_riverlake
+
+CONTAINS
+
+ ! ---------
+ SUBROUTINE river_lake_flow (year, dt)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist, only : DEF_Reservoir_Method
+ USE MOD_Utils
+ USE MOD_Catch_BasinNetwork
+ USE MOD_Catch_HillslopeNetwork
+ USE MOD_Catch_RiverLakeNetwork
+ USE MOD_Catch_Reservoir
+ USE MOD_Catch_Vars_TimeVariables
+ USE MOD_Catch_Vars_1DFluxes
+ USE MOD_Const_Physical, only: grav
+ IMPLICIT NONE
+
+ integer, intent(in) :: year
+ real(r8), intent(in) :: dt
+
+ ! Local Variables
+ integer :: hs, he, i, j, irsv
+ real(r8) :: dt_this
+
+ real(r8), allocatable :: wdsrf_bsn_ds(:)
+ real(r8), allocatable :: veloc_riv_ds(:)
+ real(r8), allocatable :: momen_riv_ds(:)
+
+ real(r16), allocatable :: hflux_fc(:)
+ real(r16), allocatable :: mflux_fc(:)
+ real(r16), allocatable :: zgrad_dn(:)
+
+ real(r16), allocatable :: hflux_resv(:)
+ real(r16), allocatable :: mflux_resv(:)
+
+ real(r16), allocatable :: sum_hflux_riv(:)
+ real(r16), allocatable :: sum_mflux_riv(:)
+ real(r16), allocatable :: sum_zgrad_riv(:)
+
+ real(r8) :: veloct_fc, height_fc, momen_fc, zsurf_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) :: totalvolume, friction, dvol, nextl, nexta, nextv, ddep
+ real(r8), allocatable :: dt_res(:), dt_all(:), dt_tmp(:)
+ logical, allocatable :: hmask(:), bsnfilter(:)
+
+
+ IF (p_is_compute) THEN
+
+ ! update water depth in basin by aggregating water depths in patches
+ DO i = 1, numbasin
+ hs = basin_hru%substt(i)
+ he = basin_hru%subend(i)
+
+ IF (lake_id(i) <= 0) THEN
+ ! river or lake catchment
+ ! Water surface in a basin is defined as the lowest surface water in the basin
+ wdsrf_bsn(i) = minval(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he)) - handmin(i)
+
+ ELSEIF (lake_id(i) > 0) THEN
+ ! lake
+ totalvolume = sum(wdsrf_bsnhru(hs:he) * lakeinfo(i)%area0)
+ wdsrf_bsn(i) = lakeinfo(i)%surface(totalvolume)
+ ENDIF
+
+
+ IF (lake_id(i) == 0) THEN
+ ! river momentum is less or equal than the momentum at last time step.
+ IF (wdsrf_bsn_prev(i) < wdsrf_bsn(i)) THEN
+ momen_riv(i) = wdsrf_bsn_prev(i) * veloc_riv(i)
+ veloc_riv(i) = momen_riv(i) / wdsrf_bsn(i)
+ ELSE
+ momen_riv(i) = wdsrf_bsn(i) * veloc_riv(i)
+ ENDIF
+ ELSE
+ ! water in lake or lake catchment is assumued to be stationary.
+ ! TODO: lake dynamics
+ momen_riv(i) = 0
+ veloc_riv(i) = 0
+ ENDIF
+
+ ENDDO
+
+ IF (numbasin > 0) THEN
+
+ allocate (wdsrf_bsn_ds (numbasin))
+ allocate (veloc_riv_ds (numbasin))
+ allocate (momen_riv_ds (numbasin))
+ allocate (hflux_fc (numbasin))
+ allocate (mflux_fc (numbasin))
+ allocate (zgrad_dn (numbasin))
+ allocate (sum_hflux_riv (numbasin))
+ allocate (sum_mflux_riv (numbasin))
+ allocate (sum_zgrad_riv (numbasin))
+ allocate (bsnfilter (numbasin))
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ allocate (hflux_resv (numbasin))
+ allocate (mflux_resv (numbasin))
+ ENDIF
+
+ ENDIF
+
+ allocate (dt_res (numrivsys))
+ allocate (dt_all (numrivsys))
+
+ ntimestep_riverlake = 0
+
+ dt_res(:) = dt
+
+ DO WHILE (any(dt_res > 0))
+
+ ntimestep_riverlake = ntimestep_riverlake + 1
+
+ DO i = 1, numbasin
+ bsnfilter(i) = dt_res(irivsys(i)) > 0
+ IF (bsnfilter(i)) THEN
+ sum_hflux_riv(i) = 0.
+ sum_mflux_riv(i) = 0.
+ sum_zgrad_riv(i) = 0.
+ ENDIF
+ ENDDO
+
+ WHERE (bsnfilter) ntacc_bsn = ntacc_bsn + 1
+
+ CALL pull_from_downstream (wdsrf_bsn, wdsrf_bsn_ds, bsnfilter)
+ CALL pull_from_downstream (veloc_riv, veloc_riv_ds, bsnfilter)
+ CALL pull_from_downstream (momen_riv, momen_riv_ds, bsnfilter)
+
+ ! velocity in ocean or inland depression is assumed to be 0.
+ IF (numbasin > 0) THEN
+ WHERE (riverdown <= 0)
+ veloc_riv_ds = 0.
+ END WHERE
+ ENDIF
+
+ dt_all(:) = dt_res(:)
+
+ DO i = 1, numbasin
+
+ IF (.not. bsnfilter(i)) CYCLE
+
+ IF (riverdown(i) >= 0) THEN
+
+ IF (riverdown(i) > 0) THEN
+ ! both elements are dry.
+ IF ((wdsrf_bsn(i) < RIVERMIN) .and. (wdsrf_bsn_ds(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 (riverdown(i) > 0) THEN
+ bedelv_fc = max(bedelv(i), bedelv_ds(i))
+ IF ((lake_type(i) == 2) .or. (lake_type(i) == 3)) THEN
+ ! for reservoir (type=2) or controlled lake (type=3)
+ IF ((DEF_Reservoir_Method > 0) &
+ .and. (year >= dam_build_year(bsn2resv(i)))) THEN
+ bedelv_fc = max(bedelv_fc, dam_elv(bsn2resv(i)))
+ ENDIF
+ ENDIF
+ height_up = max(0., wdsrf_bsn(i) +bedelv(i) -bedelv_fc)
+ height_dn = max(0., wdsrf_bsn_ds(i)+bedelv_ds(i)-bedelv_fc)
+ ELSEIF (riverdown(i) == 0) THEN ! for river mouth
+ bedelv_fc = bedelv(i)
+ height_up = wdsrf_bsn(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_riv_ds(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_riv_ds(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_riv_ds(i) - 2.0 * sqrt(grav*height_dn)
+ ENDIF
+
+ IF (height_dn > 0) THEN
+ vwave_dn = max(veloc_riv_ds(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_riv_ds(i) * height_dn
+ mflux_up = veloc_riv(i)**2 * height_up + 0.5*grav * height_up**2
+ mflux_dn = veloc_riv_ds(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 (riverdown(i) == -3) 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_bsn(i) > riverdpth(i)) THEN
+
+ ! reconstruction of height of water near interface
+ height_up = wdsrf_bsn(i)
+ height_dn = riverdpth(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 (riverdown(i) == -1) THEN ! inland depression
+ hflux_fc(i) = 0
+ mflux_fc(i) = 0
+ ENDIF
+
+ IF ((lake_id(i) < 0) .and. (hflux_fc(i) < 0)) THEN
+ dt_this = dt_all(irivsys(i))
+ hflux_fc(i) = &
+ max(hflux_fc(i), (height_up-height_dn) / dt_this * sum(hillslope_basin(i)%area, &
+ mask = hillslope_basin(i)%hand <= wdsrf_bsn(i) + handmin(i)))
+ ENDIF
+
+ ! reservoir operation.
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (lake_type(i) == 2) THEN
+ IF (year >= dam_build_year(bsn2resv(i))) THEN
+ hflux_fc(i) = 0.
+ mflux_fc(i) = 0.
+ zgrad_dn(i) = 0.
+ ENDIF
+ ENDIF
+ ENDIF
+
+ sum_hflux_riv(i) = sum_hflux_riv(i) + hflux_fc(i)
+ sum_mflux_riv(i) = sum_mflux_riv(i) + mflux_fc(i)
+
+ ENDDO
+
+ IF (numbasin > 0) THEN
+ hflux_fc = - hflux_fc; mflux_fc = - mflux_fc; zgrad_dn = - zgrad_dn
+ ENDIF
+
+ CALL push_to_downstream (hflux_fc, sum_hflux_riv, bsnfilter)
+ CALL push_to_downstream (mflux_fc, sum_mflux_riv, bsnfilter)
+ CALL push_to_downstream (zgrad_dn, sum_zgrad_riv, bsnfilter)
+
+ IF (numbasin > 0) THEN
+ hflux_fc = - hflux_fc; mflux_fc = - mflux_fc; zgrad_dn = - zgrad_dn
+ ENDIF
+
+ ! reservoir operation.
+ IF (DEF_Reservoir_Method > 0) THEN
+
+ DO i = 1, numbasin
+
+ hflux_resv(i) = 0.
+ mflux_resv(i) = 0.
+
+ IF (bsnfilter(i)) THEN
+ IF ((lake_type(i) == 2) .and. (riverdown(i) /= -1)) THEN
+ IF (year >= dam_build_year(bsn2resv(i))) THEN
+
+ irsv = bsn2resv(i)
+ qresv_in(irsv) = - sum_hflux_riv(i)
+ volresv (irsv) = lakeinfo(i)%volume( wdsrf_bsn(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_bsn(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
+ ENDIF
+ ENDIF
+ ENDDO
+
+ CALL push_to_downstream (hflux_resv, sum_hflux_riv, bsnfilter)
+ CALL push_to_downstream (mflux_resv, sum_mflux_riv, bsnfilter)
+
+ ENDIF
+
+ DO i = 1, numbasin
+
+ IF (.not. bsnfilter(i)) CYCLE
+
+ dt_this = dt_all(irivsys(i))
+
+ ! constraint 1: CFL condition (only for rivers)
+ IF ((lake_id(i) == 0) .and. (riverdown(i) /= -1)) THEN
+ IF ((veloc_riv(i) /= 0.) .or. (wdsrf_bsn(i) > 0.)) THEN
+ dt_this = min(dt_this, riverlen(i)/(abs(veloc_riv(i))+sqrt(grav*wdsrf_bsn(i)))*0.8)
+ ENDIF
+ ENDIF
+
+ ! constraint 2: Avoid negative values of water
+ IF (sum_hflux_riv(i) > 0) THEN
+ IF (lake_id(i) <= 0) THEN
+ ! for river or lake catchment
+ totalvolume = sum((wdsrf_bsn(i) + handmin(i) - hillslope_basin(i)%hand) &
+ * hillslope_basin(i)%area, &
+ mask = wdsrf_bsn(i) + handmin(i) >= hillslope_basin(i)%hand)
+ ELSEIF (lake_id(i) > 0) THEN
+ ! for lake
+ totalvolume = lakeinfo(i)%volume(wdsrf_bsn(i))
+ ENDIF
+
+ dt_this = min(dt_this, totalvolume / sum_hflux_riv(i))
+
+ ENDIF
+
+ ! constraint 3: Avoid change of flow direction (only for rivers)
+ IF (lake_id(i) == 0) 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) * riverarea(i) / (sum_mflux_riv(i)-sum_zgrad_riv(i))))
+ ENDIF
+ ENDIF
+
+ dt_all(irivsys(i)) = min(dt_this, dt_all(irivsys(i)))
+
+ ENDDO
+
+#ifdef USEMPI
+ IF (riversystem /= -1) THEN
+ CALL mpi_allreduce (MPI_IN_PLACE, dt_all, 1, MPI_REAL8, MPI_MIN, p_comm_rivsys, p_err)
+ ENDIF
+#endif
+
+ DO i = 1, numbasin
+
+ IF (.not. bsnfilter(i)) CYCLE
+
+ IF (lake_id(i) <= 0) THEN
+ ! rivers or lake catchments
+ hs = basin_hru%substt(i)
+ he = basin_hru%subend(i)
+ allocate (hmask (hillslope_basin(i)%nhru))
+
+ totalvolume = sum((wdsrf_bsn(i) + handmin(i) - hillslope_basin(i)%hand) &
+ * hillslope_basin(i)%area, &
+ mask = wdsrf_bsn(i) + handmin(i) >= hillslope_basin(i)%hand)
+
+ totalvolume = totalvolume - sum_hflux_riv(i) * dt_all(irivsys(i))
+
+ IF (totalvolume < VOLUMEMIN) THEN
+ DO j = 1, hillslope_basin(i)%nhru
+ IF (hillslope_basin(i)%hand(j) <= wdsrf_bsn(i) + handmin(i)) THEN
+ wdsrf_bsnhru(j+hs-1) = wdsrf_bsnhru(j+hs-1) &
+ - (wdsrf_bsn(i) + handmin(i) - hillslope_basin(i)%hand(j))
+ ENDIF
+ ENDDO
+ wdsrf_bsn(i) = 0
+ ELSE
+
+ dvol = sum_hflux_riv(i) * dt_all(irivsys(i))
+ IF (dvol > VOLUMEMIN) THEN
+ DO WHILE (dvol > VOLUMEMIN)
+ hmask = hillslope_basin(i)%hand < wdsrf_bsn(i) + handmin(i)
+ nextl = maxval(hillslope_basin(i)%hand, mask = hmask)
+ nexta = sum (hillslope_basin(i)%area, mask = hmask)
+ nextv = nexta * (wdsrf_bsn(i)+handmin(i)-nextl)
+ IF (nextv > dvol) THEN
+ ddep = dvol/nexta
+ dvol = 0.
+ ELSE
+ ddep = wdsrf_bsn(i)+handmin(i) - nextl
+ dvol = dvol - nextv
+ ENDIF
+
+ wdsrf_bsn(i) = wdsrf_bsn(i) - ddep
+
+ DO j = 1, hillslope_basin(i)%nhru
+ IF (hmask(j)) THEN
+ wdsrf_bsnhru(j+hs-1) = wdsrf_bsnhru(j+hs-1) - ddep
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSEIF (dvol < -VOLUMEMIN) THEN
+ hmask = .true.
+ nexta = 0.
+ DO WHILE (dvol < -VOLUMEMIN)
+ IF (any(hmask)) THEN
+ j = minloc(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he), 1, mask = hmask)
+ nexta = nexta + hillslope_basin(i)%area(j)
+ hmask(j) = .false.
+ ENDIF
+ IF (any(hmask)) THEN
+ nextl = minval(hillslope_basin(i)%hand + wdsrf_bsnhru(hs:he), mask = hmask)
+ nextv = nexta*(nextl-(wdsrf_bsn(i)+handmin(i)))
+ IF ((-dvol) > nextv) THEN
+ ddep = nextl - (wdsrf_bsn(i)+handmin(i))
+ dvol = dvol + nextv
+ ELSE
+ ddep = (-dvol)/nexta
+ dvol = 0.
+ ENDIF
+ ELSE
+ ddep = (-dvol)/nexta
+ dvol = 0.
+ ENDIF
+
+ wdsrf_bsn(i) = wdsrf_bsn(i) + ddep
+
+ DO j = 1, hillslope_basin(i)%nhru
+ IF (.not. hmask(j)) THEN
+ wdsrf_bsnhru(j+hs-1) = wdsrf_bsnhru(j+hs-1) + ddep
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ ENDIF
+ deallocate(hmask)
+
+ ELSE
+ totalvolume = lakeinfo(i)%volume(wdsrf_bsn(i))
+ totalvolume = totalvolume - sum_hflux_riv(i) * dt_all(irivsys(i))
+ wdsrf_bsn(i) = lakeinfo(i)%surface(totalvolume)
+ ENDIF
+
+ IF ((lake_id(i) /= 0) .or. (wdsrf_bsn(i) < RIVERMIN)) THEN
+ momen_riv(i) = 0
+ veloc_riv(i) = 0
+ ELSE
+ friction = grav * nmanning_riv**2 / wdsrf_bsn(i)**(7.0/3.0) * abs(momen_riv(i))
+ momen_riv(i) = (momen_riv(i) &
+ - (sum_mflux_riv(i) - sum_zgrad_riv(i)) / riverarea(i) * dt_all(irivsys(i))) &
+ / (1 + friction * dt_all(irivsys(i)))
+ veloc_riv(i) = momen_riv(i) / wdsrf_bsn(i)
+ ENDIF
+
+ ! inland depression river
+ IF ((lake_id(i) == 0) .and. (riverdown(i) == -1)) 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.)
+
+ ENDDO
+
+ DO i = 1, numbasin
+ IF (bsnfilter(i)) THEN
+
+ wdsrf_bsn_ta (i) = wdsrf_bsn_ta (i) + wdsrf_bsn(i) * dt_all(irivsys(i))
+ momen_riv_ta (i) = momen_riv_ta (i) + momen_riv(i) * dt_all(irivsys(i))
+ discharge_ta (i) = discharge_ta (i) + hflux_fc (i) * dt_all(irivsys(i))
+
+ IF (lake_id(i) > 0) THEN ! for lakes
+ hs = basin_hru%substt(i)
+ he = basin_hru%subend(i)
+ DO j = hs, he
+ wdsrf_bsnhru(j) = &
+ max(wdsrf_bsn(i) - (lakeinfo(i)%depth(1) - lakeinfo(i)%depth0(j-hs+1)), 0.)
+ wdsrf_bsnhru_ta(j) = wdsrf_bsnhru_ta(j) + wdsrf_bsnhru(j) * dt_all(irivsys(i))
+ ENDDO
+ ENDIF
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (lake_type(i) == 2) THEN
+ IF (year >= dam_build_year(bsn2resv(i))) THEN
+ irsv = bsn2resv(i)
+ volresv_ta (irsv) = volresv_ta (irsv) + volresv (irsv) * dt_all(irivsys(i))
+ qresv_in_ta (irsv) = qresv_in_ta (irsv) + qresv_in (irsv) * dt_all(irivsys(i))
+ qresv_out_ta(irsv) = qresv_out_ta(irsv) + qresv_out(irsv) * dt_all(irivsys(i))
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDDO
+
+ dt_res = dt_res - dt_all
+
+ ENDDO
+
+ IF (numbasin > 0) wdsrf_bsn_prev(:) = wdsrf_bsn(:)
+
+#ifdef USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, ntimestep_riverlake, 1, MPI_INTEGER, MPI_MAX, p_comm_compute, p_err)
+#endif
+
+ IF (allocated(wdsrf_bsn_ds )) deallocate(wdsrf_bsn_ds )
+ IF (allocated(veloc_riv_ds )) deallocate(veloc_riv_ds )
+ IF (allocated(momen_riv_ds )) deallocate(momen_riv_ds )
+ IF (allocated(hflux_fc )) deallocate(hflux_fc )
+ IF (allocated(mflux_fc )) deallocate(mflux_fc )
+ IF (allocated(zgrad_dn )) deallocate(zgrad_dn )
+ IF (allocated(hflux_resv )) deallocate(hflux_resv )
+ IF (allocated(mflux_resv )) deallocate(mflux_resv )
+ 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(bsnfilter )) deallocate(bsnfilter )
+
+ ENDIF
+
+ END SUBROUTINE river_lake_flow
+
+END MODULE MOD_Catch_RiverLakeFlow
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90
new file mode 100644
index 0000000000..7ed4ee95a7
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_RiverLakeNetwork.F90
@@ -0,0 +1,1145 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_RiverLakeNetwork
+!--------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! River networks: data and communication subroutines.
+!
+! Created by Shupeng Zhang, May 2023
+!--------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Vars_Global, only: spval
+ USE MOD_Pixelset
+ USE MOD_Catch_BasinNetwork
+ USE MOD_Catch_HillslopeNetwork
+ USE MOD_Catch_Vars_TimeVariables
+ IMPLICIT NONE
+
+ ! -- river parameters --
+ real(r8), allocatable :: riverlen (:)
+ real(r8), allocatable :: riverelv (:)
+ real(r8), allocatable :: riverwth (:)
+ real(r8), allocatable :: riverarea (:)
+ real(r8), allocatable :: riverdpth (:)
+
+ real(r8), allocatable :: basinelv (:)
+ real(r8), allocatable :: bedelv (:)
+ real(r8), allocatable :: handmin (:)
+
+ real(r8), allocatable :: wtsrfelv (:)
+
+ ! index of downstream river
+ ! > 0 : other catchment; 0 : river mouth; -1 : inland depression
+ integer, allocatable :: riverdown (:)
+ integer, allocatable :: ilocdown (:)
+ logical, allocatable :: to_lake (:)
+
+ real(r8), allocatable :: riverlen_ds (:)
+ real(r8), allocatable :: wtsrfelv_ds (:)
+ real(r8), allocatable :: riverwth_ds (:)
+ real(r8), allocatable :: bedelv_ds (:)
+
+ real(r8), allocatable :: outletwth (:)
+
+ integer :: riversystem
+
+ integer :: numrivsys
+ integer, allocatable :: irivsys (:)
+
+#ifdef USEMPI
+ integer :: p_comm_rivsys
+
+ integer :: numbsnlink
+ integer, allocatable :: linkbindex (:)
+
+ integer :: nlink_me
+ integer, allocatable :: linkpush (:)
+ integer, allocatable :: linkpull (:)
+#endif
+
+ ! -- lake data type --
+ type :: lake_info_type
+ integer :: nsub
+ real(r8), allocatable :: area0 (:) ! area data in HRU order
+ real(r8), allocatable :: area (:) ! area data in the order from deepest to shallowest HRU
+ real(r8), allocatable :: depth0 (:) ! depth data in HRU order
+ real(r8), allocatable :: depth (:) ! depth data in the order from deepest to shallowest HRU
+ ! a curve describing the relationship between depth of water from lake bottom and total water volume
+ ! the i-th value corresponds to the volume when water depth is at i-th depth
+ real(r8), allocatable :: dep_vol_curve (:)
+ CONTAINS
+ procedure, PUBLIC :: surface => retrieve_lake_surface_from_volume
+ procedure, PUBLIC :: volume => retrieve_lake_volume_from_surface
+ final :: lake_info_free_mem
+ END type lake_info_type
+
+ ! -- lake information --
+ type(lake_info_type), allocatable :: lakeinfo (:)
+
+ ! -- information of HRU in basin --
+ type(hillslope_network_type), pointer :: hillslope_basin (:)
+
+
+ ! ----- subroutines and functions -----
+ PUBLIC :: river_lake_network_init
+ PUBLIC :: pull_from_downstream
+ PUBLIC :: push_to_downstream
+ PUBLIC :: calc_riverdepth_from_runoff
+ PUBLIC :: retrieve_lake_surface_from_volume
+ PUBLIC :: river_lake_network_final
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE river_lake_network_init (patcharea)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_NetCDFSerial
+ USE MOD_Mesh
+ USE MOD_Pixel
+ USE MOD_LandElm
+ USE MOD_LandHRU
+ USE MOD_LandPatch
+ USE MOD_ElementNeighbour
+ USE MOD_DataType
+ USE MOD_Utils
+ USE MOD_UserDefFun
+ USE MOD_Vars_TimeInvariants, only: lakedepth
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: patcharea (:)
+
+ ! Local Variables
+ character(len=256) :: river_file, rivdpt_file
+ logical :: use_calc_rivdpt
+
+ integer :: totalnumbasin, ibasin, jbasin, inb, iloc, ielm, i, j, ilink
+ integer :: irank, mesg(2), isrc, idest, nrecv
+
+#ifdef USEMPI
+ integer :: nblink_all
+ integer, allocatable :: linkbindex_all (:)
+ integer, allocatable :: linkrivmth_all (:)
+#endif
+
+ logical , allocatable :: is_link (:)
+ logical , allocatable :: link_on_me (:)
+
+ integer :: nnode
+ integer, allocatable :: route(:)
+
+ integer , allocatable :: icache (:)
+ real(r8), allocatable :: rcache (:)
+ logical , allocatable :: lcache (:)
+
+ integer, allocatable :: bindex(:), addrbasin(:), addrdown(:)
+ integer, allocatable :: basin_sorted(:), basin_order(:), order (:)
+
+ logical, allocatable :: bsnfilter(:)
+
+ ! for lakes
+ integer :: ps, pe, nsublake, hs, he, ihru
+ integer, allocatable :: all_lake_id (:), lake_id_elm (:)
+ integer , allocatable :: lakedown_id_elm(:), lakedown_id_bsn (:)
+ real(r8), allocatable :: lakedepth_hru (:), lakedepth_bsnhru(:)
+ real(r8), allocatable :: lakeoutlet_elm (:), lakeoutlet_bsn (:)
+ real(r8), allocatable :: unitarea_hru (:), unitarea_bsnhru (:)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ use_calc_rivdpt = DEF_USE_EstimatedRiverDepth
+ river_file = DEF_CatchmentMesh_data
+
+ ! step 1: read in parameters from file.
+ IF (p_is_root) THEN
+
+ CALL ncio_read_serial (river_file, 'lake_id', all_lake_id)
+
+ CALL ncio_read_serial (river_file, 'basin_downstream', riverdown)
+ CALL ncio_read_serial (river_file, 'river_length' , riverlen )
+ CALL ncio_read_serial (river_file, 'river_elevation' , riverelv )
+ CALL ncio_read_serial (river_file, 'basin_elevation' , basinelv )
+
+ IF (.not. use_calc_rivdpt) THEN
+ CALL ncio_read_serial (river_file, 'river_depth' , riverdpth)
+ ENDIF
+
+ riverlen = riverlen * 1.e3 ! km to m
+
+ totalnumbasin = size(riverdown)
+ allocate (to_lake (totalnumbasin))
+ to_lake = .false.
+ DO i = 1, totalnumbasin
+ IF (riverdown(i) > 0) THEN
+ to_lake(i) = all_lake_id(riverdown(i)) > 0
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ ! step 2: Estimate river depth by using runoff data.
+ IF (use_calc_rivdpt) THEN
+ CALL calc_riverdepth_from_runoff (patcharea)
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_root) THEN
+
+ DO irank = 0, p_np_compute-1
+
+ CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ isrc = mesg(1)
+ nrecv = mesg(2)
+
+ IF (nrecv > 0) THEN
+
+ allocate (bindex (nrecv))
+ allocate (icache (nrecv))
+ allocate (rcache (nrecv))
+ allocate (lcache (nrecv))
+
+ CALL mpi_recv (bindex, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ idest = isrc
+
+ icache = riverdown(bindex)
+ CALL mpi_send (icache, nrecv, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ lcache = to_lake(bindex)
+ CALL mpi_send (lcache, nrecv, MPI_LOGICAL, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ rcache = riverlen(bindex)
+ CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ rcache = riverelv(bindex)
+ CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ rcache = riverdpth(bindex)
+ CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ rcache = basinelv(bindex)
+ CALL mpi_send (rcache, nrecv, MPI_REAL8, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (bindex)
+ deallocate (icache)
+ deallocate (rcache)
+ deallocate (lcache)
+
+ ENDIF
+ ENDDO
+
+ deallocate (all_lake_id)
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ mesg(1:2) = (/p_iam_glb, numbasin/)
+ CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (numbasin > 0) THEN
+ CALL mpi_send (basinindex, numbasin, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+
+ allocate (riverdown (numbasin))
+ CALL mpi_recv (riverdown, numbasin, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (to_lake (numbasin))
+ CALL mpi_recv (to_lake, numbasin, MPI_LOGICAL, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (riverlen (numbasin))
+ CALL mpi_recv (riverlen, numbasin, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (riverelv (numbasin))
+ CALL mpi_recv (riverelv, numbasin, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (riverdpth (numbasin))
+ CALL mpi_recv (riverdpth, numbasin, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (basinelv (numbasin))
+ CALL mpi_recv (basinelv, numbasin, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ IF (numbasin > 0) THEN
+
+ riverdown = riverdown(basinindex)
+ to_lake = to_lake (basinindex)
+ riverlen = riverlen (basinindex)
+ riverelv = riverelv (basinindex)
+ riverdpth = riverdpth(basinindex)
+ basinelv = basinelv (basinindex)
+
+ ENDIF
+#endif
+
+#ifdef USEMPI
+ ! get address of basins
+ IF (p_is_root) THEN
+
+ allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1
+
+ DO irank = 0, p_np_compute-1
+
+ CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ isrc = mesg(1)
+ nrecv = mesg(2)
+
+ IF (nrecv > 0) THEN
+ allocate (bindex (nrecv))
+
+ CALL mpi_recv (bindex, nrecv, MPI_INTEGER, isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ addrbasin(bindex) = isrc
+
+ deallocate(bindex)
+ ENDIF
+
+ ENDDO
+
+ ELSEIF (p_is_compute) THEN
+
+ mesg(1:2) = (/p_iam_glb, numbasin/)
+ CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (numbasin > 0) THEN
+ CALL mpi_send (basinindex, numbasin, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ ENDIF
+
+
+ IF (p_is_root) THEN
+
+ allocate (addrdown (totalnumbasin))
+ allocate (is_link (totalnumbasin)); is_link = .false.
+
+ DO ibasin = 1, totalnumbasin
+ IF (riverdown(ibasin) >= 1) THEN
+ addrdown(ibasin) = addrbasin(riverdown(ibasin))
+ IF (addrdown(ibasin) /= addrbasin(ibasin)) THEN
+ is_link(riverdown(ibasin)) = .true.
+ ENDIF
+ ELSE
+ addrdown(ibasin) = addrbasin(ibasin)
+ ENDIF
+ ENDDO
+
+ nblink_all = count(is_link)
+
+ IF (nblink_all > 0) THEN
+ allocate (linkbindex_all (nblink_all))
+ allocate (linkrivmth_all (nblink_all))
+ linkbindex_all = pack((/(ibasin, ibasin = 1, totalnumbasin)/), mask = is_link)
+ linkrivmth_all = pack(rivermouth, mask = is_link)
+ ENDIF
+
+ deallocate (addrdown)
+ deallocate (is_link )
+
+ write(*,'(/,A,I5,A,/)') 'There are ', nblink_all, ' links between processors.'
+
+ ENDIF
+
+ CALL mpi_bcast (nblink_all, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ IF (nblink_all > 0) THEN
+ IF (.not. allocated(linkbindex_all)) allocate (linkbindex_all (nblink_all))
+ IF (.not. allocated(linkrivmth_all)) allocate (linkrivmth_all (nblink_all))
+ CALL mpi_bcast (linkbindex_all, nblink_all, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ CALL mpi_bcast (linkrivmth_all, nblink_all, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ ENDIF
+#endif
+
+ IF (p_is_compute) THEN
+
+ IF (numbasin > 0) THEN
+ allocate (basin_sorted (numbasin))
+ allocate (basin_order (numbasin))
+ basin_sorted = basinindex
+ basin_order = (/(ibasin, ibasin = 1, numbasin)/)
+
+ CALL quicksort (numbasin, basin_sorted, basin_order)
+ ENDIF
+
+ riversystem = -1
+
+#ifdef USEMPI
+ IF (nblink_all > 0) THEN
+ DO ibasin = 1, numbasin
+
+ iloc = find_in_sorted_list1 (riverdown(ibasin), nblink_all, linkbindex_all)
+ IF (iloc <= 0) THEN
+ iloc = find_in_sorted_list1 (basinindex(ibasin), nblink_all, linkbindex_all)
+ ENDIF
+
+ IF (iloc > 0) THEN
+ IF (riversystem == -1) THEN
+ riversystem = linkrivmth_all(iloc)
+ ELSEIF (riversystem /= linkrivmth_all(iloc)) THEN
+ write(*,*) 'Warning: river system allocation error!'
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (riversystem /= -1) THEN
+ numbsnlink = count(linkrivmth_all == riversystem)
+ allocate (linkbindex (numbsnlink))
+ linkbindex = pack(linkbindex_all, linkrivmth_all == riversystem)
+
+ allocate (link_on_me (numbsnlink)); link_on_me = .false.
+
+ DO ibasin = 1, numbsnlink
+ iloc = find_in_sorted_list1 (linkbindex(ibasin), numbasin, basin_sorted)
+ IF (iloc > 0) THEN
+ link_on_me(ibasin) = .true.
+ ENDIF
+ ENDDO
+
+ nlink_me = count(link_on_me)
+
+ IF (nlink_me > 0) THEN
+ allocate (linkpush (nlink_me))
+ allocate (linkpull (nlink_me))
+ ilink = 0
+ DO ibasin = 1, numbsnlink
+ IF (link_on_me(ibasin)) THEN
+ ilink = ilink + 1
+ iloc = find_in_sorted_list1 (linkbindex(ibasin), numbasin, basin_sorted)
+ linkpush(ilink) = basin_order(iloc)
+ linkpull(ilink) = ibasin
+ ENDIF
+ ENDDO
+ ENDIF
+
+ deallocate (link_on_me)
+ ENDIF
+
+ IF (riversystem /= -1) THEN
+ CALL mpi_comm_split (p_comm_compute, riversystem, p_iam_compute, p_comm_rivsys, p_err)
+ ELSE
+ CALL mpi_comm_split (p_comm_compute, MPI_UNDEFINED, p_iam_compute, p_comm_rivsys, p_err)
+ ENDIF
+#endif
+
+
+ IF (numbasin > 0) THEN
+
+ allocate (ilocdown (numbasin)); ilocdown(:) = 0
+
+ DO ibasin = 1, numbasin
+ IF (riverdown(ibasin) > 0) THEN
+ iloc = find_in_sorted_list1 (riverdown(ibasin), numbasin, basin_sorted)
+ IF (iloc > 0) THEN
+ ilocdown(ibasin) = basin_order(iloc)
+#ifdef USEMPI
+ ELSE
+ iloc = find_in_sorted_list1 (riverdown(ibasin), numbsnlink, linkbindex)
+ ilocdown(ibasin) = - iloc
+#endif
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+
+
+ IF (numbasin > 0) allocate (irivsys (numbasin))
+ IF (numbasin > 0) allocate (route (numbasin))
+
+ IF (riversystem == -1) THEN
+ irivsys(:) = -1
+ numrivsys = 0
+ DO ibasin = 1, numbasin
+ IF (irivsys(ibasin) == -1) THEN
+
+ jbasin = ibasin
+ nnode = 1
+ route(nnode) = jbasin
+ DO WHILE ((riverdown(jbasin) > 0) .and. (irivsys(jbasin) == -1))
+ nnode = nnode + 1
+ route(nnode) = jbasin
+ jbasin = ilocdown(jbasin)
+ ENDDO
+
+ IF (irivsys(jbasin) == -1) THEN
+ numrivsys = numrivsys + 1
+ irivsys(jbasin) = numrivsys
+ ENDIF
+
+ irivsys(route(1:nnode)) = irivsys(jbasin)
+
+ ENDIF
+ ENDDO
+ ELSE
+ numrivsys = 1
+ irivsys(:) = 1
+ ENDIF
+
+ IF (numbasin > 0) deallocate (route)
+
+ ENDIF
+
+#ifdef USEMPI
+ IF (allocated (linkbindex_all)) deallocate (linkbindex_all)
+ IF (allocated (linkrivmth_all)) deallocate (linkrivmth_all)
+#endif
+
+
+ CALL hillslope_network_init (numbasin, basinindex, hillslope_basin)
+
+ IF (p_is_compute) THEN
+
+ IF (numelm > 0) allocate (lake_id_elm (numelm))
+ IF (numhru > 0) allocate (lakedepth_hru (numhru))
+ IF (numbsnhru > 0) allocate (lakedepth_bsnhru(numbsnhru))
+ IF (numelm > 0) allocate (lakedown_id_elm (numelm))
+ IF (numbasin > 0) allocate (lakedown_id_bsn (numbasin))
+ IF (numelm > 0) allocate (lakeoutlet_elm (numelm))
+ IF (numbasin > 0) allocate (lakeoutlet_bsn (numbasin))
+ IF (numhru > 0) allocate (unitarea_hru (numhru))
+ IF (numbsnhru > 0) allocate (unitarea_bsnhru (numbsnhru))
+
+ DO ibasin = 1, numbasin
+
+ lakedown_id_bsn(ibasin) = 0
+
+ IF ((lake_id(ibasin) /= 0) .and. (to_lake(ibasin))) THEN
+ ! lake to lake .or. lake catchment to lake
+ lakedown_id_bsn(ibasin) = riverdown(ibasin)
+ ENDIF
+ IF ((lake_id(ibasin) > 0) .and. (riverdown(ibasin) == 0)) THEN
+ ! lake to ocean
+ lakedown_id_bsn(ibasin) = -9 ! -9 is ocean
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ CALL compute_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999)
+ CALL compute_push_data (push_bsn2elm, lakedown_id_bsn, lakedown_id_elm, -9999)
+
+ IF (p_is_compute) THEN
+
+ unitarea_hru = 0.
+ lakedepth_hru = 0.
+ lakeoutlet_elm = 0.
+
+ DO ielm = 1, numelm
+ hs = elm_hru%substt(ielm)
+ he = elm_hru%subend(ielm)
+ DO ihru = hs, he
+ ps = hru_patch%substt(ihru)
+ pe = hru_patch%subend(ihru)
+
+ unitarea_hru(ihru) = sum(patcharea(ps:pe))
+
+ IF (lake_id_elm(ielm) > 0) THEN
+ lakedepth_hru(ihru) = maxval(lakedepth(ps:pe))
+ ENDIF
+ ENDDO
+
+ IF (lakedown_id_elm(ielm) /= 0) THEN
+ inb = findloc_ud(elementneighbour(ielm)%glbindex == lakedown_id_elm(ielm))
+ IF (inb > 0) lakeoutlet_elm(ielm) = elementneighbour(ielm)%lenbdr(inb)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ CALL compute_push_data (push_elm2bsn, lakeoutlet_elm, lakeoutlet_bsn, spval)
+
+ CALL compute_push_data (push_elmhru2bsnhru, unitarea_hru, unitarea_bsnhru, spval)
+ CALL compute_push_data (push_elmhru2bsnhru, lakedepth_hru, lakedepth_bsnhru, spval)
+
+ IF (allocated (lake_id_elm )) deallocate (lake_id_elm )
+ IF (allocated (lakedepth_hru )) deallocate (lakedepth_hru )
+ IF (allocated (lakedown_id_elm)) deallocate (lakedown_id_elm)
+ IF (allocated (lakedown_id_bsn)) deallocate (lakedown_id_bsn)
+ IF (allocated (lakeoutlet_elm )) deallocate (lakeoutlet_elm )
+ IF (allocated (unitarea_hru )) deallocate (unitarea_hru )
+
+ IF (p_is_compute) THEN
+
+ IF (numbasin > 0) THEN
+
+ allocate (lakeinfo (numbasin))
+ allocate (riverarea (numbasin))
+ allocate (riverwth (numbasin))
+ allocate (bedelv (numbasin))
+ allocate (handmin (numbasin))
+ allocate (wtsrfelv (numbasin))
+ allocate (riverlen_ds (numbasin))
+ allocate (wtsrfelv_ds (numbasin))
+ allocate (riverwth_ds (numbasin))
+ allocate (bedelv_ds (numbasin))
+ allocate (outletwth (numbasin))
+
+ DO ibasin = 1, numbasin
+
+ hs = basin_hru%substt(ibasin)
+ he = basin_hru%subend(ibasin)
+
+ IF (lake_id(ibasin) == 0) THEN
+
+ hillslope_basin(ibasin)%area = unitarea_bsnhru(hs:he)
+
+ riverarea(ibasin) = hillslope_basin(ibasin)%area(1)
+ riverwth (ibasin) = riverarea(ibasin) / riverlen(ibasin)
+
+ ! modify height above nearest drainage data to consider river depth
+ IF (hillslope_basin(ibasin)%nhru > 1) THEN
+ hillslope_basin(ibasin)%hand(2:) = &
+ hillslope_basin(ibasin)%hand(2:) + riverdpth(ibasin)
+ ENDIF
+
+ wtsrfelv(ibasin) = riverelv(ibasin)
+ bedelv (ibasin) = riverelv(ibasin) - riverdpth(ibasin)
+
+ handmin(ibasin) = minval(hillslope_basin(ibasin)%hand)
+
+ ELSEIF (lake_id(ibasin) > 0) THEN
+
+ wtsrfelv(ibasin) = basinelv(ibasin)
+
+ bedelv(ibasin) = basinelv(ibasin) - maxval(lakedepth_bsnhru(hs:he))
+
+ nsublake = he - hs + 1
+ lakeinfo(ibasin)%nsub = nsublake
+
+ allocate (lakeinfo(ibasin)%area0 (nsublake))
+ allocate (lakeinfo(ibasin)%area (nsublake))
+ allocate (lakeinfo(ibasin)%depth0 (nsublake))
+ allocate (lakeinfo(ibasin)%depth (nsublake))
+
+ lakeinfo(ibasin)%area = unitarea_bsnhru (hs:he)
+ lakeinfo(ibasin)%depth = lakedepth_bsnhru(hs:he)
+
+ ! area data in HRU order
+ lakeinfo(ibasin)%area0 = lakeinfo(ibasin)%area
+
+ ! depth data in HRU order
+ lakeinfo(ibasin)%depth0 = lakeinfo(ibasin)%depth
+
+ allocate (order (1:nsublake))
+ order = (/(i, i = 1, nsublake)/)
+
+ CALL quicksort (nsublake, lakeinfo(ibasin)%depth, order)
+
+ ! area data in depth order
+ lakeinfo(ibasin)%area = lakeinfo(ibasin)%area(order)
+
+ ! adjust to be from deepest to shallowest
+ lakeinfo(ibasin)%depth = lakeinfo(ibasin)%depth(nsublake:1:-1)
+ lakeinfo(ibasin)%area = lakeinfo(ibasin)%area (nsublake:1:-1)
+
+ allocate (lakeinfo(ibasin)%dep_vol_curve (nsublake))
+
+ lakeinfo(ibasin)%dep_vol_curve(1) = 0
+ DO i = 2, nsublake
+ lakeinfo(ibasin)%dep_vol_curve(i) = &
+ lakeinfo(ibasin)%dep_vol_curve(i-1) &
+ + sum(lakeinfo(ibasin)%area(1:i-1)) &
+ * (lakeinfo(ibasin)%depth(i-1)-lakeinfo(ibasin)%depth(i))
+ ENDDO
+
+ riverlen(ibasin) = 0.
+
+ deallocate (order)
+
+ ELSEIF (lake_id(ibasin) < 0) THEN
+
+ hillslope_basin(ibasin)%area = unitarea_bsnhru(hs:he)
+ handmin(ibasin) = minval(hillslope_basin(ibasin)%hand)
+
+ ENDIF
+
+ ENDDO
+ ENDIF
+
+ IF (numbasin > 0) THEN
+ allocate(bsnfilter (numbasin))
+ bsnfilter(:) = .true.
+ ENDIF
+
+ CALL pull_from_downstream (riverlen, riverlen_ds, bsnfilter)
+ CALL pull_from_downstream (wtsrfelv, wtsrfelv_ds, bsnfilter)
+ CALL pull_from_downstream (riverwth, riverwth_ds, bsnfilter)
+ CALL pull_from_downstream (bedelv , bedelv_ds , bsnfilter)
+
+ IF (allocated(bsnfilter)) deallocate(bsnfilter)
+
+ DO ibasin = 1, numbasin
+ IF (lake_id(ibasin) < 0) THEN
+ bedelv(ibasin) = wtsrfelv_ds(ibasin) + minval(hillslope_basin(ibasin)%hand)
+ ENDIF
+ ENDDO
+
+ DO ibasin = 1, numbasin
+ IF (lake_id(ibasin) == 0) THEN
+ IF ((to_lake(ibasin)) .or. (riverdown(ibasin) <= 0)) THEN
+ ! river to lake, ocean, inland depression or out of region
+ outletwth(ibasin) = riverwth(ibasin)
+ ELSE
+ ! river to river
+ outletwth(ibasin) = (riverwth(ibasin) + riverwth_ds(ibasin)) * 0.5
+ ENDIF
+ ELSEIF (lake_id(ibasin) /= 0) THEN
+ IF ((.not. to_lake(ibasin)) .and. (riverdown(ibasin) /= 0)) THEN
+ IF (riverdown(ibasin) > 0) THEN
+ ! lake to river
+ outletwth(ibasin) = riverwth_ds(ibasin)
+ ELSEIF (riverdown(ibasin) == -1) THEN
+ ! lake is inland depression
+ outletwth(ibasin) = 0
+ ENDIF
+ ELSEIF (to_lake(ibasin)) THEN
+ ! lake to lake .or. lake catchment to lake
+ outletwth(ibasin) = lakeoutlet_bsn(ibasin)
+ ELSEIF (riverdown(ibasin) == 0) THEN
+ ! lake to ocean
+ outletwth(ibasin) = lakeoutlet_bsn(ibasin)
+ ENDIF
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (allocated (lakedepth_bsnhru)) deallocate (lakedepth_bsnhru)
+ IF (allocated (lakeoutlet_bsn )) deallocate (lakeoutlet_bsn )
+ IF (allocated (unitarea_bsnhru )) deallocate (unitarea_bsnhru )
+
+ IF (allocated(basin_sorted )) deallocate(basin_sorted )
+ IF (allocated(basin_order )) deallocate(basin_order )
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+ IF (p_is_root) write(*,'(A)') 'Building river network information done.'
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ END SUBROUTINE river_lake_network_init
+
+ ! ----- pull data from downstream basin -----
+ SUBROUTINE pull_from_downstream (datain, dataout, bsnfilter)
+
+ USE MOD_SPMD_Task
+
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: datain (:)
+ real(r8), intent(inout) :: dataout (:)
+ logical, intent(in) :: bsnfilter(:)
+
+ ! local variables
+ integer :: i, ibasin
+ real(r8), allocatable :: datalink(:)
+
+ IF (p_is_compute) THEN
+
+#ifdef USEMPI
+ IF (riversystem /= -1) THEN
+ allocate (datalink (numbsnlink)); datalink(:) = 0.
+ DO i = 1, nlink_me
+ datalink(linkpull(i)) = datain(linkpush(i))
+ ENDDO
+ CALL mpi_allreduce (MPI_IN_PLACE, datalink, numbsnlink, MPI_REAL8, MPI_SUM, p_comm_rivsys, p_err)
+ ENDIF
+#endif
+
+ DO ibasin = 1, numbasin
+ IF (bsnfilter(ibasin)) THEN
+ IF (riverdown(ibasin) > 0) THEN
+ IF (ilocdown(ibasin) > 0) THEN
+ dataout(ibasin) = datain(ilocdown(ibasin))
+#ifdef USEMPI
+ ELSEIF (ilocdown(ibasin) < 0) THEN
+ dataout(ibasin) = datalink(-ilocdown(ibasin))
+#endif
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+
+#ifdef USEMPI
+ IF (allocated(datalink)) deallocate (datalink)
+#endif
+ ENDIF
+
+ END SUBROUTINE pull_from_downstream
+
+ ! ----- push data to downstream basin -----
+ SUBROUTINE push_to_downstream (datain, dataout, bsnfilter)
+
+ USE MOD_SPMD_Task
+
+ IMPLICIT NONE
+
+ real(r16), intent(in) :: datain (:)
+ real(r16), intent(inout) :: dataout (:)
+ logical, intent(in) :: bsnfilter(:)
+
+ ! local variables
+ integer :: i, ibasin
+ real(r16), allocatable :: datalink(:)
+
+
+ IF (p_is_compute) THEN
+
+#ifdef USEMPI
+ IF (numbsnlink > 0) THEN
+ allocate (datalink (numbsnlink)); datalink(:) = 0.
+ ENDIF
+#endif
+
+ DO ibasin = 1, numbasin
+ IF (bsnfilter(ibasin)) THEN
+ IF (riverdown(ibasin) > 0) THEN
+ IF (ilocdown(ibasin) > 0) THEN
+ dataout(ilocdown(ibasin)) = dataout(ilocdown(ibasin)) + datain(ibasin)
+#ifdef USEMPI
+ ELSEIF (ilocdown(ibasin) < 0) THEN
+ datalink(-ilocdown(ibasin)) = datalink(-ilocdown(ibasin)) + datain(ibasin)
+#endif
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+
+#ifdef USEMPI
+ IF (riversystem /= -1) THEN
+
+ CALL mpi_allreduce (MPI_IN_PLACE, datalink, numbsnlink, MPI_REAL16, MPI_SUM, p_comm_rivsys, p_err)
+
+ DO i = 1, nlink_me
+ dataout(linkpush(i)) = dataout(linkpush(i)) + datalink(linkpull(i))
+ ENDDO
+
+ deallocate (datalink)
+ ENDIF
+#endif
+ ENDIF
+
+ END SUBROUTINE push_to_downstream
+
+ ! ----- retrieve river depth from runoff -----
+ SUBROUTINE calc_riverdepth_from_runoff (patcharea)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_DataType
+ USE MOD_Utils
+ USE MOD_NetCDFSerial
+ USE MOD_NetCDFBlock
+ USE MOD_Pixel
+ USE MOD_Block
+ USE MOD_Mesh
+ USE MOD_Grid
+ USE MOD_SpatialMapping
+ USE MOD_LandElm
+ USE MOD_LandPatch
+ USE MOD_ElmVector
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: patcharea (:)
+
+ ! Local Variables
+ character(len=256) :: file_rnof, file_rivdpt
+ type(grid_type) :: grid_rnof
+ type(block_data_real8_2d) :: f_rnof
+ type(spatial_mapping_type) :: mg2p_rnof
+
+ real(r8), allocatable :: bsnrnof(:) , bsndis(:)
+ integer, allocatable :: nups_riv(:), iups_riv(:), b_up2down(:)
+
+ integer :: i, j, ithis, ib, jb, iblkme, ps, pe
+ integer :: iwork, mesg(2), isrc, ndata
+ real(r8), allocatable :: rcache(:)
+ real(r8) :: myarea
+
+ real(r8), parameter :: cH_rivdpt = 0.1
+ real(r8), parameter :: pH_rivdpt = 0.5
+ real(r8), parameter :: B0_rivdpt = 0.0
+ real(r8), parameter :: Bmin_rivdpt = 1.0
+
+
+ file_rnof = trim(DEF_dir_runtime) // '/runoff_clim.nc'
+
+ CALL grid_rnof%define_from_file (file_rnof, 'lat', 'lon')
+
+ CALL mg2p_rnof%build_arealweighted (grid_rnof, landelm)
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (grid_rnof, f_rnof)
+ CALL ncio_read_block (file_rnof, 'ro', grid_rnof, f_rnof)
+
+ DO iblkme = 1, gblock%nblkme
+ ib = gblock%xblkme(iblkme)
+ jb = gblock%yblkme(iblkme)
+ DO j = 1, grid_rnof%ycnt(jb)
+ DO i = 1, grid_rnof%xcnt(ib)
+ f_rnof%blk(ib,jb)%val(i,j) = max(f_rnof%blk(ib,jb)%val(i,j), 0.)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numelm > 0) allocate (bsnrnof (numelm))
+ ENDIF
+
+ CALL mg2p_rnof%grid2pset (f_rnof, bsnrnof)
+
+ IF (p_is_compute) THEN
+ IF (numelm > 0) THEN
+ bsnrnof = bsnrnof /24.0/3600.0 ! from m/day to m/s
+ DO i = 1, numelm
+ ps = elm_patch%substt(i)
+ pe = elm_patch%subend(i)
+ myarea = sum(patcharea(ps:pe))
+ ! total runoff in basin, from m/s to m3/s
+ bsnrnof(i) = bsnrnof(i) * myarea
+ ENDDO
+ ENDIF
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+ IF (p_is_compute) THEN
+ mesg = (/p_iam_glb, numelm/)
+ CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ IF (numelm > 0) THEN
+ CALL mpi_send (bsnrnof, numelm, MPI_REAL8, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+
+ allocate (bsnrnof (totalnumelm))
+
+ DO iwork = 0, p_np_compute-1
+ CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = mesg(1)
+ ndata = mesg(2)
+ IF (ndata > 0) THEN
+ allocate(rcache (ndata))
+
+ CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ bsnrnof(elm_data_address(p_itis_compute(isrc))%val) = rcache
+
+ deallocate (rcache)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ bsnrnof(elm_data_address(0)%val) = bsnrnof
+#endif
+
+
+ IF (p_is_root) THEN
+
+ allocate (nups_riv (totalnumelm))
+ allocate (iups_riv (totalnumelm))
+ allocate (b_up2down(totalnumelm))
+
+ allocate (bsndis (totalnumelm))
+
+ nups_riv(:) = 0
+ DO i = 1, totalnumelm
+ j = riverdown(i)
+ IF (j > 0) THEN
+ nups_riv(j) = nups_riv(j) + 1
+ ENDIF
+ ENDDO
+
+ iups_riv(:) = 0
+ ithis = 0
+ DO i = 1, totalnumelm
+ IF (iups_riv(i) == nups_riv(i)) THEN
+
+ ithis = ithis + 1
+ b_up2down(ithis) = i
+
+ j = riverdown(i)
+ DO WHILE (j > 0)
+
+ iups_riv(j) = iups_riv(j) + 1
+
+ IF (iups_riv(j) == nups_riv(j)) THEN
+ ithis = ithis + 1
+ b_up2down(ithis) = j
+ j = riverdown(j)
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ bsndis(:) = 0.
+ DO i = 1, totalnumelm
+ j = b_up2down(i)
+ bsndis(j) = bsndis(j) + bsnrnof(j)
+ IF (riverdown(j) > 0) THEN
+ bsndis(riverdown(j)) = bsndis(riverdown(j)) + bsndis(j)
+ ENDIF
+ ENDDO
+
+ allocate (riverdpth (totalnumelm))
+ DO i = 1, totalnumelm
+ riverdpth(i) = max(cH_rivdpt * (bsndis(i)**pH_rivdpt) + B0_rivdpt, Bmin_rivdpt)
+ ENDDO
+
+ ENDIF
+
+ IF (allocated (bsnrnof )) deallocate(bsnrnof )
+ IF (allocated (bsndis )) deallocate(bsndis )
+ IF (allocated (nups_riv )) deallocate(nups_riv )
+ IF (allocated (iups_riv )) deallocate(iups_riv )
+ IF (allocated (b_up2down)) deallocate(b_up2down)
+
+ END SUBROUTINE calc_riverdepth_from_runoff
+
+ !
+ FUNCTION retrieve_lake_surface_from_volume (this, volume) result(surface)
+
+ IMPLICIT NONE
+
+ class(lake_info_type) :: this
+ real(r8), intent(in) :: volume
+ real(r8) :: surface
+
+ ! Local Variables
+ integer :: i
+
+ IF (volume <= 0) THEN
+ surface = 0
+ RETURN
+ ENDIF
+
+ IF (this%nsub == 1) THEN
+ surface = volume / this%area(1)
+ ELSE
+ i = 1
+ DO WHILE (i < this%nsub)
+ IF (volume >= this%dep_vol_curve(i+1)) THEN
+ i = i + 1
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ surface = this%depth(1) - this%depth(i) + &
+ (volume - this%dep_vol_curve(i)) / sum(this%area(1:i))
+ ENDIF
+
+ END FUNCTION retrieve_lake_surface_from_volume
+
+ !
+ FUNCTION retrieve_lake_volume_from_surface (this, surface) result(volume)
+
+ IMPLICIT NONE
+
+ class(lake_info_type) :: this
+ real(r8), intent(in) :: surface
+ real(r8) :: volume
+
+ ! Local Variables
+ integer :: i
+
+ IF (surface <= 0) THEN
+ volume = 0
+ RETURN
+ ENDIF
+
+ IF (this%nsub == 1) THEN
+ volume = this%area(1) * surface
+ ELSE
+ i = 1
+ DO WHILE (i < this%nsub)
+ IF (surface >= this%depth(1)-this%depth(i+1)) THEN
+ i = i + 1
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ volume = this%dep_vol_curve(i) &
+ + (surface - (this%depth(1) - this%depth(i))) * sum(this%area(1:i))
+ ENDIF
+
+ END FUNCTION retrieve_lake_volume_from_surface
+
+ ! ----------
+ SUBROUTINE river_lake_network_final ()
+
+ IMPLICIT NONE
+
+ ! Local Variables
+ integer :: ilake
+
+ IF (allocated (riverlen )) deallocate(riverlen )
+ IF (allocated (riverelv )) deallocate(riverelv )
+ IF (allocated (riverwth )) deallocate(riverwth )
+ IF (allocated (riverarea )) deallocate(riverarea )
+ IF (allocated (riverdpth )) deallocate(riverdpth )
+ IF (allocated (basinelv )) deallocate(basinelv )
+ IF (allocated (bedelv )) deallocate(bedelv )
+ IF (allocated (handmin )) deallocate(handmin )
+ IF (allocated (wtsrfelv )) deallocate(wtsrfelv )
+ IF (allocated (riverdown )) deallocate(riverdown )
+ IF (allocated (ilocdown )) deallocate(ilocdown )
+ IF (allocated (to_lake )) deallocate(to_lake )
+ IF (allocated (riverlen_ds )) deallocate(riverlen_ds )
+ IF (allocated (wtsrfelv_ds )) deallocate(wtsrfelv_ds )
+ IF (allocated (riverwth_ds )) deallocate(riverwth_ds )
+ IF (allocated (bedelv_ds )) deallocate(bedelv_ds )
+ IF (allocated (outletwth )) deallocate(outletwth )
+ IF (allocated (irivsys )) deallocate(irivsys )
+#ifdef USEMPI
+ IF (allocated (linkbindex )) deallocate(linkbindex )
+ IF (allocated (linkpush )) deallocate(linkpush )
+ IF (allocated (linkpull )) deallocate(linkpull )
+#endif
+ IF (allocated (lakeinfo )) deallocate(lakeinfo )
+ IF (associated(hillslope_basin)) deallocate(hillslope_basin)
+
+ END SUBROUTINE river_lake_network_final
+
+ ! ---------
+ SUBROUTINE lake_info_free_mem (this)
+
+ IMPLICIT NONE
+ type(lake_info_type) :: this
+
+ IF (allocated(this%area0 )) deallocate (this%area0 )
+ IF (allocated(this%area )) deallocate (this%area )
+ IF (allocated(this%depth0)) deallocate (this%depth0)
+ IF (allocated(this%depth )) deallocate (this%depth )
+ IF (allocated(this%dep_vol_curve)) deallocate (this%dep_vol_curve)
+
+ END SUBROUTINE lake_info_free_mem
+
+END MODULE MOD_Catch_RiverLakeNetwork
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90
new file mode 100644
index 0000000000..7bbcf51834
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_SubsurfaceFlow.F90
@@ -0,0 +1,823 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_SubsurfaceFlow
+!-------------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Ground water lateral flow.
+!
+! Ground water fluxes are calculated
+! 1. between elements
+! 2. between hydrological response units
+! 3. between patches inside one HRU
+!
+! Created by Shupeng Zhang, May 2023
+!-------------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_DataType
+ USE MOD_Catch_HillslopeNetwork
+ IMPLICIT NONE
+
+ ! --- information of HRU on hillslope ---
+ type(hillslope_network_type), pointer :: hillslope_element (:)
+
+ integer, allocatable :: lake_id_elm (:)
+ real(r8), allocatable :: lakedepth_elm(:)
+ real(r8), allocatable :: riverdpth_elm(:)
+ real(r8), allocatable :: wdsrf_elm (:)
+
+ real(r8), parameter :: e_ice = 6.0 ! soil ice impedance factor
+
+ ! anisotropy ratio of lateral/vertical hydraulic conductivity (unitless)
+ ! for USDA soil texture class:
+ ! 0: undefined
+ ! 1: clay; 2: silty clay; 3: sandy clay; 4: clay loam; 5: silty clay loam; 6: sandy clay loam; &
+ ! 7: loam; 8: silty loam; 9: sandy loam; 10: silt; 11: loamy sand; 12: sand
+ real(r8), parameter :: raniso(0:12) = (/ 1., &
+ 48., 40., 28., 24., 20., 14., 12., 10., 4., 2., 3., 2. /)
+
+ ! -- neighbour variables --
+ type(pointer_real8_1d), allocatable :: agwt_nb (:) ! ground water area (for patchtype <= 2) of neighbours [m^2]
+ type(pointer_real8_1d), allocatable :: theta_a_nb (:) ! saturated volume content [-]
+ type(pointer_real8_1d), allocatable :: zwt_nb (:) ! water table depth [m]
+ type(pointer_real8_1d), allocatable :: Kl_nb (:) ! lateral hydraulic conductivity [m/s]
+ type(pointer_real8_1d), allocatable :: wdsrf_nb (:) ! depth of surface water [m]
+ type(pointer_logic_1d), allocatable :: islake_nb (:) ! whether a neighbour is water body
+ type(pointer_real8_1d), allocatable :: lakedp_nb (:) ! lake depth of neighbour [m]
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE subsurface_network_init (patcharea)
+
+ USE MOD_SPMD_Task
+ USE MOD_Utils
+ USE MOD_Mesh
+ USE MOD_Pixel
+ USE MOD_LandElm
+ USE MOD_LandPatch
+ USE MOD_ElementNeighbour
+ USE MOD_ComputePushData, only: compute_push_data
+ USE MOD_Catch_BasinNetwork, only: push_bsn2elm
+ USE MOD_Catch_RiverLakeNetwork, only: lake_id, riverdpth
+ USE MOD_Vars_TimeInvariants, only: patchtype, lakedepth
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: patcharea (:)
+
+ integer :: ielm, inb, i, ihru, ps, pe, ipatch
+
+ real(r8), allocatable :: agwt_b(:)
+ real(r8), allocatable :: islake(:)
+ type(pointer_real8_1d), allocatable :: iswat_nb (:)
+
+ integer, allocatable :: eindex(:)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_compute) THEN
+ IF (numelm > 0) THEN
+ allocate (eindex (numelm))
+ eindex = landelm%eindex
+ ENDIF
+ ENDIF
+
+ CALL hillslope_network_init (numelm, eindex, hillslope_element)
+
+ IF (allocated(eindex)) deallocate (eindex)
+
+ IF (p_is_compute) THEN
+
+ IF (numelm > 0) allocate (lake_id_elm (numelm))
+ IF (numelm > 0) allocate (riverdpth_elm(numelm))
+ IF (numelm > 0) allocate (lakedepth_elm(numelm))
+ IF (numelm > 0) allocate (wdsrf_elm (numelm))
+
+ CALL compute_push_data (push_bsn2elm, lake_id, lake_id_elm, -9999)
+ CALL compute_push_data (push_bsn2elm, riverdpth, riverdpth_elm, spval)
+
+ DO ielm = 1, numelm
+ IF (lake_id_elm(ielm) <= 0) THEN
+ DO i = 1, hillslope_element(ielm)%nhru
+
+ hillslope_element(ielm)%agwt(i) = 0
+ hillslope_element(ielm)%area(i) = 0
+
+ ihru = hillslope_element(ielm)%ihru(i)
+ ps = hru_patch%substt(ihru)
+ pe = hru_patch%subend(ihru)
+ DO ipatch = ps, pe
+ hillslope_element(ielm)%area(i) = hillslope_element(ielm)%area(i) + patcharea(ipatch)
+ IF (patchtype(ipatch) <= 2) THEN
+ hillslope_element(ielm)%agwt(i) = hillslope_element(ielm)%agwt(i) + patcharea(ipatch)
+ ENDIF
+ ENDDO
+
+ ENDDO
+ ENDIF
+ ENDDO
+
+ lakedepth_elm(:) = 0.
+ DO ielm = 1, numelm
+ IF (lake_id_elm(ielm) > 0) THEN
+ ps = elm_patch%substt(ielm)
+ pe = elm_patch%subend(ielm)
+ lakedepth_elm(ielm) = sum(lakedepth(ps:pe) * elm_patch%subfrc(ps:pe))
+ ENDIF
+ ENDDO
+
+ CALL allocate_neighbour_data (agwt_nb )
+ CALL allocate_neighbour_data (theta_a_nb)
+ CALL allocate_neighbour_data (zwt_nb )
+ CALL allocate_neighbour_data (Kl_nb )
+ CALL allocate_neighbour_data (wdsrf_nb )
+ CALL allocate_neighbour_data (islake_nb )
+ CALL allocate_neighbour_data (lakedp_nb )
+ CALL allocate_neighbour_data (iswat_nb )
+
+ IF (numelm > 0) THEN
+ allocate (agwt_b(numelm))
+ allocate (islake(numelm))
+ DO ielm = 1, numelm
+ IF (lake_id_elm(ielm) <= 0) THEN
+ agwt_b(ielm) = sum(hillslope_element(ielm)%agwt)
+ islake(ielm) = 0.
+ ELSE
+ agwt_b(ielm) = 0.
+ islake(ielm) = 1.
+ ENDIF
+ ENDDO
+ ENDIF
+
+ CALL retrieve_neighbour_data (lakedepth_elm, lakedp_nb)
+
+ CALL retrieve_neighbour_data (agwt_b, agwt_nb )
+ CALL retrieve_neighbour_data (islake, iswat_nb)
+
+ DO ielm = 1, numelm
+ DO inb = 1, elementneighbour(ielm)%nnb
+ IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour
+ islake_nb(ielm)%val(inb) = (iswat_nb(ielm)%val(inb) > 0)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ IF (allocated(agwt_b )) deallocate(agwt_b )
+ IF (allocated(islake )) deallocate(islake )
+ IF (allocated(iswat_nb)) deallocate(iswat_nb)
+
+ ENDIF
+
+ END SUBROUTINE subsurface_network_init
+
+ ! ---------
+ SUBROUTINE subsurface_flow (deltime)
+
+ USE MOD_SPMD_Task
+ USE MOD_UserDefFun
+ USE MOD_Mesh
+ USE MOD_LandElm
+ USE MOD_LandHRU
+ USE MOD_LandPatch
+ USE MOD_Vars_TimeVariables
+ USE MOD_Vars_TimeInvariants
+ USE MOD_Vars_1DFluxes
+ USE MOD_Catch_HillslopeNetwork
+ USE MOD_ElementNeighbour
+ USE MOD_Const_Physical, only: denice, denh2o
+ USE MOD_Vars_Global, only: pi, nl_soil, zi_soi
+ USE MOD_Hydro_SoilWater, only: soilwater_aquifer_exchange
+
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: deltime
+
+ ! Local Variables
+ integer :: nhru, ielm, i, i0, j, ihru, ipatch, ps, pe, hs, he, ilev
+
+ type(hillslope_network_type), pointer :: hrus
+
+ real(r8), allocatable :: theta_a_h (:)
+ real(r8), allocatable :: zwt_h (:)
+ real(r8), allocatable :: Kl_h (:) ! [m/s]
+ real(r8), allocatable :: xsubs_h (:) ! [m/s]
+ real(r8), allocatable :: xsubs_fc (:) ! [m/s]
+
+ logical :: j_is_river
+ real(r8) :: theta_s_h, air_h, icefrac, imped, delp
+ real(r8) :: sumwt, sumarea, zwt_mean
+ real(r8) :: zsubs_h_up, zsubs_h_dn
+ real(r8) :: slope, bdamp, Kl_fc, Kl_in
+ real(r8) :: ca, cb
+ real(r8) :: alp
+
+ real(r8), allocatable :: theta_a_elm (:)
+ real(r8), allocatable :: zwt_elm (:)
+ real(r8), allocatable :: Kl_elm (:) ! [m/s]
+
+ integer :: jnb
+ real(r8) :: zsubs_up, zwt_up, Kl_up, theta_a_up, area_up
+ real(r8) :: zsubs_dn, zwt_dn, Kl_dn, theta_a_dn, area_dn
+ real(r8) :: lenbdr, xsubs_nb
+ logical :: iam_lake, nb_is_lake, has_river
+
+ ! for water exchange
+ logical :: is_dry_lake
+ integer :: izwt
+ real(r8) :: exwater
+ real(r8) :: sp_zi(0:nl_soil), sp_dz(1:nl_soil), zwtmm ! [mm]
+ real(r8) :: vl_r (1:nl_soil)
+#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)
+ real(r8) :: vol_ice (1:nl_soil)
+ real(r8) :: vol_liq (1:nl_soil)
+ real(r8) :: eff_porosity(1:nl_soil)
+ logical :: is_permeable(1:nl_soil)
+ real(r8) :: wresi (1:nl_soil)
+ real(r8) :: w_sum_before, w_sum_after, errblc
+
+
+ IF (p_is_compute) THEN
+
+ xsubs_elm(:) = 0. ! subsurface lateral flow between element basins
+ xsubs_hru(:) = 0. ! subsurface lateral flow between hydrological response units
+ xsubs_pch(:) = 0. ! subsurface lateral flow between patches inside one HRU
+
+ xwsub(:) = 0. ! total recharge/discharge from subsurface lateral flow
+
+ IF (numpatch > 0) rsub(:) = 0.
+
+ IF (numelm > 0) THEN
+ allocate (theta_a_elm (numelm)); theta_a_elm = 0.
+ allocate (zwt_elm (numelm)); zwt_elm = 0.
+ allocate (Kl_elm (numelm)); Kl_elm = 0.
+ ENDIF
+
+ DO ielm = 1, numelm
+
+ hrus => hillslope_element(ielm)
+
+ nhru = hrus%nhru
+
+ IF (lake_id_elm(ielm) > 0) CYCLE ! lake
+ IF (sum(hrus%agwt) <= 0) CYCLE ! no area of soil, urban or wetland
+
+ allocate (theta_a_h (nhru)); theta_a_h = 0.
+ allocate (zwt_h (nhru)); zwt_h = 0.
+ allocate (Kl_h (nhru)); Kl_h = 0.
+
+ DO i = 1, nhru
+
+ IF (hrus%indx(i) == 0) CYCLE ! river
+ IF (hrus%agwt(i) == 0) CYCLE ! no area of soil, urban or wetland
+
+ ps = hru_patch%substt(hrus%ihru(i))
+ pe = hru_patch%subend(hrus%ihru(i))
+
+ theta_s_h = 0
+ sumwt = 0
+ DO ipatch = ps, pe
+ IF (patchtype(ipatch) <= 2) THEN
+ theta_s_h = theta_s_h + hru_patch%subfrc(ipatch) &
+ * sum(porsl(1:nl_soil,ipatch) * dz_soi(1:nl_soil) &
+ - wice_soisno(1:nl_soil,ipatch)/denice) / sum(dz_soi(1:nl_soil))
+ sumwt = sumwt + hru_patch%subfrc(ipatch)
+ ENDIF
+ ENDDO
+ IF (sumwt > 0) theta_s_h = theta_s_h / sumwt
+
+ IF (theta_s_h > 0.) THEN
+
+ air_h = 0.
+ zwt_h(i) = 0.
+ sumwt = 0.
+ DO ipatch = ps, pe
+ IF (patchtype(ipatch) <= 2) THEN
+ air_h = air_h + hru_patch%subfrc(ipatch) &
+ * (sum( porsl(1:nl_soil,ipatch) * dz_soi(1:nl_soil) &
+ - wliq_soisno(1:nl_soil,ipatch)/denh2o &
+ - wice_soisno(1:nl_soil,ipatch)/denice ) - wa(ipatch)/1.0e3)
+ air_h = max(0., air_h)
+
+ zwt_h(i) = zwt_h(i) + zwt(ipatch) * hru_patch%subfrc(ipatch)
+
+ sumwt = sumwt + hru_patch%subfrc(ipatch)
+ ENDIF
+ ENDDO
+ IF (sumwt > 0) air_h = air_h / sumwt
+ IF (sumwt > 0) zwt_h(i) = zwt_h(i) / sumwt
+
+ IF ((air_h <= 0.) .or. (zwt_h(i) <= 0.)) THEN
+ theta_a_h(i) = theta_s_h
+ zwt_h(i) = 0.
+ ELSE
+ theta_a_h(i) = air_h / zwt_h(i)
+ IF (theta_a_h(i) > theta_s_h) THEN
+ theta_a_h(i) = theta_s_h
+ zwt_h(i) = air_h / theta_a_h(i)
+ ENDIF
+ ENDIF
+
+ Kl_h(i) = 0.
+ sumwt = 0.
+ DO ipatch = ps, pe
+ IF (patchtype(ipatch) <= 2) THEN
+ DO ilev = 1, nl_soil
+ icefrac = min(1., wice_soisno(ilev,ipatch)/denice/dz_soi(ilev)/porsl(ilev,ipatch))
+ imped = 10.**(-e_ice*icefrac)
+ Kl_h(i) = Kl_h(i) + hru_patch%subfrc(ipatch) * raniso(soiltext(ipatch)) &
+ * hksati(ilev,ipatch)/1.0e3 * imped * dz_soi(ilev)/zi_soi(nl_soil)
+ ENDDO
+ sumwt = sumwt + hru_patch%subfrc(ipatch)
+ ENDIF
+ ENDDO
+ IF (sumwt > 0) Kl_h(i) = Kl_h(i) / sumwt
+ ELSE
+ ! Frozen soil.
+ Kl_h(i) = 0.
+ ENDIF
+
+ ENDDO
+
+ allocate (xsubs_h (nhru))
+ allocate (xsubs_fc (nhru))
+
+ xsubs_h (:) = 0.
+ xsubs_fc(:) = 0.
+
+ DO i = 1, nhru
+
+ j = hrus%inext(i)
+
+ IF (j <= 0) CYCLE ! downstream is out of catchment
+ IF (Kl_h(i) == 0.) CYCLE ! this HRU is frozen
+
+ j_is_river = (hrus%indx(j) == 0)
+
+ IF ((.not. j_is_river) .and. (Kl_h(j) == 0.)) CYCLE ! non-river downstream HRU is frozen
+
+ zsubs_h_up = hrus%elva(i) - zwt_h(i)
+
+ IF (.not. j_is_river) THEN
+ zsubs_h_dn = hrus%elva(j) - zwt_h(j)
+ ELSE
+ zsubs_h_dn = hrus%elva(1) - riverdpth_elm(ielm) + wdsrf_hru(hrus%ihru(1))
+ ENDIF
+
+ IF (.not. j_is_river) THEN
+ delp = hrus%plen(i) + hrus%plen(j)
+ ELSE
+ delp = hrus%plen(i)
+ ENDIF
+
+ slope = abs(hrus%elva(i)-hrus%elva(j))/delp
+ ! from Fan et al., JGR 112(D10125)
+ IF (slope > 0.16) THEN
+ bdamp = 4.8
+ ELSE
+ bdamp = 120./(1+150.*slope)
+ ENDIF
+
+ ! Upstream scheme for hydraulic conductivity
+ IF ((zsubs_h_up > zsubs_h_dn) .or. j_is_river) THEN
+ IF (zwt_h(i) > 1.5) THEN
+ ! from Fan et al., JGR 112(D10125)
+ Kl_fc = Kl_h(i) * bdamp * exp(-(zwt_h(i)-1.5)/bdamp)
+ ELSE
+ Kl_fc = Kl_h(i) * ((1.5-zwt_h(i)) + bdamp)
+ ENDIF
+ ELSE
+ IF (zwt_h(j) > 1.5) THEN
+ Kl_fc = Kl_h(j) * bdamp * exp(-(zwt_h(j)-1.5)/bdamp)
+ ELSE
+ Kl_fc = Kl_h(j) * ((1.5-zwt_h(j)) + bdamp)
+ ENDIF
+ ENDIF
+
+ ca = hrus%flen(i) * Kl_fc / theta_a_h(i) / delp / hrus%agwt(i) * deltime
+
+ IF (.not. j_is_river) THEN
+ cb = hrus%flen(i) * Kl_fc / theta_a_h(j) / delp / hrus%agwt(j) * deltime
+ ELSE
+ cb = hrus%flen(i) * Kl_fc / delp / hrus%area(j) * deltime
+ ENDIF
+
+ xsubs_fc(i) = (zsubs_h_up - zsubs_h_dn) * hrus%flen(i) * Kl_fc / (1+ca+cb) / delp
+
+ xsubs_h(i) = xsubs_h(i) + xsubs_fc(i) / hrus%agwt(i)
+
+ IF (j_is_river) THEN
+ xsubs_h(j) = xsubs_h(j) - xsubs_fc(i) / hrus%area(j)
+ ELSE
+ xsubs_h(j) = xsubs_h(j) - xsubs_fc(i) / hrus%agwt(j)
+ ENDIF
+
+ ENDDO
+
+ IF (hrus%indx(1) == 0) THEN
+ ! xsubs_h(1) is positive = out of soil column
+ IF (xsubs_h(1)*deltime > wdsrf_hru(hrus%ihru(1))) THEN
+ alp = wdsrf_hru(hrus%ihru(1)) / (xsubs_h(1)*deltime)
+ xsubs_h(1) = xsubs_h(1) * alp
+ DO i = 2, nhru
+ IF ((hrus%inext(i) == 1) .and. (hrus%agwt(i) > 0.)) THEN
+ xsubs_h(i) = xsubs_h(i) - (1.0-alp)*xsubs_fc(i)/hrus%agwt(i)
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ ! Update total subsurface lateral flow (1): Between hydrological units
+ ! for soil, urban, wetland or river patches
+ DO i = 1, nhru
+ xsubs_hru(hrus%ihru(i)) = xsubs_h(i)
+
+ ps = hru_patch%substt(hrus%ihru(i))
+ pe = hru_patch%subend(hrus%ihru(i))
+ DO ipatch = ps, pe
+ IF ((patchtype(ipatch) <= 2) .or. (hrus%indx(i) == 0)) THEN
+ xwsub(ipatch) = xwsub(ipatch) + xsubs_h(i) * 1.e3 ! (positive = out of soil column)
+ ENDIF
+ ENDDO
+
+ IF (hrus%indx(1) == 0) THEN
+ DO ipatch = ps, pe
+ IF (patchtype(ipatch) <= 2) THEN
+ rsub(ipatch) = - xsubs_h(1) * hrus%area(1) / sum(hrus%agwt) * 1.0e3 ! m/s to mm/s
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ DO i = 1, nhru
+ ! Inside hydrological units
+ IF (hrus%agwt(i) > 0) THEN
+
+ bdamp = 4.8
+
+ IF (zwt_h(i) > 1.5) THEN
+ ! from Fan et al., JGR 112(D10125)
+ Kl_in = Kl_h(i) * bdamp * exp(-(zwt_h(i)-1.5)/bdamp)
+ ELSE
+ Kl_in = Kl_h(i) * ((1.5-zwt_h(i)) + bdamp)
+ ENDIF
+
+ ps = hru_patch%substt(hrus%ihru(i))
+ pe = hru_patch%subend(hrus%ihru(i))
+ sumwt = sum(hru_patch%subfrc(ps:pe), mask = patchtype(ps:pe) <= 2)
+ IF (sumwt > 0) THEN
+ zwt_mean = sum(zwt(ps:pe)*hru_patch%subfrc(ps:pe), mask = patchtype(ps:pe) <= 2) / sumwt
+
+ DO ipatch = ps, pe
+ IF (patchtype(ipatch) <= 2) THEN
+ xsubs_pch(ipatch) = - Kl_in * (zwt(ipatch) - zwt_mean) *6.0*pi/hrus%agwt(i)
+ ! Update total subsurface lateral flow (2): Between patches
+ xwsub(ipatch) = xwsub(ipatch) + xsubs_pch(ipatch) * 1.e3 ! m/s to mm/s
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDDO
+
+ sumarea = sum(hrus%agwt)
+ IF (sumarea > 0) THEN
+ theta_a_elm (ielm) = sum(theta_a_h * hrus%agwt) / sumarea
+ zwt_elm (ielm) = sum(zwt_h * hrus%agwt) / sumarea
+ Kl_elm (ielm) = sum(Kl_h * hrus%agwt) / sumarea
+ ENDIF
+
+ deallocate (theta_a_h)
+ deallocate (zwt_h )
+ deallocate (Kl_h )
+ deallocate (xsubs_h )
+ deallocate (xsubs_fc )
+
+ ENDDO
+
+ DO ielm = 1, numelm
+ hs = elm_hru%substt(ielm)
+ he = elm_hru%subend(ielm)
+ wdsrf_elm(ielm) = sum(wdsrf_hru(hs:he) * elm_hru%subfrc(hs:he))
+ ENDDO
+
+ CALL retrieve_neighbour_data (theta_a_elm, theta_a_nb)
+ CALL retrieve_neighbour_data (zwt_elm , zwt_nb )
+ CALL retrieve_neighbour_data (Kl_elm , Kl_nb )
+ CALL retrieve_neighbour_data (wdsrf_elm , wdsrf_nb )
+
+ DO ielm = 1, numelm
+
+ hrus => hillslope_element(ielm)
+
+ iam_lake = (lake_id_elm(ielm) > 0)
+
+ DO jnb = 1, elementneighbour(ielm)%nnb
+
+ IF (elementneighbour(ielm)%glbindex(jnb) == -9) CYCLE ! skip ocean neighbour
+
+ nb_is_lake = islake_nb(ielm)%val(jnb)
+
+ IF (iam_lake .and. nb_is_lake) THEN
+ CYCLE
+ ENDIF
+
+ IF (.not. iam_lake) THEN
+ Kl_up = Kl_elm (ielm)
+ zwt_up = zwt_elm (ielm)
+ theta_a_up = theta_a_elm(ielm)
+ zsubs_up = elementneighbour(ielm)%myelva - zwt_up
+ area_up = sum(hrus%agwt)
+ ELSE
+ theta_a_up = 1.
+ zsubs_up = elementneighbour(ielm)%myelva - lakedepth_elm(ielm) + wdsrf_elm(ielm)
+ area_up = elementneighbour(ielm)%myarea
+ ENDIF
+
+ IF (.not. nb_is_lake) THEN
+ Kl_dn = Kl_nb(ielm)%val(jnb)
+ zwt_dn = zwt_nb(ielm)%val(jnb)
+ theta_a_dn = theta_a_nb(ielm)%val(jnb)
+ zsubs_dn = elementneighbour(ielm)%elva(jnb) - zwt_dn
+ area_dn = agwt_nb(ielm)%val(jnb)
+ ELSE
+ theta_a_dn = 1.
+ zsubs_dn = elementneighbour(ielm)%elva(jnb) - lakedp_nb(ielm)%val(jnb) + wdsrf_nb(ielm)%val(jnb)
+ area_dn = elementneighbour(ielm)%area(jnb)
+ ENDIF
+
+ IF ((.not. iam_lake) .and. (area_up <= 0)) CYCLE
+ IF ((.not. nb_is_lake) .and. (area_dn <= 0)) CYCLE
+ IF ((.not. iam_lake) .and. (Kl_up == 0. )) CYCLE
+ IF ((.not. nb_is_lake) .and. (Kl_dn == 0. )) CYCLE
+
+ ! water body is dry.
+ IF (iam_lake .and. (zsubs_up > zsubs_dn) .and. (wdsrf_elm(ielm) == 0.)) THEN
+ CYCLE
+ ENDIF
+ IF (nb_is_lake .and. (zsubs_up < zsubs_dn) .and. (wdsrf_nb(ielm)%val(jnb) == 0.)) THEN
+ CYCLE
+ ENDIF
+
+ lenbdr = elementneighbour(ielm)%lenbdr(jnb)
+
+ delp = elementneighbour(ielm)%dist(jnb)
+ IF (iam_lake) THEN
+ delp = elementneighbour(ielm)%area(jnb) / lenbdr * 0.5
+ ENDIF
+ IF (nb_is_lake) THEN
+ delp = elementneighbour(ielm)%myarea / lenbdr * 0.5
+ ENDIF
+
+ ! from Fan et al., JGR 112(D10125)
+ slope = abs(elementneighbour(ielm)%slope(jnb))
+ IF (slope > 0.16) THEN
+ bdamp = 4.8
+ ELSE
+ bdamp = 120./(1+150.*slope)
+ ENDIF
+
+ ! Upstream scheme for hydraulic conductivity
+ IF (nb_is_lake .or. ((.not. iam_lake) .and. (zsubs_up > zsubs_dn))) THEN
+ IF (zwt_up > 1.5) THEN
+ ! from Fan et al., JGR 112(D10125)
+ Kl_fc = Kl_up * bdamp * exp(-(zwt_up-1.5)/bdamp)
+ ELSE
+ Kl_fc = Kl_up * ((1.5-zwt_up) + bdamp)
+ ENDIF
+ ELSE
+ IF (zwt_dn > 1.5) THEN
+ Kl_fc = Kl_dn * bdamp * exp(-(zwt_dn-1.5)/bdamp)
+ ELSE
+ Kl_fc = Kl_dn * ((1.5-zwt_dn) + bdamp)
+ ENDIF
+ ENDIF
+
+ ca = lenbdr * Kl_fc / theta_a_up / delp / area_up * deltime
+ cb = lenbdr * Kl_fc / theta_a_dn / delp / area_dn * deltime
+
+ xsubs_nb = (zsubs_up - zsubs_dn) * lenbdr * Kl_fc / (1+ca+cb) / delp
+
+ IF (.not. iam_lake) THEN
+ xsubs_nb = xsubs_nb / sum(hrus%agwt)
+ ELSE
+ xsubs_nb = xsubs_nb / elementneighbour(ielm)%myarea
+ ENDIF
+
+ xsubs_elm(ielm) = xsubs_elm(ielm) + xsubs_nb
+
+ IF (nb_is_lake) THEN
+ ps = elm_patch%substt(ielm)
+ pe = elm_patch%subend(ielm)
+ DO ipatch = ps, pe
+ IF (patchtype(ipatch) <= 2) THEN
+ rsub(ipatch) = rsub(ipatch) + xsubs_nb * 1.e3
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ENDDO
+
+ ! Update total subsurface lateral flow (3): Between basins
+ ps = elm_patch%substt(ielm)
+ pe = elm_patch%subend(ielm)
+ DO ipatch = ps, pe
+ IF (iam_lake .or. (patchtype(ipatch) <= 2)) THEN
+ xwsub(ipatch) = xwsub(ipatch) + xsubs_elm(ielm) * 1.e3 ! m/s to mm/s
+ ENDIF
+ ENDDO
+
+ ENDDO
+
+ IF (allocated(theta_a_elm)) deallocate(theta_a_elm)
+ IF (allocated(zwt_elm )) deallocate(zwt_elm )
+ IF (allocated(Kl_elm )) deallocate(Kl_elm )
+
+ ENDIF
+
+ ! Exchange between soil water and aquifer.
+ IF (p_is_compute) THEN
+
+ sp_zi(0) = 0.
+ sp_zi(1:nl_soil) = zi_soi(1:nl_soil) * 1000.0 ! from meter to mm
+ sp_dz(1:nl_soil) = sp_zi(1:nl_soil) - sp_zi(0:nl_soil-1)
+
+ DO ipatch = 1, numpatch
+
+#if (defined CoLMDEBUG)
+ ! For water balance check, the sum of water in soil column before the calcultion
+ w_sum_before = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) &
+ + wa(ipatch) + wdsrf(ipatch) + wetwat(ipatch)
+#endif
+
+ IF (DEF_USE_Dynamic_Lake) THEN
+ is_dry_lake = (patchtype(ipatch) == 4) .and. (zwt(ipatch) > 0.)
+ ELSE
+ is_dry_lake = .false.
+ ENDIF
+
+ IF ((patchtype(ipatch) <= 1) .or. is_dry_lake) THEN
+
+ exwater = xwsub(ipatch) * deltime
+
+#ifdef Campbell_SOIL_MODEL
+ vl_r(1:nl_soil) = 0._r8
+ prms(1,:) = bsw(1:nl_soil,ipatch)
+#endif
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ vl_r (1:nl_soil) = theta_r (1:nl_soil,ipatch)
+ prms(1,1:nl_soil) = alpha_vgm(1:nl_soil,ipatch)
+ prms(2,1:nl_soil) = n_vgm (1:nl_soil,ipatch)
+ prms(3,1:nl_soil) = L_vgm (1:nl_soil,ipatch)
+ prms(4,1:nl_soil) = sc_vgm (1:nl_soil,ipatch)
+ prms(5,1:nl_soil) = fc_vgm (1:nl_soil,ipatch)
+#endif
+
+ DO ilev = 1, nl_soil
+ vol_ice(ilev) = wice_soisno(ilev,ipatch)/denice*1000. / sp_dz(ilev)
+ vol_ice(ilev) = min(vol_ice(ilev), porsl(ilev,ipatch))
+
+ eff_porosity(ilev) = max(wimp, porsl(ilev,ipatch)-vol_ice(ilev))
+ is_permeable(ilev) = eff_porosity(ilev) > max(wimp, vl_r(ilev))
+ IF (is_permeable(ilev)) THEN
+ vol_liq(ilev) = wliq_soisno(ilev,ipatch)/denh2o*1000. / sp_dz(ilev)
+ vol_liq(ilev) = min(eff_porosity(ilev), max(0., vol_liq(ilev)))
+ wresi(ilev) = wliq_soisno(ilev,ipatch) - sp_dz(ilev)*vol_liq(ilev)/1000. * denh2o
+ ELSE
+ vol_liq(ilev) = eff_porosity(ilev)
+ wresi(ilev) = 0.
+ ENDIF
+ ENDDO
+
+ zwtmm = zwt(ipatch) * 1000. ! m -> mm
+
+ ! check consistancy between water table location and liquid water content
+ DO ilev = 1, nl_soil
+ IF ((vol_liq(ilev) < eff_porosity(ilev)-1.e-8) .and. (zwtmm <= sp_zi(ilev-1))) THEN
+ zwtmm = sp_zi(ilev)
+ ENDIF
+ ENDDO
+
+ izwt = findloc_ud(zwtmm >= sp_zi, back=.true.)
+
+ IF (izwt <= nl_soil) THEN
+ IF (is_permeable(izwt) .and. (zwtmm > sp_zi(izwt-1))) THEN
+ vol_liq(izwt) = (wliq_soisno(izwt,ipatch)/denh2o*1000.0 &
+ - eff_porosity(izwt)*(sp_zi(izwt)-zwtmm)) / (zwtmm - sp_zi(izwt-1))
+
+ IF (vol_liq(izwt) < 0.) THEN
+ zwtmm = sp_zi(izwt)
+ vol_liq(izwt) = wliq_soisno(izwt,ipatch)/denh2o*1000.0 / (sp_zi(izwt)-sp_zi(izwt-1))
+ ENDIF
+
+ vol_liq(izwt) = max(0., min(eff_porosity(izwt), vol_liq(izwt)))
+ wresi(izwt) = wliq_soisno(izwt,ipatch) - (eff_porosity(izwt)*(sp_zi(izwt)-zwtmm) &
+ + vol_liq(izwt)*(zwtmm-sp_zi(izwt-1))) /1000. * denh2o
+ ENDIF
+ ENDIF
+
+ CALL soilwater_aquifer_exchange ( &
+ nl_soil, exwater, sp_zi, is_permeable, eff_porosity, vl_r, psi0(:,ipatch), &
+ hksati(:,ipatch), nprms, prms, porsl(nl_soil,ipatch), wdsrf(ipatch), &
+ vol_liq, zwtmm, wa(ipatch), izwt)
+
+ ! update the mass of liquid water
+ DO ilev = nl_soil, 1, -1
+ IF (is_permeable(ilev)) THEN
+ IF (zwtmm < sp_zi(ilev)) THEN
+ IF (zwtmm >= sp_zi(ilev-1)) THEN
+ wliq_soisno(ilev,ipatch) = ((eff_porosity(ilev)*(sp_zi(ilev)-zwtmm)) &
+ + vol_liq(ilev)*(zwtmm-sp_zi(ilev-1)))/1000.0 * denh2o
+ ELSE
+ wliq_soisno(ilev,ipatch) = denh2o * eff_porosity(ilev)*sp_dz(ilev)/1000.0
+ ENDIF
+ ELSE
+ wliq_soisno(ilev,ipatch) = denh2o * vol_liq(ilev)*sp_dz(ilev)/1000.0
+ ENDIF
+
+ wliq_soisno(ilev,ipatch) = wliq_soisno(ilev,ipatch) + wresi(ilev)
+ ENDIF
+ ENDDO
+
+ zwt(ipatch) = zwtmm/1000.0
+
+ ELSEIF (patchtype(ipatch) == 2) THEN ! wetland
+
+ wetwat(ipatch) = wdsrf(ipatch) + wa(ipatch) + wetwat(ipatch) - xwsub(ipatch)*deltime
+
+ IF (wetwat(ipatch) > wetwatmax) THEN
+ wdsrf (ipatch) = wetwat(ipatch) - wetwatmax
+ wetwat(ipatch) = wetwatmax
+ wa (ipatch) = 0.
+ ELSEIF (wetwat(ipatch) < 0) THEN
+ wa (ipatch) = wetwat(ipatch)
+ wdsrf (ipatch) = 0.
+ wetwat(ipatch) = 0.
+ ELSE
+ wdsrf(ipatch) = 0.
+ wa (ipatch) = 0.
+ ENDIF
+
+ ELSEIF (patchtype(ipatch) == 4) THEN ! land water bodies
+
+ wdsrf(ipatch) = wa(ipatch) + wdsrf(ipatch) - xwsub(ipatch)*deltime
+
+ IF (wdsrf(ipatch) < 0) THEN
+ wa (ipatch) = wdsrf(ipatch)
+ wdsrf(ipatch) = 0
+ ELSE
+ wa(ipatch) = 0
+ ENDIF
+
+ ENDIF
+
+#if (defined CoLMDEBUG)
+ ! For water balance check, the sum of water in soil column after the calcultion
+ w_sum_after = sum(wliq_soisno(1:nl_soil,ipatch)) + sum(wice_soisno(1:nl_soil,ipatch)) &
+ + wa(ipatch) + wdsrf(ipatch) + wetwat(ipatch)
+ errblc = w_sum_after - w_sum_before + xwsub(ipatch)*deltime
+
+ IF(abs(errblc) > 1.e-3)THEN
+ write(6,'(A,I0,4E20.5)') 'Warning (Subsurface Runoff): water balance violation ', &
+ ipatch, errblc, xwsub(ipatch), zwtmm
+ write(*,*) patchtype(ipatch)
+ CALL CoLM_stop ()
+ ENDIF
+#endif
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE subsurface_flow
+
+ ! ----------
+ SUBROUTINE subsurface_network_final ()
+
+ IMPLICIT NONE
+
+ IF (allocated(lake_id_elm )) deallocate(lake_id_elm )
+ IF (allocated(riverdpth_elm)) deallocate(riverdpth_elm)
+ IF (allocated(lakedepth_elm)) deallocate(lakedepth_elm)
+ IF (allocated(wdsrf_elm )) deallocate(wdsrf_elm )
+
+ IF (allocated(theta_a_nb)) deallocate(theta_a_nb)
+ IF (allocated(zwt_nb )) deallocate(zwt_nb )
+ IF (allocated(Kl_nb )) deallocate(Kl_nb )
+ IF (allocated(wdsrf_nb )) deallocate(wdsrf_nb )
+ IF (allocated(agwt_nb )) deallocate(agwt_nb )
+ IF (allocated(islake_nb )) deallocate(islake_nb )
+ IF (allocated(lakedp_nb )) deallocate(lakedp_nb )
+
+ IF (associated(hillslope_element)) deallocate(hillslope_element)
+
+ END SUBROUTINE subsurface_network_final
+
+END MODULE MOD_Catch_SubsurfaceFlow
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90
new file mode 100644
index 0000000000..3eab827aab
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_1DFluxes.F90
@@ -0,0 +1,115 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_Vars_1DFluxes
+!-------------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! 1D fluxes in lateral hydrological processes.
+!
+! Created by Shupeng Zhang, May 2023
+!-------------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ IMPLICIT NONE
+
+ ! -- fluxes --
+ real(r8), allocatable :: xsubs_elm (:) ! subsurface lateral flow between basins [m/s]
+ real(r8), allocatable :: xsubs_hru (:) ! subsurface lateral flow between hydrological response units [m/s]
+ real(r8), allocatable :: xsubs_pch (:) ! subsurface lateral flow between patches inside one HRU [m/s]
+
+ real(r8), allocatable :: wdsrf_bsn_ta (:) ! time step average of river height [m]
+ real(r8), allocatable :: momen_riv_ta (:) ! time step average of river momentum [m^2/s]
+ real(r8), allocatable :: veloc_riv_ta (:) ! time step average of river velocity [m/s]
+ real(r8), allocatable :: discharge_ta (:) ! river discharge [m^3/s]
+
+ real(r8), allocatable :: wdsrf_bsnhru_ta (:) ! time step average of surface water depth [m]
+ real(r8), allocatable :: momen_bsnhru_ta (:) ! time step average of surface water momentum [m^2/s]
+ real(r8), allocatable :: veloc_bsnhru_ta (:) ! time step average of surface water veloctiy [m/s]
+
+ real(r8), allocatable :: xwsur (:) ! surface water exchange [mm h2o/s]
+ real(r8), allocatable :: xwsub (:) ! subsurface water exchange [mm h2o/s]
+ real(r8), allocatable :: fldarea (:) ! fraction of flooded area [-]
+
+ real(r8), allocatable :: ntacc_bsn (:)
+
+ ! PUBLIC MEMBER FUNCTIONS:
+ PUBLIC :: allocate_1D_CatchFluxes
+ PUBLIC :: deallocate_1D_CatchFluxes
+
+CONTAINS
+
+ SUBROUTINE allocate_1D_CatchFluxes
+
+ USE MOD_SPMD_Task
+ USE MOD_Vars_Global, only: spval
+ USE MOD_Mesh, only: numelm
+ USE MOD_LandHRU, only: numhru
+ USE MOD_LandPatch, only: numpatch
+ USE MOD_Catch_BasinNetwork, only: numbasin, numbsnhru
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+
+ IF (numpatch > 0) THEN
+ allocate (xsubs_pch (numpatch)) ; xsubs_pch (:) = spval
+ allocate (xwsur (numpatch)) ; xwsur (:) = spval
+ allocate (xwsub (numpatch)) ; xwsub (:) = spval
+ allocate (fldarea (numpatch)) ; fldarea (:) = spval
+ ENDIF
+
+ IF (numelm > 0) THEN
+ allocate (xsubs_elm (numelm)) ; xsubs_elm(:) = spval
+ ENDIF
+
+ IF (numbasin > 0) THEN
+ allocate (wdsrf_bsn_ta (numbasin)) ; wdsrf_bsn_ta (:) = spval
+ allocate (momen_riv_ta (numbasin)) ; momen_riv_ta (:) = spval
+ allocate (veloc_riv_ta (numbasin)) ; veloc_riv_ta (:) = spval
+ allocate (discharge_ta (numbasin)) ; discharge_ta (:) = spval
+ ENDIF
+
+ IF (numhru > 0) THEN
+ allocate (xsubs_hru (numhru)); xsubs_hru(:) = spval
+ ENDIF
+
+ IF (numbsnhru > 0) THEN
+ allocate (wdsrf_bsnhru_ta (numbsnhru)) ; wdsrf_bsnhru_ta (:) = spval
+ allocate (momen_bsnhru_ta (numbsnhru)) ; momen_bsnhru_ta (:) = spval
+ allocate (veloc_bsnhru_ta (numbsnhru)) ; veloc_bsnhru_ta (:) = spval
+ ENDIF
+
+ IF (numbasin > 0) allocate (ntacc_bsn (numbasin))
+ IF (numbasin > 0) ntacc_bsn(:) = 0.
+
+ ENDIF
+
+ END SUBROUTINE allocate_1D_CatchFluxes
+
+ SUBROUTINE deallocate_1D_CatchFluxes
+
+ IMPLICIT NONE
+
+ IF (allocated(xsubs_elm)) deallocate(xsubs_elm)
+ IF (allocated(xsubs_hru)) deallocate(xsubs_hru)
+ IF (allocated(xsubs_pch)) deallocate(xsubs_pch)
+
+ IF (allocated(wdsrf_bsn_ta)) deallocate(wdsrf_bsn_ta)
+ IF (allocated(momen_riv_ta)) deallocate(momen_riv_ta)
+ IF (allocated(veloc_riv_ta)) deallocate(veloc_riv_ta)
+ IF (allocated(discharge_ta)) deallocate(discharge_ta)
+
+ IF (allocated(wdsrf_bsnhru_ta)) deallocate(wdsrf_bsnhru_ta)
+ IF (allocated(momen_bsnhru_ta)) deallocate(momen_bsnhru_ta)
+ IF (allocated(veloc_bsnhru_ta)) deallocate(veloc_bsnhru_ta)
+
+ IF (allocated(xwsur )) deallocate(xwsur )
+ IF (allocated(xwsub )) deallocate(xwsub )
+ IF (allocated(fldarea)) deallocate(fldarea)
+
+ IF (allocated(ntacc_bsn)) deallocate(ntacc_bsn)
+
+ END SUBROUTINE deallocate_1D_CatchFluxes
+
+END MODULE MOD_Catch_Vars_1DFluxes
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90
new file mode 100644
index 0000000000..37b9af417f
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_Vars_TimeVariables.F90
@@ -0,0 +1,178 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_Vars_TimeVariables
+!-------------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Time Variables in lateral hydrological processes.
+!
+! Created by Shupeng Zhang, May 2023
+!-------------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Catch_BasinNetwork
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ ! -- state variables (1): necessary for restart --
+ real(r8), allocatable :: veloc_elm (:) ! river velocity [m/s]
+ real(r8), allocatable :: veloc_hru (:) ! surface water velocity [m/s]
+ real(r8), allocatable :: wdsrf_hru (:) ! surface water depth [m]
+
+ real(r8), allocatable :: wdsrf_elm_prev (:) ! river or lake water depth at previous time step [m]
+ real(r8), allocatable :: wdsrf_hru_prev (:) ! surface water depth at previous time step [m]
+
+ ! -- state variables (2): only in model --
+ real(r8), allocatable :: wdsrf_bsn (:) ! river or lake water depth [m]
+ real(r8), allocatable :: veloc_riv (:) ! river velocity [m/s]
+ real(r8), allocatable :: momen_riv (:) ! unit river momentum [m^2/s]
+ real(r8), allocatable :: wdsrf_bsnhru (:) ! surface water depth [m]
+ real(r8), allocatable :: veloc_bsnhru (:) ! surface water velocity [m/s]
+ real(r8), allocatable :: momen_bsnhru (:) ! unit surface water momentum [m^2/s]
+
+ real(r8), allocatable :: wdsrf_bsn_prev (:) ! river or lake water depth at previous time step [m]
+ real(r8), allocatable :: wdsrf_bsnhru_prev (:) ! surface water depth at previous time step [m]
+
+ ! PUBLIC MEMBER FUNCTIONS:
+ PUBLIC :: allocate_CatchTimeVariables
+ PUBLIC :: deallocate_CatchTimeVariables
+
+ PUBLIC :: read_CatchTimeVariables
+ PUBLIC :: write_CatchTimeVariables
+
+CONTAINS
+
+ SUBROUTINE allocate_CatchTimeVariables
+
+ USE MOD_SPMD_Task
+ USE MOD_Mesh, only: numelm
+ USE MOD_LandHRU, only: numhru
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+
+ IF (numelm > 0) THEN
+ allocate (veloc_elm (numelm))
+ allocate (wdsrf_elm_prev (numelm))
+ ENDIF
+
+ IF (numhru > 0) THEN
+ allocate (veloc_hru (numhru))
+ allocate (wdsrf_hru (numhru))
+ allocate (wdsrf_hru_prev (numhru))
+ ENDIF
+
+ IF (numbasin > 0) allocate (wdsrf_bsn (numbasin))
+ IF (numbasin > 0) allocate (veloc_riv (numbasin))
+ IF (numbasin > 0) allocate (momen_riv (numbasin))
+ IF (numbasin > 0) allocate (wdsrf_bsn_prev(numbasin))
+
+ IF (numbsnhru > 0) allocate (wdsrf_bsnhru (numbsnhru))
+ IF (numbsnhru > 0) allocate (veloc_bsnhru (numbsnhru))
+ IF (numbsnhru > 0) allocate (momen_bsnhru (numbsnhru))
+ IF (numbsnhru > 0) allocate (wdsrf_bsnhru_prev (numbsnhru))
+
+ ENDIF
+
+ END SUBROUTINE allocate_CatchTimeVariables
+
+ SUBROUTINE READ_CatchTimeVariables (file_restart)
+
+ USE MOD_Mesh
+ USE MOD_LandHRU
+ USE MOD_Vector_ReadWrite
+ USE MOD_ElmVector
+ USE MOD_HRUVector
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: file_restart
+
+ CALL vector_read_and_scatter (file_restart, veloc_elm, numelm, 'veloc_riv', elm_data_address)
+ CALL compute_push_data (push_elm2bsn, veloc_elm, veloc_riv, spval)
+
+ CALL vector_read_and_scatter (file_restart, wdsrf_elm_prev, numelm, 'wdsrf_bsn_prev', elm_data_address)
+ CALL compute_push_data (push_elm2bsn, wdsrf_elm_prev, wdsrf_bsn_prev, spval)
+
+ CALL vector_read_and_scatter (file_restart, veloc_hru, numhru, 'veloc_hru', hru_data_address)
+ CALL compute_push_data (push_elmhru2bsnhru, veloc_hru, veloc_bsnhru, spval)
+
+ CALL vector_read_and_scatter (file_restart, wdsrf_hru_prev, numhru, 'wdsrf_hru_prev', hru_data_address)
+ CALL compute_push_data (push_elmhru2bsnhru, wdsrf_hru_prev, wdsrf_bsnhru_prev, spval)
+
+ END SUBROUTINE READ_CatchTimeVariables
+
+ SUBROUTINE WRITE_CatchTimeVariables (file_restart)
+
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_Mesh
+ USE MOD_LandHRU
+ USE MOD_Vector_ReadWrite
+ USE MOD_ElmVector
+ USE MOD_HRUVector
+ IMPLICIT NONE
+
+ integer :: iwork
+ character(len=*), intent(in) :: file_restart
+
+ IF (p_is_root) THEN
+ CALL ncio_create_file (trim(file_restart))
+ CALL ncio_define_dimension(file_restart, 'basin', totalnumelm)
+ CALL ncio_define_dimension(file_restart, 'hydrounit', totalnumhru)
+
+ CALL ncio_write_serial (file_restart, 'basin', eindex_glb, 'basin')
+ CALL ncio_put_attr (file_restart, 'basin', 'long_name', 'basin index')
+
+ CALL ncio_write_serial (file_restart, 'bsn_hru', eindx_hru, 'hydrounit')
+ CALL ncio_put_attr (file_restart, 'bsn_hru', &
+ 'long_name', 'basin index of hydrological units')
+
+ CALL ncio_write_serial (file_restart, 'hru_type' , htype_hru, 'hydrounit')
+ CALL ncio_put_attr (file_restart, 'hru_type' , &
+ 'long_name', 'index of hydrological units inside basin')
+ ENDIF
+
+ CALL compute_push_data (push_bsn2elm, veloc_riv, veloc_elm, spval)
+ CALL vector_gather_and_write (&
+ veloc_elm, numelm, totalnumelm, elm_data_address, file_restart, 'veloc_riv', 'basin')
+
+ CALL compute_push_data (push_bsn2elm, wdsrf_bsn_prev, wdsrf_elm_prev, spval)
+ CALL vector_gather_and_write (&
+ wdsrf_elm_prev, numelm, totalnumelm, elm_data_address, file_restart, 'wdsrf_bsn_prev', 'basin')
+
+ CALL compute_push_data (push_bsnhru2elmhru, veloc_bsnhru, veloc_hru, spval)
+ CALL vector_gather_and_write (&
+ veloc_hru, numhru, totalnumhru, hru_data_address, file_restart, 'veloc_hru', 'hydrounit')
+
+ CALL compute_push_data (push_bsnhru2elmhru, wdsrf_bsnhru_prev, wdsrf_hru_prev, spval)
+ CALL vector_gather_and_write (&
+ wdsrf_hru_prev, numhru, totalnumhru, hru_data_address, file_restart, 'wdsrf_hru_prev', 'hydrounit')
+
+ END SUBROUTINE WRITE_CatchTimeVariables
+
+ SUBROUTINE deallocate_CatchTimeVariables
+
+ IMPLICIT NONE
+
+ IF (allocated(veloc_elm)) deallocate(veloc_elm)
+ IF (allocated(veloc_hru)) deallocate(veloc_hru)
+ IF (allocated(wdsrf_hru)) deallocate(wdsrf_hru)
+
+ IF (allocated(wdsrf_elm_prev)) deallocate(wdsrf_elm_prev)
+ IF (allocated(wdsrf_hru_prev)) deallocate(wdsrf_hru_prev)
+
+ IF (allocated (wdsrf_bsn )) deallocate (wdsrf_bsn )
+ IF (allocated (veloc_riv )) deallocate (veloc_riv )
+ IF (allocated (momen_riv )) deallocate (momen_riv )
+ IF (allocated (wdsrf_bsn_prev)) deallocate (wdsrf_bsn_prev)
+
+ IF (allocated (wdsrf_bsnhru )) deallocate (wdsrf_bsnhru )
+ IF (allocated (veloc_bsnhru )) deallocate (veloc_bsnhru )
+ IF (allocated (momen_bsnhru )) deallocate (momen_bsnhru )
+ IF (allocated (wdsrf_bsnhru_prev)) deallocate (wdsrf_bsnhru_prev)
+
+ END SUBROUTINE deallocate_CatchTimeVariables
+
+END MODULE MOD_Catch_Vars_TimeVariables
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90
new file mode 100644
index 0000000000..c872b4ebf4
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Catch_WriteParameters.F90
@@ -0,0 +1,230 @@
+#include
+
+#ifdef CatchLateralFlow
+MODULE MOD_Catch_WriteParameters
+
+CONTAINS
+
+ SUBROUTINE write_catch_parameters
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_NetCDFSerial
+ USE MOD_Vector_ReadWrite
+ USE MOD_ElmVector
+ USE MOD_Catch_Reservoir
+ USE MOD_Vars_TimeInvariants, only : wf_sand, wf_clay, wf_om, wf_gravels, patchclass
+ USE MOD_Catch_SubsurfaceFlow, only : hillslope_element, lake_id_elm
+ USE MOD_HRUVector, only : totalnumhru, hru_data_address, eindx_hru, htype_hru
+ USE MOD_Mesh, only : numelm
+ USE MOD_LandHRU, only : numhru
+ USE MOD_LandPatch, only : hru_patch
+ USE MOD_Vars_Global, only : spval
+ IMPLICIT NONE
+
+ character(len=256) :: file_parameters
+ character(len=1) :: slev
+ real(r8), allocatable :: hrupara(:), varpara(:)
+ integer :: ilev, i, ps, pe, ielm, ihru, j
+
+ file_parameters = trim(DEF_dir_output) // '/' // trim(DEF_CASE_NAME) // '/catch_parameters.nc'
+
+ IF (p_is_root) THEN
+ CALL ncio_create_file (trim(file_parameters))
+ CALL ncio_define_dimension(file_parameters, 'hydrounit', totalnumhru)
+
+ CALL ncio_write_serial (file_parameters, 'bsn_hru', eindx_hru, 'hydrounit')
+ CALL ncio_put_attr (file_parameters, 'bsn_hru', &
+ 'long_name', 'basin index of hydrological units')
+
+ CALL ncio_write_serial (file_parameters, 'hru_type' , htype_hru, 'hydrounit')
+ CALL ncio_put_attr (file_parameters, 'hru_type' , &
+ 'long_name', 'index of hydrological units inside basin')
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numhru > 0) allocate (hrupara (numhru))
+ ENDIF
+
+ DO ilev = 1, 5
+
+ write(slev,'(i1.1)') ilev
+
+ ! sand
+ IF (p_is_compute) THEN
+ DO i = 1, numhru
+ ps = hru_patch%substt(i)
+ pe = hru_patch%subend(i)
+ hrupara(i) = sum(wf_sand(ilev,ps:pe) * hru_patch%subfrc(ps:pe))
+ ENDDO
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_sand_l'//slev, 'hydrounit')
+
+ ! clay
+ IF (p_is_compute) THEN
+ DO i = 1, numhru
+ ps = hru_patch%substt(i)
+ pe = hru_patch%subend(i)
+ hrupara(i) = sum(wf_clay(ilev,ps:pe) * hru_patch%subfrc(ps:pe))
+ ENDDO
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_clay_l'//slev, 'hydrounit')
+
+ ! organic matter
+ IF (p_is_compute) THEN
+ DO i = 1, numhru
+ ps = hru_patch%substt(i)
+ pe = hru_patch%subend(i)
+ hrupara(i) = sum(wf_om(ilev,ps:pe) * hru_patch%subfrc(ps:pe))
+ ENDDO
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_om_l'//slev, 'hydrounit')
+
+ ! silt
+ IF (p_is_compute) THEN
+ DO i = 1, numhru
+ ps = hru_patch%substt(i)
+ pe = hru_patch%subend(i)
+ hrupara(i) = sum((1-wf_sand(ilev,ps:pe)-wf_gravels(ilev,ps:pe)-wf_om(ilev,ps:pe)-wf_clay(ilev,ps:pe)) * hru_patch%subfrc(ps:pe))
+ ENDDO
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'wf_silt_l'//slev, 'hydrounit')
+ ENDDO
+
+
+
+ IF (p_is_compute) THEN
+ DO i = 1, numhru
+ ps = hru_patch%substt(i)
+ pe = hru_patch%subend(i)
+ hrupara(i) = patchclass(ps)
+ ENDDO
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'lulc_igbp', 'hydrounit')
+
+ IF (p_is_compute) THEN
+ IF (numhru > 0) hrupara(:) = spval
+ DO ielm = 1, numelm
+ IF (lake_id_elm(ielm) <= 0) THEN
+ DO i = 1, hillslope_element(ielm)%nhru
+ IF (hillslope_element(ielm)%indx(i) /= 0) THEN
+ ihru = hillslope_element(ielm)%ihru(i)
+ hrupara(ihru) = hillslope_element(ielm)%plen(i) * 2.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'slope_length', 'hydrounit')
+
+ IF (p_is_root) THEN
+ CALL ncio_put_attr (file_parameters, 'slope_length', 'units', 'm')
+ CALL ncio_put_attr (file_parameters, 'slope_length', 'missing_value', spval)
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numhru > 0) hrupara(:) = spval
+ DO ielm = 1, numelm
+ IF (lake_id_elm(ielm) <= 0) THEN
+ DO i = 1, hillslope_element(ielm)%nhru
+ IF (hillslope_element(ielm)%indx(i) /= 0) THEN
+ ihru = hillslope_element(ielm)%ihru(i)
+ hrupara(ihru) = hillslope_element(ielm)%elva(i)
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'elevation', 'hydrounit')
+
+ IF (p_is_root) THEN
+ CALL ncio_put_attr (file_parameters, 'elevation', 'units', 'm')
+ CALL ncio_put_attr (file_parameters, 'elevation', 'missing_value', spval)
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numhru > 0) hrupara(:) = spval
+ DO ielm = 1, numelm
+ IF (lake_id_elm(ielm) <= 0) THEN
+ DO i = 1, hillslope_element(ielm)%nhru
+ IF (hillslope_element(ielm)%indx(i) /= 0) THEN
+ ihru = hillslope_element(ielm)%ihru(i)
+ j = hillslope_element(ielm)%inext(i)
+ IF (j > 0) THEN
+ hrupara(ihru) = (hillslope_element(ielm)%hand(i) - hillslope_element(ielm)%hand(j)) &
+ / (hillslope_element(ielm)%plen(i) + hillslope_element(ielm)%plen(j))
+ ELSE
+ hrupara(ihru) = hillslope_element(ielm)%hand(i) / hillslope_element(ielm)%plen(i)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ hrupara, numhru, totalnumhru, hru_data_address, file_parameters, 'slope_ratio', 'hydrounit')
+
+ IF (p_is_root) THEN
+ CALL ncio_put_attr (file_parameters, 'slope_ratio', 'units', '-')
+ CALL ncio_put_attr (file_parameters, 'slope_ratio', 'missing_value', spval)
+ ENDIF
+
+ IF (allocated(hrupara)) deallocate(hrupara)
+
+
+ ! ----- reservoirs -----
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (numresv_uniq > 0) THEN
+
+ IF (p_is_root) THEN
+ CALL ncio_define_dimension (file_parameters, 'reservoir', numresv_uniq)
+ CALL ncio_write_serial (file_parameters, 'resv_hylak_id' , resv_hylak_id, 'reservoir')
+ CALL ncio_put_attr (file_parameters, 'resv_hylak_id' , 'long_name', &
+ 'HydroLAKE ID of reservoirs')
+ ENDIF
+
+ allocate (varpara (numresv_uniq))
+
+ CALL reservoir_gather_var (volresv_total, varpara)
+ IF (p_is_root) THEN
+ CALL ncio_write_serial (file_parameters, 'volresv_total', varpara, 'reservoir', 1)
+ CALL ncio_put_attr (file_parameters, 'volresv_total', 'units', 'm^3')
+ ENDIF
+
+ CALL reservoir_gather_var (qresv_mean, varpara)
+ IF (p_is_root) THEN
+ CALL ncio_write_serial (file_parameters, 'qresv_mean', varpara, 'reservoir', 1)
+ CALL ncio_put_attr (file_parameters, 'qresv_mean', 'units', 'm^3/s')
+ ENDIF
+
+ CALL reservoir_gather_var (qresv_flood, varpara)
+ IF (p_is_root) THEN
+ CALL ncio_write_serial (file_parameters, 'qresv_flood', varpara, 'reservoir', 1)
+ CALL ncio_put_attr (file_parameters, 'qresv_flood', 'units', 'm^3/s')
+ ENDIF
+
+ deallocate (varpara)
+
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE write_catch_parameters
+
+END MODULE MOD_Catch_WriteParameters
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90
new file mode 100644
index 0000000000..8897bb1f3c
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_ElementNeighbour.F90
@@ -0,0 +1,711 @@
+#include
+
+MODULE MOD_ElementNeighbour
+!--------------------------------------------------------------------------------!
+! DESCRIPTION: !
+! !
+! Element Neighbours : data and communication subroutines. !
+! !
+! Created by Shupeng Zhang, May 2023 !
+!--------------------------------------------------------------------------------!
+
+ USE MOD_Precision
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ ! -- neighbour parameters --
+ type element_neighbour_type
+
+ integer :: nnb ! number of neighbours
+ real(r8) :: myarea ! area of this element [m^2]
+ real(r8) :: myelva ! elevation of this element [m]
+
+ integer*8, allocatable :: glbindex (:) ! neighbour global index
+
+ ! data address: (1,:) refers to process, (2,:) refers to location
+ integer , allocatable :: addr (:,:)
+
+ real(r8), allocatable :: dist (:) ! distance between element centers [m]
+ real(r8), allocatable :: lenbdr (:) ! length of boundary line [m]
+ real(r8), allocatable :: area (:) ! area of neighbours [m^2]
+ real(r8), allocatable :: elva (:) ! elevation of neighbours [m]
+ real(r8), allocatable :: slope (:) ! slope (positive) [-]
+
+ END type element_neighbour_type
+
+ type(element_neighbour_type), allocatable :: elementneighbour (:)
+
+ ! -- neighbour communication --
+ type neighbour_sendrecv_type
+ integer :: ndata
+ integer*8, allocatable :: glbindex (:)
+ integer, allocatable :: ielement (:)
+ END type neighbour_sendrecv_type
+
+ type(neighbour_sendrecv_type), allocatable :: recvaddr(:)
+ type(neighbour_sendrecv_type), allocatable :: sendaddr(:)
+
+ INTERFACE allocate_neighbour_data
+ MODULE procedure allocate_neighbour_data_real8
+ MODULE procedure allocate_neighbour_data_logic
+ END INTERFACE allocate_neighbour_data
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE element_neighbour_init (patcharea, lc_year)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_NetCDFSerial
+ USE MOD_NetCDFVector
+ USE MOD_Mesh
+ USE MOD_Pixel
+ USE MOD_LandElm
+ USE MOD_LandPatch
+ USE MOD_Utils
+ IMPLICIT NONE
+
+ integer, intent(in) :: lc_year ! which year of land cover data used
+ real(r8), intent(in) :: patcharea (:)
+
+ ! Local Variables
+ character(len=256) :: neighbour_file
+
+ integer :: ielm
+ integer :: iwork, mesg(2), isrc, idest
+ integer :: nrecv, irecv
+ integer :: iloc, iloc1, iloc2
+ integer :: nnb, nnbinq, inb, ndata
+
+ integer :: maxnnb
+ integer , allocatable :: nnball (:)
+ integer , allocatable :: idxnball (:,:)
+ real(r8), allocatable :: lenbdall (:,:)
+
+ integer , allocatable :: addrelement(:)
+
+ integer*8, allocatable :: eindex (:)
+ integer, allocatable :: icache1 (:)
+ integer, allocatable :: icache2 (:,:)
+ real(r8), allocatable :: rcache2 (:,:)
+
+ integer*8, allocatable :: elm_sorted (:)
+ integer, allocatable :: order (:)
+ integer*8, allocatable :: idxinq (:)
+ integer, allocatable :: addrinq (:)
+
+ logical, allocatable :: mask(:)
+
+ real(r8), allocatable :: rlon_b(:), rlat_b(:)
+ type(pointer_real8_1d), allocatable :: rlon_nb(:), rlat_nb(:)
+
+ real(r8), allocatable :: area_b(:)
+ real(r8), allocatable :: elva_b(:)
+
+ character(len=256) :: lndname, cyear
+ real(r8), allocatable :: elv_patches(:)
+
+ type(pointer_real8_1d), allocatable :: area_nb (:) ! m^2
+ type(pointer_real8_1d), allocatable :: elva_nb (:) ! m
+
+ integer :: istt, iend
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ neighbour_file = DEF_ElementNeighbour_file
+
+ IF (p_is_root) THEN
+ CALL ncio_read_serial (neighbour_file, 'num_neighbour', nnball )
+ CALL ncio_read_serial (neighbour_file, 'idx_neighbour', idxnball)
+ CALL ncio_read_serial (neighbour_file, 'len_border' , lenbdall)
+
+ maxnnb = size(idxnball,1)
+
+ lenbdall = lenbdall * 1.e3 ! km to m
+ ENDIF
+
+#ifdef USEMPI
+
+ CALL mpi_bcast (maxnnb, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+
+ IF (p_is_root) THEN
+
+ allocate (addrelement (size(nnball)))
+ addrelement(:) = -1
+
+ DO iwork = 0, p_np_compute-1
+
+ CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ isrc = mesg(1)
+ nrecv = mesg(2)
+
+ IF (nrecv > 0) THEN
+
+ allocate (eindex (nrecv))
+ allocate (icache1 (nrecv))
+ allocate (icache2 (maxnnb,nrecv))
+ allocate (rcache2 (maxnnb,nrecv))
+
+ CALL mpi_recv (eindex, nrecv, MPI_INTEGER8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ addrelement(eindex) = isrc
+
+ idest = isrc
+
+ icache1 = nnball(eindex)
+ CALL mpi_send (icache1, nrecv, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ DO irecv = 1, nrecv
+ icache2(:,irecv) = idxnball(:,eindex(irecv))
+ ENDDO
+ CALL mpi_send (icache2, maxnnb*nrecv, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ DO irecv = 1, nrecv
+ rcache2(:,irecv) = lenbdall(:,eindex(irecv))
+ ENDDO
+ CALL mpi_send (rcache2, maxnnb*nrecv, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (eindex )
+ deallocate (icache1)
+ deallocate (icache2)
+ deallocate (rcache2)
+
+ ENDIF
+ ENDDO
+ ENDIF
+#endif
+
+ IF (p_is_compute) THEN
+
+ IF (numelm > 0) THEN
+ allocate (eindex (numelm))
+ eindex = landelm%eindex
+ ENDIF
+
+#ifdef USEMPI
+ mesg(1:2) = (/p_iam_glb, numelm/)
+ CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (numelm > 0) THEN
+ CALL mpi_send (eindex, numelm, MPI_INTEGER8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+
+ allocate (nnball (numelm))
+ CALL mpi_recv (nnball, numelm, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (idxnball (maxnnb,numelm))
+ CALL mpi_recv (idxnball, maxnnb*numelm, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (lenbdall (maxnnb,numelm))
+ CALL mpi_recv (lenbdall, maxnnb*numelm, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+#else
+ allocate (icache1 (numelm))
+ allocate (icache2 (maxnnb,numelm))
+ allocate (rcache2 (maxnnb,numelm))
+
+ icache1 = nnball
+ icache2 = idxnball
+ rcache2 = lenbdall
+
+ DO ielm = 1, numelm
+ nnball (ielm) = icache1 (eindex(ielm))
+ idxnball (:,ielm) = icache2 (:,eindex(ielm))
+ lenbdall (:,ielm) = rcache2 (:,eindex(ielm))
+ ENDDO
+
+ deallocate (icache1, icache2, rcache2)
+#endif
+
+ IF (numelm > 0) THEN
+
+ allocate (elementneighbour (numelm))
+
+ DO ielm = 1, numelm
+ nnb = nnball(ielm)
+ elementneighbour(ielm)%nnb = nnb
+
+ IF (nnb > 0) THEN
+ allocate (elementneighbour(ielm)%glbindex (nnb))
+ allocate (elementneighbour(ielm)%lenbdr (nnb))
+ allocate (elementneighbour(ielm)%addr (2,nnb))
+
+ elementneighbour(ielm)%glbindex = idxnball(1:nnb,ielm)
+ elementneighbour(ielm)%lenbdr = lenbdall(1:nnb,ielm)
+ elementneighbour(ielm)%addr(1,:) = -9999
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+#ifdef USEMPI
+ IF (p_is_root) THEN
+ DO iwork = 0, p_np_compute-1
+
+ CALL mpi_recv (mesg(1:2), 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ isrc = mesg(1)
+ nrecv = mesg(2)
+
+ IF (nrecv > 0) THEN
+ allocate (eindex (nrecv))
+ allocate (icache1 (nrecv))
+
+ CALL mpi_recv (eindex, nrecv, MPI_INTEGER8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ icache1 = addrelement(eindex)
+
+ idest = isrc
+ CALL mpi_send (icache1, nrecv, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate(eindex, icache1)
+ ENDIF
+ ENDDO
+ ENDIF
+#endif
+
+ IF (p_is_compute) THEN
+
+ IF (numelm > 0) THEN
+ allocate (elm_sorted (numelm))
+ allocate (order (numelm))
+
+ elm_sorted = eindex
+ order = (/(ielm, ielm = 1, numelm)/)
+
+ CALL quicksort (numelm, elm_sorted, order)
+
+#ifdef USEMPI
+ allocate(idxinq (numelm*maxnnb))
+#endif
+
+ nnbinq = 0
+ DO ielm = 1, numelm
+ DO inb = 1, elementneighbour(ielm)%nnb
+
+ IF (elementneighbour(ielm)%glbindex(inb) <= 0) CYCLE ! skip ocean neighbour
+
+ iloc = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), numelm, elm_sorted)
+ IF (iloc > 0) THEN
+ elementneighbour(ielm)%addr(1,inb) = -1
+ elementneighbour(ielm)%addr(2,inb) = order(iloc)
+#ifdef USEMPI
+ ELSE
+ CALL insert_into_sorted_list1 (elementneighbour(ielm)%glbindex(inb), nnbinq, idxinq, iloc)
+#endif
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ nnbinq = 0
+ ENDIF
+
+#ifdef USEMPI
+ mesg(1:2) = (/p_iam_glb, nnbinq/)
+ CALL mpi_send (mesg(1:2), 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (nnbinq > 0) THEN
+
+ CALL mpi_send (idxinq(1:nnbinq), nnbinq, MPI_INTEGER8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+
+ allocate (addrinq (nnbinq))
+ CALL mpi_recv (addrinq, nnbinq, MPI_INTEGER, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ ENDIF
+
+ IF (nnbinq > 0) allocate(mask (nnbinq))
+
+ allocate (recvaddr (0:p_np_compute-1))
+ DO iwork = 0, p_np_compute-1
+ IF (nnbinq > 0) THEN
+ mask = (addrinq == p_address_compute(iwork))
+ ndata = count(mask)
+ ELSE
+ ndata = 0
+ ENDIF
+
+ recvaddr(iwork)%ndata = ndata
+ IF (ndata > 0) THEN
+ allocate (recvaddr(iwork)%glbindex (ndata))
+ recvaddr(iwork)%glbindex = pack(idxinq(1:nnbinq), mask)
+ ENDIF
+ ENDDO
+
+ IF (nnbinq > 0) deallocate(mask)
+
+ DO ielm = 1, numelm
+ DO inb = 1, elementneighbour(ielm)%nnb
+ IF ((elementneighbour(ielm)%addr(1,inb) == -9999) &
+ .and. (elementneighbour(ielm)%glbindex(inb) > 0)) THEN ! skip ocean neighbour
+
+ iloc = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), &
+ nnbinq, idxinq(1:nnbinq))
+
+ iwork = p_itis_compute(addrinq(iloc))
+ iloc1 = find_in_sorted_list1 (elementneighbour(ielm)%glbindex(inb), &
+ recvaddr(iwork)%ndata, recvaddr(iwork)%glbindex)
+
+ elementneighbour(ielm)%addr(1,inb) = iwork
+ elementneighbour(ielm)%addr(2,inb) = iloc1
+ ENDIF
+ ENDDO
+ ENDDO
+
+ allocate (sendaddr (0:p_np_compute-1))
+ DO iwork = 0, p_np_compute-1
+ sendaddr(iwork)%ndata = 0
+ ENDDO
+
+ DO ielm = 1, numelm
+ DO inb = 1, elementneighbour(ielm)%nnb
+ IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN
+ iwork = elementneighbour(ielm)%addr(1,inb)
+ sendaddr(iwork)%ndata = sendaddr(iwork)%ndata + 1
+ ENDIF
+ ENDDO
+ ENDDO
+
+ DO iwork = 0, p_np_compute-1
+ IF (sendaddr(iwork)%ndata > 0) THEN
+ allocate (sendaddr(iwork)%glbindex (sendaddr(iwork)%ndata))
+ sendaddr(iwork)%ndata = 0
+ ENDIF
+ ENDDO
+
+ DO ielm = 1, numelm
+ DO inb = 1, elementneighbour(ielm)%nnb
+ IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN
+ iwork = elementneighbour(ielm)%addr(1,inb)
+ CALL insert_into_sorted_list1 (eindex(ielm), &
+ sendaddr(iwork)%ndata, sendaddr(iwork)%glbindex, iloc)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ DO iwork = 0, p_np_compute-1
+ IF (sendaddr(iwork)%ndata > 0) THEN
+ IF (sendaddr(iwork)%ndata < size(sendaddr(iwork)%glbindex)) THEN
+ allocate (icache1 (sendaddr(iwork)%ndata))
+ icache1 = sendaddr(iwork)%glbindex(1:sendaddr(iwork)%ndata)
+
+ deallocate (sendaddr(iwork)%glbindex)
+ allocate (sendaddr(iwork)%glbindex (sendaddr(iwork)%ndata))
+ sendaddr(iwork)%glbindex = icache1
+
+ deallocate (icache1)
+ ENDIF
+ ENDIF
+ ENDDO
+
+ DO iwork = 0, p_np_compute-1
+ IF (sendaddr(iwork)%ndata > 0) THEN
+ allocate (sendaddr(iwork)%ielement (sendaddr(iwork)%ndata))
+
+ DO inb = 1, sendaddr(iwork)%ndata
+ iloc = find_in_sorted_list1 (sendaddr(iwork)%glbindex(inb), numelm, elm_sorted)
+ sendaddr(iwork)%ielement(inb) = order(iloc)
+ ENDDO
+ ENDIF
+ ENDDO
+#endif
+ ENDIF
+
+ IF (allocated(addrelement)) deallocate(addrelement)
+ IF (allocated(elm_sorted )) deallocate(elm_sorted )
+ IF (allocated(nnball )) deallocate(nnball )
+ IF (allocated(idxnball )) deallocate(idxnball )
+ IF (allocated(lenbdall )) deallocate(lenbdall )
+ IF (allocated(eindex )) deallocate(eindex )
+ IF (allocated(icache1 )) deallocate(icache1 )
+ IF (allocated(icache2 )) deallocate(icache2 )
+ IF (allocated(rcache2 )) deallocate(rcache2 )
+ IF (allocated(order )) deallocate(order )
+ IF (allocated(idxinq )) deallocate(idxinq )
+ IF (allocated(addrinq )) deallocate(addrinq )
+ IF (allocated(mask )) deallocate(mask )
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ write(cyear,'(i4.4)') lc_year
+ lndname = trim(DEF_dir_landdata) // '/topography/'//trim(cyear)//'/elevation_patches.nc'
+ CALL ncio_read_vector (lndname, 'elevation_patches', landpatch, elv_patches)
+
+ IF (p_is_compute) THEN
+
+ DO ielm = 1, numelm
+ nnb = elementneighbour(ielm)%nnb
+ IF (nnb > 0) THEN
+ allocate (elementneighbour(ielm)%dist (nnb))
+ allocate (elementneighbour(ielm)%area (nnb))
+ allocate (elementneighbour(ielm)%elva (nnb))
+ allocate (elementneighbour(ielm)%slope (nnb))
+ ENDIF
+ ENDDO
+
+ IF (numelm > 0) THEN
+ allocate (rlon_b(numelm))
+ allocate (rlat_b(numelm))
+ CALL landelm%get_lonlat_radian (rlon_b, rlat_b)
+ ENDIF
+
+ CALL allocate_neighbour_data (rlon_nb)
+ CALL allocate_neighbour_data (rlat_nb)
+
+ CALL retrieve_neighbour_data (rlon_b, rlon_nb)
+ CALL retrieve_neighbour_data (rlat_b, rlat_nb)
+
+ DO ielm = 1, numelm
+ DO inb = 1, elementneighbour(ielm)%nnb
+ IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour
+ elementneighbour(ielm)%dist(inb) = 1.0e3 * arclen ( &
+ rlat_b (ielm), rlon_b (ielm), &
+ rlat_nb(ielm)%val(inb), rlon_nb(ielm)%val(inb))
+ elementneighbour(ielm)%dist(inb) = max(elementneighbour(ielm)%dist(inb), 90.)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ IF (numelm > 0) THEN
+ allocate (area_b(numelm))
+ allocate (elva_b(numelm))
+ DO ielm = 1, numelm
+ istt = elm_patch%substt(ielm)
+ iend = elm_patch%subend(ielm)
+ area_b(ielm) = sum(patcharea(istt:iend))
+ elva_b(ielm) = sum(elv_patches(istt:iend) * elm_patch%subfrc(istt:iend))
+
+ elementneighbour(ielm)%myarea = area_b(ielm)
+ elementneighbour(ielm)%myelva = elva_b(ielm)
+ ENDDO
+ ENDIF
+
+ CALL allocate_neighbour_data (area_nb)
+ CALL retrieve_neighbour_data (area_b, area_nb)
+
+ CALL allocate_neighbour_data (elva_nb)
+ CALL retrieve_neighbour_data (elva_b, elva_nb)
+
+ DO ielm = 1, numelm
+ DO inb = 1, elementneighbour(ielm)%nnb
+ IF (elementneighbour(ielm)%glbindex(inb) > 0) THEN ! skip ocean neighbour
+ elementneighbour(ielm)%area (inb) = area_nb(ielm)%val(inb)
+ elementneighbour(ielm)%elva (inb) = elva_nb(ielm)%val(inb)
+ elementneighbour(ielm)%slope(inb) = &
+ abs(elva_nb(ielm)%val(inb) - elva_b(ielm)) / elementneighbour(ielm)%dist(inb)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ IF (allocated(rlon_b )) deallocate(rlon_b )
+ IF (allocated(rlat_b )) deallocate(rlat_b )
+ IF (allocated(elva_b )) deallocate(elva_b )
+ IF (allocated(area_b )) deallocate(area_b )
+ IF (allocated(rlon_nb)) deallocate(rlon_nb)
+ IF (allocated(rlat_nb)) deallocate(rlat_nb)
+ IF (allocated(area_nb)) deallocate(area_nb)
+ IF (allocated(elva_nb)) deallocate(elva_nb)
+
+ ENDIF
+
+ END SUBROUTINE element_neighbour_init
+
+ ! ----------
+ SUBROUTINE retrieve_neighbour_data (vec_in, nbdata)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Mesh, only: numelm
+ IMPLICIT NONE
+
+ real(r8), intent(inout) :: vec_in (:)
+ type(pointer_real8_1d) :: nbdata (:)
+
+ ! Local Variables
+ logical, allocatable :: smask(:), rmask(:)
+ integer, allocatable :: req_send(:), req_recv(:)
+ type(pointer_real8_1d), allocatable :: sbuff(:), rbuff(:)
+ integer :: iwork, ielm, inb, iloc
+
+ IF (p_is_compute) THEN
+
+ DO ielm = 1, numelm
+ DO inb = 1, elementneighbour(ielm)%nnb
+ IF (elementneighbour(ielm)%addr(1,inb)== -1) THEN
+ iloc = elementneighbour(ielm)%addr(2,inb)
+ nbdata(ielm)%val(inb) = vec_in(iloc)
+ ENDIF
+ ENDDO
+ ENDDO
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_compute, p_err)
+
+ allocate (smask (0:p_np_compute-1))
+ allocate (req_send (0:p_np_compute-1))
+ allocate (sbuff (0:p_np_compute-1))
+ smask(:) = .false.
+
+ DO iwork = 0, p_np_compute-1
+ IF (sendaddr(iwork)%ndata > 0) THEN
+ smask(iwork) = .true.
+
+ allocate (sbuff(iwork)%val (sendaddr(iwork)%ndata))
+ sbuff(iwork)%val = vec_in(sendaddr(iwork)%ielement)
+
+ CALL mpi_isend(sbuff(iwork)%val, sendaddr(iwork)%ndata, MPI_REAL8, &
+ p_address_compute(iwork), 101, p_comm_glb, req_send(iwork), p_err)
+ ENDIF
+ ENDDO
+
+ allocate (rmask (0:p_np_compute-1))
+ allocate (req_recv (0:p_np_compute-1))
+ allocate (rbuff (0:p_np_compute-1))
+ rmask(:) = .false.
+
+ DO iwork = 0, p_np_compute-1
+ IF (recvaddr(iwork)%ndata > 0) THEN
+ rmask(iwork) = .true.
+
+ allocate (rbuff(iwork)%val (recvaddr(iwork)%ndata))
+
+ CALL mpi_irecv(rbuff(iwork)%val, recvaddr(iwork)%ndata, MPI_REAL8, &
+ p_address_compute(iwork), 101, p_comm_glb, req_recv(iwork), p_err)
+ ENDIF
+ ENDDO
+
+ IF (any(rmask)) THEN
+
+ CALL mpi_waitall(count(rmask), pack(req_recv,rmask), MPI_STATUSES_IGNORE, p_err)
+
+ DO ielm = 1, numelm
+ DO inb = 1, elementneighbour(ielm)%nnb
+ IF (elementneighbour(ielm)%addr(1,inb) >= 0) THEN
+ iwork = elementneighbour(ielm)%addr(1,inb)
+ iloc = elementneighbour(ielm)%addr(2,inb)
+ nbdata(ielm)%val(inb) = rbuff(iwork)%val(iloc)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF (any(smask)) THEN
+ CALL mpi_waitall(count(smask), pack(req_send,smask), MPI_STATUSES_IGNORE, p_err)
+ ENDIF
+
+ IF (allocated(smask)) deallocate(smask)
+ IF (allocated(rmask)) deallocate(rmask)
+
+ IF (allocated(req_send)) deallocate(req_send)
+ IF (allocated(req_recv)) deallocate(req_recv)
+
+ IF (allocated(sbuff)) deallocate(sbuff)
+ IF (allocated(rbuff)) deallocate(rbuff)
+
+ CALL mpi_barrier (p_comm_compute, p_err)
+#endif
+
+ ENDIF
+
+ END SUBROUTINE retrieve_neighbour_data
+
+ ! ---
+ SUBROUTINE allocate_neighbour_data_real8 (nbdata)
+
+ USE MOD_Mesh, only: numelm
+ IMPLICIT NONE
+
+ type(pointer_real8_1d), allocatable :: nbdata(:)
+ integer :: ielm
+
+ IF (numelm > 0) THEN
+ allocate (nbdata(numelm))
+ DO ielm = 1, numelm
+ IF (elementneighbour(ielm)%nnb > 0) THEN
+ allocate (nbdata(ielm)%val (elementneighbour(ielm)%nnb))
+ ENDIF
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE allocate_neighbour_data_real8
+
+ ! ---
+ SUBROUTINE allocate_neighbour_data_logic (nbdata)
+
+ USE MOD_Mesh, only: numelm
+ IMPLICIT NONE
+
+ type(pointer_logic_1d), allocatable :: nbdata(:)
+ integer :: ielm
+
+ IF (numelm > 0) THEN
+ allocate (nbdata(numelm))
+ DO ielm = 1, numelm
+ IF (elementneighbour(ielm)%nnb > 0) THEN
+ allocate (nbdata(ielm)%val (elementneighbour(ielm)%nnb))
+ ENDIF
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE allocate_neighbour_data_logic
+
+ ! ----------
+ SUBROUTINE element_neighbour_final ()
+
+ IMPLICIT NONE
+ integer :: i
+
+ IF (allocated(elementneighbour)) THEN
+ DO i = 1, size(elementneighbour)
+ IF (allocated(elementneighbour(i)%glbindex)) deallocate(elementneighbour(i)%glbindex)
+ IF (allocated(elementneighbour(i)%addr )) deallocate(elementneighbour(i)%addr )
+ IF (allocated(elementneighbour(i)%dist )) deallocate(elementneighbour(i)%dist )
+ IF (allocated(elementneighbour(i)%lenbdr)) deallocate(elementneighbour(i)%lenbdr)
+ IF (allocated(elementneighbour(i)%area )) deallocate(elementneighbour(i)%area )
+ IF (allocated(elementneighbour(i)%elva )) deallocate(elementneighbour(i)%elva )
+ IF (allocated(elementneighbour(i)%slope )) deallocate(elementneighbour(i)%slope )
+ ENDDO
+ deallocate(elementneighbour)
+ ENDIF
+
+ IF (allocated(recvaddr)) THEN
+ DO i = lbound(recvaddr,1), ubound(recvaddr,1)
+ IF (allocated(recvaddr(i)%glbindex)) deallocate(recvaddr(i)%glbindex)
+ IF (allocated(recvaddr(i)%ielement)) deallocate(recvaddr(i)%ielement)
+ ENDDO
+ ENDIF
+
+ IF (allocated(sendaddr)) THEN
+ DO i = lbound(sendaddr,1), ubound(sendaddr,1)
+ IF (allocated(sendaddr(i)%glbindex)) deallocate(sendaddr(i)%glbindex)
+ IF (allocated(sendaddr(i)%ielement)) deallocate(sendaddr(i)%ielement)
+ ENDDO
+ ENDIF
+
+ IF (allocated(recvaddr)) deallocate(recvaddr)
+ IF (allocated(sendaddr)) deallocate(sendaddr)
+
+ END SUBROUTINE element_neighbour_final
+
+END MODULE MOD_ElementNeighbour
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..d41418d8ce
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_Reservoir.F90
@@ -0,0 +1,337 @@
+#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
+ integer :: numresv
+ 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_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_Utils
+ USE MOD_Namelist, only: DEF_ReservoirPara_file
+ USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_ucid, lake_type
+
+ 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, nresv, irank
+ integer :: istart, iend, local_index
+
+
+ parafile = DEF_ReservoirPara_file
+
+#ifndef MPAS_EMBEDDED_COLM
+ IF (p_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 (p_is_compute) 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)
+ IF (ucat2resv(local_index) == 0) THEN
+ numresv = numresv + 1
+ lake_type(local_index) = 2
+ ucat2resv(local_index) = numresv
+ resv_global_index(numresv) = i
+ ENDIF
+ 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 COLM_PARALLEL
+ IF (.not. allocated(resv_data_address)) allocate (resv_data_address (0:p_np_compute-1))
+
+ IF (p_is_root) THEN
+ DO irank = 0, p_np_compute-1
+
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ nresv = numresv
+ ELSE
+ CALL mpi_recv (nresv, 1, MPI_INTEGER, &
+ p_address_compute(irank), mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ ENDIF
+
+ IF (nresv > 0) THEN
+ allocate (resv_data_address(irank)%val (nresv))
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ resv_data_address(irank)%val = resv_global_index(1:nresv)
+ ELSE
+ CALL mpi_recv (resv_data_address(irank)%val, nresv, MPI_INTEGER, &
+ p_address_compute(irank), mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+
+ CALL mpi_send (numresv, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (numresv > 0) THEN
+ CALL mpi_send (resv_global_index(1:numresv), numresv, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_err)
+ 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 (p_is_compute) 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))
+
+ ENDIF
+
+ ENDIF
+
+#ifdef MPAS_EMBEDDED_COLM
+ IF (p_is_compute .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 (p_is_compute .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 (p_is_compute .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 (p_is_compute .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 (p_is_compute .and. (numresv > 0)) THEN
+ qresv_normal = rcache(resv_global_index(1:numresv))
+ ENDIF
+
+ CALL ncio_read_bcast_serial (parafile, 'dam_Qf', rcache)
+ IF (p_is_compute .and. (numresv > 0)) THEN
+ qresv_flood = rcache(resv_global_index(1:numresv))
+ ENDIF
+#endif
+
+
+ IF (p_is_compute) THEN
+ 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(rcache )) deallocate(rcache )
+ IF (allocated(icache )) deallocate(icache )
+
+ END SUBROUTINE reservoir_init
+
+
+ SUBROUTINE reservoir_operation (method, irsv, qin, vol, qout)
+
+ 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 (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 )
+
+ 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..790931e487
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeFlow.F90
@@ -0,0 +1,787 @@
+#include
+
+#ifdef GridRiverLakeFlow
+MODULE MOD_Grid_RiverLakeFlow
+!-------------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! River Lake flow.
+!
+!-------------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Grid_RiverLakeNetwork
+ USE MOD_Grid_RiverLakeTimeVars
+ USE MOD_Grid_Reservoir
+ USE MOD_Grid_RiverLakeHist
+#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
+
+ real(r8) :: acctime_rnof
+ real(r8), allocatable :: acc_rnof_uc (:)
+ logical, allocatable :: filter_rnof (:)
+
+CONTAINS
+
+ ! ---------
+ SUBROUTINE grid_riverlake_flow_init ()
+
+ USE MOD_LandPatch, only: numpatch
+ USE MOD_Forcing, only: forcmask_pch
+ USE MOD_Vars_TimeInvariants, only: patchtype, patchmask
+ IMPLICIT NONE
+
+ acctime_rnof_max = DEF_GRIDBASED_ROUTING_MAX_DT
+ acctime_rnof = 0.
+
+ IF (p_is_compute) THEN
+ ! Allocate on all ranks (zero-length if numucat/numpatch=0)
+ ! to avoid passing unallocated arrays to assumed-shape MPI wrappers.
+ allocate (acc_rnof_uc (numucat))
+ acc_rnof_uc = 0.
+ ENDIF
+
+ ! excluding (patchtype >= 99), virtual patches and those forcing missed
+ IF (p_is_compute) THEN
+ allocate (filter_rnof (numpatch))
+ IF (numpatch > 0) THEN
+ filter_rnof = patchtype < 99
+ filter_rnof = filter_rnof .and. patchmask
+ IF (DEF_forcing%has_missing_value) THEN
+ filter_rnof = filter_rnof .and. forcmask_pch
+ ENDIF
+ 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_Mesh, only: numelm
+ 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
+ IMPLICIT NONE
+
+ integer, intent(in) :: year
+ real(r8), intent(in) :: deltime
+
+ ! Local Variables
+ integer :: i, j, irsv, ntimestep
+ real(r8) :: dt_this
+ integer :: sed_clock_start, sed_clock_end, sed_clock_rate
+ real(r8) :: sed_elapsed
+
+ 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 :: 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, momen_fc, zsurf_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, floodarea
+ 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 (p_is_compute) THEN
+
+ allocate (rnof_gd (numinpm))
+ allocate (rnof_uc (numucat))
+
+ IF (numpatch > 0) THEN
+ 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
+ acc_rnof_uc = acc_rnof_uc + rnof_uc*1.e-3*deltime
+ 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 (acctime_rnof+0.01 < acctime_rnof_max) THEN
+ RETURN
+ ENDIF
+
+ IF (p_is_compute) 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 (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)))
+
+#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 (volresv(irsv) == 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 COLM_PARALLEL
+ IF (rivsys_by_multiple_procs) THEN
+ CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, p_comm_rivsys, p_err)
+ ENDIF
+#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
+
+ DO i = 1, numucat
+
+ ucatfilter(i) = dt_res(irivsys(i)) > 0._r8
+
+ IF (.not. ucatfilter(i)) CYCLE
+
+ sum_hflux_riv(i) = 0.
+ sum_mflux_riv(i) = 0.
+ sum_zgrad_riv(i) = 0.
+
+ ! 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
+
+ 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 ((veloc_riv(i) /= 0.) .or. (wdsrf_ucat(i) > 0.)) 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 COLM_PARALLEL
+ IF (rivsys_by_multiple_procs) THEN
+ CALL mpi_allreduce (MPI_IN_PLACE, dt_all, size(dt_all), MPI_REAL8, MPI_MIN, p_comm_rivsys, p_err)
+ ENDIF
+#endif
+
+ 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.)
+
+ ENDDO
+
+ DO i = 1, numucat
+ IF (ucatfilter(i)) THEN
+
+#ifdef CoLMDEBUG
+ IF (ucat_next(i) <= 0) THEN
+ totaldis = totaldis + hflux_fc(i)*dt_all(irivsys(i))
+ ENDIF
+#endif
+
+ IF (allocated(acctime_ucat) .and. allocated(a_wdsrf_ucat) .and. &
+ allocated(a_veloc_riv) .and. allocated(a_discharge) .and. &
+ allocated(a_floodarea)) THEN
+ acctime_ucat(i) = acctime_ucat(i) + dt_all(irivsys(i))
+
+ a_wdsrf_ucat(i) = a_wdsrf_ucat(i) + wdsrf_ucat(i) * dt_all(irivsys(i))
+ a_veloc_riv (i) = a_veloc_riv (i) + veloc_riv (i) * dt_all(irivsys(i))
+ a_discharge (i) = a_discharge (i) + hflux_fc (i) * dt_all(irivsys(i))
+
+ floodarea = floodplain_curve(i)%floodarea (wdsrf_ucat(i))
+ a_floodarea (i) = a_floodarea (i) + floodarea * dt_all(irivsys(i))
+
+ IF (is_built_resv(i) .and. allocated(acctime_resv) .and. &
+ allocated(a_volresv) .and. allocated(a_qresv_in) .and. &
+ allocated(a_qresv_out)) THEN
+ irsv = ucat2resv(i)
+ acctime_resv(irsv) = acctime_resv(irsv) + dt_all(irivsys(i))
+ a_volresv (irsv) = a_volresv (irsv) + volresv (irsv) * dt_all(irivsys(i))
+ a_qresv_in (irsv) = a_qresv_in (irsv) + qresv_in (irsv) * dt_all(irivsys(i))
+ a_qresv_out (irsv) = a_qresv_out(irsv) + qresv_out(irsv) * 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 COLM_PARALLEL
+ IF (rivsys_by_multiple_procs) THEN
+ CALL mpi_allreduce (MPI_IN_PLACE, global_dt_remaining, 1, MPI_REAL8, MPI_MAX, p_comm_rivsys, p_err)
+ ENDIF
+#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 COLM_PARALLEL
+ IF (.not. p_is_compute) ntimestep = 0
+ CALL mpi_allreduce (MPI_IN_PLACE, ntimestep, 1, MPI_INTEGER, MPI_MAX, p_comm_glb, p_err)
+
+ IF (.not. p_is_compute) totalvol_bef = 0.
+ IF (.not. p_is_compute) totalvol_aft = 0.
+ IF (.not. p_is_compute) totalrnof = 0.
+ IF (.not. p_is_compute) totaldis = 0.
+
+ CALL mpi_allreduce (MPI_IN_PLACE, totalvol_bef, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err)
+ CALL mpi_allreduce (MPI_IN_PLACE, totalvol_aft, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err)
+ CALL mpi_allreduce (MPI_IN_PLACE, totalrnof, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err)
+ CALL mpi_allreduce (MPI_IN_PLACE, totaldis, 1, MPI_REAL8, MPI_SUM, p_comm_glb, p_err)
+#endif
+ IF (p_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. p_is_compute) 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
+
+ acctime_rnof = 0.
+
+ IF (p_is_compute) 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(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(acc_rnof_uc)) deallocate(acc_rnof_uc)
+ 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_RiverLakeHist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90
new file mode 100644
index 0000000000..033dec6575
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeHist.F90
@@ -0,0 +1,756 @@
+#include
+
+#ifdef GridRiverLakeFlow
+MODULE MOD_Grid_RiverLakeHist
+!--------------------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Write out model results in lateral hydrological processes to history files.
+!
+! Created by Shupeng Zhang, May 2023
+!--------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_DataType
+#ifdef GridRiverLakeSediment
+ USE MOD_Grid_RiverLakeSediment, only: nsed, sed_hist_acctime, &
+ a_sedcon, a_sedout, a_bedout, a_sedinp, a_netflw, a_layer, a_shearvel
+#endif
+
+ ! -- ACC Fluxes --
+ real(r8), allocatable :: acctime_ucat (:)
+
+ real(r8), allocatable :: a_wdsrf_ucat (:)
+ real(r8), allocatable :: a_veloc_riv (:)
+ real(r8), allocatable :: a_discharge (:)
+ real(r8), allocatable :: a_floodarea (:) ! flooded area [m^2]
+
+ real(r8), allocatable :: a_wdsrf_ucat_pch (:)
+ real(r8), allocatable :: a_veloc_riv_pch (:)
+ real(r8), allocatable :: a_discharge_pch (:)
+ real(r8), allocatable :: a_dis_rmth_pch (:)
+ real(r8), allocatable :: a_floodfrc_pch (:) ! flooded area [m^2]
+
+ ! for reservoirs
+ real(r8), allocatable :: acctime_resv (:)
+
+ real(r8), allocatable :: a_volresv (:) ! reservoir water volume [m^3]
+ real(r8), allocatable :: a_qresv_in (:) ! inflow to reservoir [m^3/s]
+ real(r8), allocatable :: a_qresv_out (:) ! outflow from reservoir [m^3/s]
+
+ ! grid information
+ real(r8), allocatable :: lon_ucat (:)
+ real(r8), allocatable :: lat_ucat (:)
+
+ ! auxiliary data
+ type(block_data_real8_2d) :: sumarea_ucat ! 1) area covered by unit catchments
+ logical, allocatable :: filter_ucat (:)
+ real(r8), allocatable :: sum_grid_area (:) ! sum area of patches inside one grid
+
+ logical, allocatable :: filter_rivmth (:) ! 2) area covered by river mouths
+ real(r8), allocatable :: sum_rmth_area (:)
+
+ logical, allocatable :: filter_inpm (:) ! 3) area covered by input matrix
+ type(block_data_real8_2d) :: sumarea_inpm
+
+ type(block_data_real8_2d) :: allups_mask_grid ! 4) mask of unit catchments with all
+ real(r8), allocatable :: allups_mask_pch (:) ! upstreams in simulation region
+
+ ! -- PUBLIC SUBROUTINEs --
+ PUBLIC :: hist_grid_riverlake_init
+ PUBLIC :: hist_grid_riverlake_out
+ PUBLIC :: hist_grid_riverlake_final
+
+!--------------------------------------------------------------------------
+CONTAINS
+
+ !---------------------------------------
+ SUBROUTINE hist_grid_riverlake_init (histform)
+
+ USE MOD_Block
+ USE MOD_ComputePushData
+ USE MOD_HistGridded
+ USE MOD_Grid_RiverLakeNetwork
+ USE MOD_Grid_Reservoir, only: numresv
+ USE MOD_LandPatch, only: numpatch
+ USE MOD_Forcing, only: forcmask_pch
+ USE MOD_Vars_TimeInvariants, only: patchtype, patchmask
+
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: histform
+
+ ! Local Variables
+ logical, allocatable :: filter_basic(:)
+ real(r8), allocatable :: vec_ucat(:), vec_grid(:), vec_inpm(:), vec_patch(:)
+ integer :: ilon, iblkme, iblk, jblk
+
+
+ ! ----- allocate memory for accumulative variables -----
+ IF (p_is_compute) THEN
+
+ allocate (acctime_ucat (numucat))
+ allocate (a_wdsrf_ucat (numucat))
+ allocate (a_veloc_riv (numucat))
+ allocate (a_discharge (numucat))
+ allocate (a_floodarea (numucat))
+
+ allocate (a_wdsrf_ucat_pch (numpatch))
+ allocate (a_veloc_riv_pch (numpatch))
+ allocate (a_discharge_pch (numpatch))
+ allocate (a_dis_rmth_pch (numpatch))
+ allocate (a_floodfrc_pch (numpatch))
+
+ allocate (acctime_resv (numresv))
+ allocate (a_volresv (numresv))
+ allocate (a_qresv_in (numresv))
+ allocate (a_qresv_out (numresv))
+
+ ENDIF
+
+ CALL flush_acc_fluxes_riverlake ()
+
+ ! ----- get longitude and latitude -----
+ IF (p_is_root) THEN
+ allocate (lon_ucat (griducat%nlon))
+ allocate (lat_ucat (griducat%nlat))
+
+ lat_ucat = (griducat%lat_s + griducat%lat_n) * 0.5
+
+ DO ilon = 1, griducat%nlon
+ IF (griducat%lon_w(ilon) > griducat%lon_e(ilon)) THEN
+ lon_ucat(ilon) = (griducat%lon_w(ilon) + griducat%lon_e(ilon)+360.) * 0.5
+ CALL normalize_longitude (lon_ucat(ilon))
+ ELSE
+ lon_ucat(ilon) = (griducat%lon_w(ilon) + griducat%lon_e(ilon)) * 0.5
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ! ----- for auxiliary data -----
+ IF (p_is_compute) THEN
+ allocate (vec_ucat (numucat ))
+ allocate (vec_grid (numinpm ))
+ allocate (vec_inpm (numinpm ))
+ allocate (vec_patch (numpatch))
+
+ ! Patches excluding (type >= 99), virtual patches and thos forcing missed
+ allocate (filter_basic (numpatch))
+ IF (numpatch > 0) THEN
+ filter_basic = patchtype < 99
+ filter_basic = filter_basic .and. patchmask
+ IF (DEF_forcing%has_missing_value) THEN
+ filter_basic = filter_basic .and. forcmask_pch
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ! ----- 1) area and filter covered by unit catchments -----
+ IF (p_is_compute) THEN
+
+ IF (numucat > 0) vec_ucat = 1.
+
+ CALL compute_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval)
+ CALL compute_remap_data_grid2pset ( &
+ remap_patch2inpm, vec_grid, vec_patch, fillvalue = spval, mode = 'average')
+
+ allocate (filter_ucat (numpatch))
+ IF (numpatch > 0) THEN
+ filter_ucat = filter_basic .and. (vec_patch /= spval)
+
+ WHERE (filter_ucat)
+ vec_patch = 1
+ ELSE WHERE
+ vec_patch = spval
+ END WHERE
+ ENDIF
+
+ allocate (sum_grid_area (numinpm))
+ CALL compute_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, &
+ fillvalue = spval, filter = filter_ucat)
+ CALL compute_push_data (allreduce_inpm, vec_grid, sum_grid_area, fillvalue = spval)
+ ENDIF
+
+#ifndef MPAS_EMBEDDED_COLM
+ IF (trim(histform) == 'Gridded') THEN
+ IF (p_is_active) CALL allocate_block_data (ghist, sumarea_ucat)
+ CALL mp2g_hist%get_sumarea (sumarea_ucat, filter_ucat)
+ ENDIF
+#endif
+
+ ! ----- 2) area and filter covered by river mouth -----
+ IF (p_is_compute) THEN
+ IF (numucat > 0) THEN
+ WHERE (ucat_next == -9)
+ vec_ucat = 1.
+ ELSE WHERE
+ vec_ucat = spval
+ END WHERE
+ ENDIF
+
+ CALL compute_push_data (push_ucat2grid, vec_ucat, vec_grid, fillvalue = spval)
+ CALL compute_remap_data_grid2pset (remap_patch2inpm, vec_grid, vec_patch, &
+ fillvalue = spval, mode = 'average')
+
+ allocate (filter_rivmth (numpatch))
+ IF (numpatch > 0) THEN
+ filter_rivmth = filter_ucat .and. (vec_patch /= spval)
+
+ WHERE (filter_rivmth)
+ vec_patch = 1
+ ELSE WHERE
+ vec_patch = spval
+ END WHERE
+ ENDIF
+
+ allocate (sum_rmth_area (numinpm))
+
+ CALL compute_remap_data_pset2grid (remap_patch2inpm, vec_patch, vec_grid, &
+ fillvalue = spval, filter = filter_rivmth)
+ CALL compute_push_data (allreduce_inpm, vec_grid, sum_rmth_area, fillvalue = spval)
+ ENDIF
+
+ ! ----- 3) area covered by input matrix -----
+ IF (p_is_compute) THEN
+ IF (numucat > 0) vec_ucat = 1.
+ CALL compute_push_data (push_ucat2inpm, vec_ucat, vec_inpm, &
+ fillvalue = spval, mode = 'average')
+ CALL compute_remap_data_grid2pset (remap_patch2inpm, vec_inpm, vec_patch, &
+ fillvalue = spval, mode = 'average')
+
+ allocate (filter_inpm (numpatch))
+ IF (numpatch > 0) THEN
+ filter_inpm = filter_basic .and. (vec_patch /= spval)
+ ENDIF
+ ENDIF
+
+#ifndef MPAS_EMBEDDED_COLM
+ IF (trim(histform) == 'Gridded') THEN
+ IF (p_is_active) CALL allocate_block_data (ghist, sumarea_inpm)
+ CALL mp2g_hist%get_sumarea (sumarea_inpm, filter_inpm)
+ ENDIF
+#endif
+
+ ! ----- 4) mask of unit catchments with all upstreams in simulation region -----
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ allocate (allups_mask_pch (numpatch))
+ ENDIF
+ ENDIF
+
+ IF (p_is_compute) THEN
+ CALL compute_push_data (push_ucat2grid, allups_mask_ucat, vec_grid, fillvalue = spval)
+ CALL compute_remap_data_grid2pset ( &
+ remap_patch2inpm, vec_grid, allups_mask_pch, fillvalue = spval, mode = 'average')
+ ENDIF
+
+#ifndef MPAS_EMBEDDED_COLM
+ IF (trim(histform) == 'Gridded') THEN
+
+ IF (p_is_active) CALL allocate_block_data (ghist, allups_mask_grid)
+
+ CALL mp2g_hist%pset2grid (allups_mask_pch, allups_mask_grid, spv = spval, msk = filter_ucat)
+
+ IF (p_is_active) THEN
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+ WHERE (sumarea_ucat%blk(iblk,jblk)%val > 0.)
+ allups_mask_grid%blk(iblk,jblk)%val = &
+ allups_mask_grid%blk(iblk,jblk)%val / sumarea_ucat%blk(iblk,jblk)%val
+ ELSE WHERE
+ allups_mask_grid%blk(iblk,jblk)%val = spval
+ END WHERE
+ ENDDO
+ ENDIF
+
+ ENDIF
+#endif
+
+ IF (allocated (vec_ucat )) deallocate (vec_ucat )
+ IF (allocated (vec_grid )) deallocate (vec_grid )
+ IF (allocated (vec_inpm )) deallocate (vec_inpm )
+ IF (allocated (vec_patch )) deallocate (vec_patch )
+ IF (allocated (filter_basic)) deallocate (filter_basic)
+
+ END SUBROUTINE hist_grid_riverlake_init
+
+ !---------------------------------------
+ SUBROUTINE hist_grid_riverlake_out (file_hist, histform, idate, itime_in_file, is_first_in_file)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_NetCDFSerial
+ USE MOD_ComputePushData
+ USE MOD_Grid_RiverLakeNetwork
+ USE MOD_Grid_Reservoir
+ USE MOD_Vector_ReadWrite
+ USE MOD_HistGridded
+#ifdef UNSTRUCTURED
+ USE MOD_HistVector
+#endif
+ USE MOD_LandPatch, only: numpatch
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: histform
+ integer, intent(in) :: idate(3)
+ integer, intent(in) :: itime_in_file
+ logical, intent(in) :: is_first_in_file
+
+ ! Local variables
+ character(len=256) :: file_hist_ucat
+ logical :: fexists
+ integer :: itime_in_file_ucat, i
+
+ real(r8), allocatable :: acc_vec_grid (:)
+ real(r8), allocatable :: a_floodfrc_ucat (:) ! flooded area fraction
+ real(r8), allocatable :: a_floodfrc_inpm (:) ! flooded area fraction
+
+
+ IF (p_is_root) THEN
+ i = len_trim (file_hist)
+ DO WHILE (file_hist(i:i) /= '_')
+ i = i - 1
+ ENDDO
+ file_hist_ucat = file_hist(1:i) // 'unitcat_' // file_hist(i+1:)
+
+ inquire (file=file_hist_ucat, exist=fexists)
+ IF (.not. fexists) THEN
+
+ CALL ncio_create_file (trim(file_hist_ucat))
+
+ CALL ncio_define_dimension (file_hist_ucat, 'time', 0)
+ CALL ncio_define_dimension (file_hist_ucat, 'lat_ucat', griducat%nlat)
+ CALL ncio_define_dimension (file_hist_ucat, 'lon_ucat', griducat%nlon)
+
+ CALL ncio_write_serial (file_hist_ucat, 'lat_ucat', lat_ucat, 'lat_ucat')
+ CALL ncio_write_serial (file_hist_ucat, 'lon_ucat', lon_ucat, 'lon_ucat')
+ ENDIF
+
+ CALL ncio_write_time (file_hist_ucat, 'time', idate, itime_in_file_ucat, DEF_HIST_FREQ)
+
+ ENDIF
+
+ IF (is_first_in_file) THEN
+ IF (trim(histform) == 'Gridded') THEN
+ CALL hist_write_var_real8_2d ( &
+ file_hist, 'mask_complete_upstream_regird', ghist, -1, allups_mask_grid, compress = 1, &
+ longname = 'Mask of grids with all upstream located in simulation region', units = '100%')
+#ifdef UNSTRUCTURED
+ ELSE
+ CALL aggregate_to_vector_and_write_2d ( &
+ allups_mask_pch, file_hist, 'mask_complete_upstream_regird', -1, filter_ucat, &
+ longname = 'Mask of grids with all upstream located in simulation region', units = '100%')
+#endif
+ ENDIF
+
+ CALL vector_gather_map2grid_and_write ( &
+ allups_mask_ucat, numucat, totalnumucat, ucat_data_address, griducat%nlon, x_ucat, &
+ griducat%nlat, y_ucat, file_hist_ucat, 'mask_complete_upstream', 'lon_ucat', 'lat_ucat', &
+ longname = 'Mask of grids with all upstream located in simulation region', units = '100%')
+ ENDIF
+
+ IF (p_is_compute) THEN
+ allocate (acc_vec_grid (numinpm ))
+ ENDIF
+
+ IF (DEF_hist_vars%riv_height) THEN
+ IF (p_is_compute) THEN
+ IF (numucat > 0) a_wdsrf_ucat = a_wdsrf_ucat / acctime_ucat
+ CALL compute_push_data (push_ucat2grid, a_wdsrf_ucat, acc_vec_grid, fillvalue = spval)
+ CALL compute_remap_data_grid2pset ( remap_patch2inpm, acc_vec_grid, a_wdsrf_ucat_pch, &
+ fillvalue = spval, mode = 'average')
+ ENDIF
+
+ CALL vector_gather_map2grid_and_write ( a_wdsrf_ucat, numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_wdpth_ucat', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'deepest water depth in river and flood plain', 'm')
+ ENDIF
+
+ IF (DEF_hist_vars%riv_veloct) THEN
+ IF (p_is_compute) THEN
+ IF (numucat > 0) a_veloc_riv = a_veloc_riv / acctime_ucat
+ CALL compute_push_data (push_ucat2grid, a_veloc_riv, acc_vec_grid, fillvalue = spval)
+ CALL compute_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_veloc_riv_pch, &
+ fillvalue = spval, mode = 'average')
+ ENDIF
+
+ CALL vector_gather_map2grid_and_write ( a_veloc_riv, numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_veloc_riv', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'water velocity in river', 'm/s')
+ ENDIF
+
+ IF (DEF_hist_vars%discharge) THEN
+ IF (p_is_compute) THEN
+ IF (numucat > 0) a_discharge = a_discharge / acctime_ucat
+ CALL compute_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval)
+
+ IF (numinpm > 0) THEN
+ WHERE ((sum_grid_area /= spval) .and. (acc_vec_grid /= spval))
+ acc_vec_grid = acc_vec_grid / sum_grid_area
+ ELSE WHERE
+ acc_vec_grid = spval
+ END WHERE
+ ENDIF
+
+ CALL compute_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_discharge_pch, &
+ fillvalue = spval, mode = 'sum')
+ ENDIF
+
+ CALL vector_gather_map2grid_and_write ( a_discharge, numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_discharge', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'discharge in river and flood plain', 'm^3/s')
+
+ IF (p_is_compute) THEN
+ IF (numucat > 0) THEN
+ WHERE (ucat_next /= -9) a_discharge = spval
+ ENDIF
+ CALL compute_push_data (push_ucat2grid, a_discharge, acc_vec_grid, fillvalue = spval)
+
+ IF (numinpm > 0) THEN
+ WHERE ((sum_rmth_area /= spval) .and. (acc_vec_grid /= spval))
+ acc_vec_grid = acc_vec_grid / sum_rmth_area
+ ELSE WHERE
+ acc_vec_grid = spval
+ END WHERE
+ ENDIF
+
+ CALL compute_remap_data_grid2pset (remap_patch2inpm, acc_vec_grid, a_dis_rmth_pch, &
+ fillvalue = spval, mode = 'sum')
+ ENDIF
+
+ CALL vector_gather_map2grid_and_write ( a_discharge, numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_discharge_rivermouth', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'river mouth discharge into ocean', 'm^3/s')
+ ENDIF
+
+ IF (DEF_hist_vars%floodfrc) THEN
+
+ IF (p_is_compute) THEN
+
+ IF (numucat > 0) a_floodarea = a_floodarea / acctime_ucat
+
+ allocate (a_floodfrc_ucat (numucat))
+ IF (numucat > 0) THEN
+ WHERE (topo_area > 0)
+ a_floodfrc_ucat = a_floodarea / topo_area
+ ELSE WHERE
+ a_floodfrc_ucat = spval
+ END WHERE
+ ENDIF
+
+ allocate (a_floodfrc_inpm (numinpm))
+
+ CALL compute_push_data (push_ucat2inpm, a_floodfrc_ucat, a_floodfrc_inpm, &
+ fillvalue = spval, mode = 'average')
+
+ CALL compute_remap_data_grid2pset (remap_patch2inpm, a_floodfrc_inpm, a_floodfrc_pch, &
+ fillvalue = spval, mode = 'average')
+ ENDIF
+
+ ENDIF
+
+
+ IF (allocated (a_floodfrc_ucat)) deallocate (a_floodfrc_ucat)
+ IF (allocated (a_floodfrc_inpm)) deallocate (a_floodfrc_inpm)
+ IF (allocated (acc_vec_grid )) deallocate (acc_vec_grid )
+
+#ifdef GridRiverLakeSediment
+ CALL write_sediment_history (file_hist_ucat, itime_in_file_ucat)
+#endif
+
+ ! ----- reservoir variables -----
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (totalnumresv > 0) THEN
+
+ IF (p_is_root) THEN
+ IF (.not. fexists) THEN
+ CALL ncio_define_dimension(file_hist_ucat, 'reservoir', totalnumresv)
+ CALL ncio_write_serial (file_hist_ucat, 'resv_GRAND_ID' , dam_GRAND_ID, 'reservoir')
+ CALL ncio_put_attr (file_hist_ucat, 'resv_GRAND_ID', 'long_name', 'reservoir GRAND ID')
+ ENDIF
+ ENDIF
+
+ IF (DEF_hist_vars%volresv) THEN
+ IF (p_is_compute) THEN
+ IF (numresv > 0) THEN
+ WHERE (acctime_resv > 0)
+ a_volresv = a_volresv / acctime_resv
+ ELSEWHERE
+ a_volresv = spval
+ END WHERE
+ ENDIF
+ ENDIF
+
+ CALL vector_gather_and_write ( a_volresv, numresv, totalnumresv, resv_data_address, &
+ file_hist_ucat, 'volresv', 'reservoir', itime_in_file_ucat, 'reservoir water volume', 'm^3')
+ ENDIF
+
+ IF (DEF_hist_vars%qresv_in) THEN
+ IF (p_is_compute) THEN
+ IF (numresv > 0) THEN
+ WHERE (acctime_resv > 0)
+ a_qresv_in = a_qresv_in / acctime_resv
+ ELSEWHERE
+ a_qresv_in = spval
+ END WHERE
+ ENDIF
+ ENDIF
+
+ CALL vector_gather_and_write ( a_qresv_in, numresv, totalnumresv, resv_data_address, &
+ file_hist_ucat, 'qresv_in', 'reservoir', itime_in_file_ucat, 'reservoir inflow', 'm^3/s')
+ ENDIF
+
+ IF (DEF_hist_vars%qresv_out) THEN
+ IF (p_is_compute) THEN
+ IF (numresv > 0) THEN
+ WHERE (acctime_resv > 0)
+ a_qresv_out = a_qresv_out / acctime_resv
+ ELSEWHERE
+ a_qresv_out = spval
+ END WHERE
+ ENDIF
+ ENDIF
+
+ CALL vector_gather_and_write ( a_qresv_out, numresv, totalnumresv, resv_data_address, &
+ file_hist_ucat, 'qresv_out', 'reservoir', itime_in_file_ucat, 'reservoir outflow', 'm^3/s')
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ CALL flush_acc_fluxes_riverlake ()
+
+ END SUBROUTINE hist_grid_riverlake_out
+
+ !-----------------------
+ SUBROUTINE flush_acc_fluxes_riverlake ()
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Grid_RiverLakeNetwork, only: numucat
+ USE MOD_Grid_Reservoir, only: numresv
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+
+ IF (numucat > 0) THEN
+ acctime_ucat (:) = 0.
+ a_wdsrf_ucat (:) = 0.
+ a_veloc_riv (:) = 0.
+ a_discharge (:) = 0.
+ a_floodarea (:) = 0.
+ ENDIF
+
+ IF (numresv > 0) THEN
+ acctime_resv (:) = 0.
+ a_volresv (:) = 0.
+ a_qresv_in (:) = 0.
+ a_qresv_out (:) = 0.
+ ENDIF
+
+#ifdef GridRiverLakeSediment
+ IF (DEF_USE_SEDIMENT .and. allocated(a_sedcon)) THEN
+ a_sedcon = 0.
+ a_sedout = 0.
+ a_bedout = 0.
+ a_sedinp = 0.
+ a_netflw = 0.
+ a_layer = 0.
+ a_shearvel = 0.
+ sed_hist_acctime = 0.
+ ENDIF
+#endif
+
+ ENDIF
+
+ END SUBROUTINE flush_acc_fluxes_riverlake
+
+ !---------------------------------------
+ SUBROUTINE hist_grid_riverlake_final ()
+
+ IMPLICIT NONE
+
+ IF (allocated(acctime_ucat )) deallocate (acctime_ucat )
+ IF (allocated(a_wdsrf_ucat )) deallocate (a_wdsrf_ucat )
+ IF (allocated(a_veloc_riv )) deallocate (a_veloc_riv )
+ IF (allocated(a_discharge )) deallocate (a_discharge )
+ IF (allocated(a_floodarea )) deallocate (a_floodarea )
+
+ IF (allocated(a_wdsrf_ucat_pch)) deallocate (a_wdsrf_ucat_pch)
+ IF (allocated(a_veloc_riv_pch )) deallocate (a_veloc_riv_pch )
+ IF (allocated(a_discharge_pch )) deallocate (a_discharge_pch )
+ IF (allocated(a_dis_rmth_pch )) deallocate (a_dis_rmth_pch )
+ IF (allocated(a_floodfrc_pch )) deallocate (a_floodfrc_pch )
+
+ IF (allocated(acctime_resv )) deallocate (acctime_resv )
+ IF (allocated(a_volresv )) deallocate (a_volresv )
+ IF (allocated(a_qresv_in )) deallocate (a_qresv_in )
+ IF (allocated(a_qresv_out )) deallocate (a_qresv_out )
+
+ IF (allocated(lon_ucat )) deallocate (lon_ucat )
+ IF (allocated(lat_ucat )) deallocate (lat_ucat )
+
+ IF (allocated(filter_ucat )) deallocate (filter_ucat )
+ IF (allocated(sum_grid_area )) deallocate (sum_grid_area )
+ IF (allocated(filter_rivmth )) deallocate (filter_rivmth )
+ IF (allocated(sum_rmth_area )) deallocate (sum_rmth_area )
+ IF (allocated(filter_inpm )) deallocate (filter_inpm )
+
+ IF (allocated(allups_mask_pch )) deallocate (allups_mask_pch )
+
+ END SUBROUTINE hist_grid_riverlake_final
+
+#ifdef GridRiverLakeSediment
+ !---------------------------------------
+ SUBROUTINE write_sediment_history (file_hist_ucat, itime_in_file_ucat)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_data_address, &
+ x_ucat, y_ucat, griducat
+ USE MOD_Vector_ReadWrite
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: file_hist_ucat
+ integer, intent(in) :: itime_in_file_ucat
+
+ real(r8), allocatable :: a_sedcon_avg(:,:)
+ real(r8), allocatable :: a_sedout_avg(:,:)
+ real(r8), allocatable :: a_bedout_avg(:,:)
+ real(r8), allocatable :: a_sedinp_avg(:,:)
+ real(r8), allocatable :: a_netflw_avg(:,:)
+ real(r8), allocatable :: a_layer_avg(:,:)
+ real(r8), allocatable :: a_shearvel_avg(:)
+ integer :: ised
+ character(len=16) :: cised
+
+ IF (.not. DEF_USE_SEDIMENT) RETURN
+
+ ! Allocate on ALL processes (zero-size on non-ranks) to avoid
+ ! passing unallocated arrays to vector_gather_map2grid_and_write
+ IF (p_is_compute .and. numucat > 0) THEN
+ allocate (a_sedcon_avg (nsed, numucat))
+ allocate (a_sedout_avg (nsed, numucat))
+ allocate (a_bedout_avg (nsed, numucat))
+ allocate (a_sedinp_avg (nsed, numucat))
+ allocate (a_netflw_avg (nsed, numucat))
+ allocate (a_layer_avg (nsed, numucat))
+ allocate (a_shearvel_avg(numucat))
+
+ IF (sed_hist_acctime > 0._r8) THEN
+ a_shearvel_avg = a_shearvel / sed_hist_acctime
+ DO ised = 1, nsed
+ a_sedcon_avg(ised,:) = a_sedcon(ised,:) / sed_hist_acctime
+ a_sedout_avg(ised,:) = a_sedout(ised,:) / sed_hist_acctime
+ a_bedout_avg(ised,:) = a_bedout(ised,:) / sed_hist_acctime
+ a_sedinp_avg(ised,:) = a_sedinp(ised,:) / sed_hist_acctime
+ a_netflw_avg(ised,:) = a_netflw(ised,:) / sed_hist_acctime
+ a_layer_avg(ised,:) = a_layer(ised,:) / sed_hist_acctime
+ ENDDO
+ ELSE
+ a_shearvel_avg = 0.
+ a_sedcon_avg = 0.
+ a_sedout_avg = 0.
+ a_bedout_avg = 0.
+ a_sedinp_avg = 0.
+ a_netflw_avg = 0.
+ a_layer_avg = 0.
+ ENDIF
+ ELSE
+ ! Allocate with nsed in first dim so a_xxx_avg(ised,:) is a valid zero-length slice
+ allocate (a_sedcon_avg (nsed, 0))
+ allocate (a_sedout_avg (nsed, 0))
+ allocate (a_bedout_avg (nsed, 0))
+ allocate (a_sedinp_avg (nsed, 0))
+ allocate (a_netflw_avg (nsed, 0))
+ allocate (a_layer_avg (nsed, 0))
+ allocate (a_shearvel_avg(0))
+ ENDIF
+
+ IF (DEF_hist_vars%sedcon) THEN
+ DO ised = 1, nsed
+ WRITE(cised, '(I0)') ised
+ CALL vector_gather_map2grid_and_write ( a_sedcon_avg(ised,:), numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_sedcon_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'suspended sediment concentration, size class ' // trim(cised), 'm^3/m^3')
+ ENDDO
+ ENDIF
+
+ IF (DEF_hist_vars%sedout) THEN
+ DO ised = 1, nsed
+ WRITE(cised, '(I0)') ised
+ CALL vector_gather_map2grid_and_write ( a_sedout_avg(ised,:), numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_sedout_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'suspended sediment flux, size class ' // trim(cised), 'm^3/s')
+ ENDDO
+ ENDIF
+
+ IF (DEF_hist_vars%bedout) THEN
+ DO ised = 1, nsed
+ WRITE(cised, '(I0)') ised
+ CALL vector_gather_map2grid_and_write ( a_bedout_avg(ised,:), numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_bedout_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'bedload flux, size class ' // trim(cised), 'm^3/s')
+ ENDDO
+ ENDIF
+
+ IF (DEF_hist_vars%sedinp) THEN
+ DO ised = 1, nsed
+ WRITE(cised, '(I0)') ised
+ CALL vector_gather_map2grid_and_write ( a_sedinp_avg(ised,:), numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_sedinp_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'sediment erosion input, size class ' // trim(cised), 'm^3/s')
+ ENDDO
+ ENDIF
+
+ IF (DEF_hist_vars%netflw) THEN
+ DO ised = 1, nsed
+ WRITE(cised, '(I0)') ised
+ CALL vector_gather_map2grid_and_write ( a_netflw_avg(ised,:), numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_netflw_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'net bed-water exchange flux (incl. shallow deposit), size class ' // trim(cised), 'm^3/s')
+ ENDDO
+ ENDIF
+
+ IF (DEF_hist_vars%sedlayer) THEN
+ DO ised = 1, nsed
+ WRITE(cised, '(I0)') ised
+ CALL vector_gather_map2grid_and_write ( a_layer_avg(ised,:), numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_layer_' // trim(cised), 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'active layer storage, size class ' // trim(cised), 'm^3')
+ ENDDO
+ ENDIF
+
+ IF (DEF_hist_vars%shearvel) THEN
+ CALL vector_gather_map2grid_and_write ( a_shearvel_avg, numucat, &
+ totalnumucat, ucat_data_address, griducat%nlon, x_ucat, griducat%nlat, y_ucat, &
+ file_hist_ucat, 'f_shearvel', 'lon_ucat', 'lat_ucat', itime_in_file_ucat, &
+ 'shear velocity', 'm/s')
+ ENDIF
+
+ IF (allocated(a_sedcon_avg )) deallocate (a_sedcon_avg )
+ IF (allocated(a_sedout_avg )) deallocate (a_sedout_avg )
+ IF (allocated(a_bedout_avg )) deallocate (a_bedout_avg )
+ IF (allocated(a_sedinp_avg )) deallocate (a_sedinp_avg )
+ IF (allocated(a_netflw_avg )) deallocate (a_netflw_avg )
+ IF (allocated(a_layer_avg )) deallocate (a_layer_avg )
+ IF (allocated(a_shearvel_avg)) deallocate (a_shearvel_avg)
+
+ END SUBROUTINE write_sediment_history
+#endif
+
+END MODULE MOD_Grid_RiverLakeHist
+#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..b3d21e2243
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeNetwork.F90
@@ -0,0 +1,2220 @@
+#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
+ integer :: numucat
+ integer, allocatable :: ucat_ucid (:) ! index in unit catchment numbering
+ integer, allocatable :: x_ucat (:) !
+ integer, allocatable :: y_ucat (:) !
+ integer, allocatable :: ucat_gdid (:) !
+
+ integer, allocatable :: numucat_rank (:)
+ type(pointer_int32_1d), allocatable :: ucat_data_address (:)
+
+ ! ----- Part 1: between runoff input elements and unit catchments -----
+ integer :: numinpm
+ integer, allocatable :: inpm_gdid (:)
+
+ integer :: inpn
+ integer, allocatable :: idmap_gd2uc (:,:)
+ real(r8), allocatable :: area_gd2uc (:,:)
+
+ integer :: nucpart
+ 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
+ type(compute_pushdata_type) :: push_ucat2grid
+ type(compute_pushdata_type) :: allreduce_inpm
+
+ ! ----- Part 2: between upstream and downstream unit catchments -----
+ integer, allocatable :: ucat_next (:) ! next unit catchment
+ integer :: upnmax
+ 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
+ logical :: rivsys_by_multiple_procs
+ integer, allocatable :: irivsys (:)
+#ifdef COLM_PARALLEL
+ integer :: p_comm_rivsys
+#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 (:)
+
+
+ ! ----- Mask of Grids with all upstream area in the simulation region -----
+ real(r8), allocatable :: allups_mask_ucat (:)
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE build_riverlake_network ()
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_NetCDFSerial
+ USE MOD_Mesh
+ USE MOD_Utils
+ USE MOD_LandPatch
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ ! Local Variables
+ character(len=256) :: parafile
+
+ integer, allocatable :: idmap_x(:,:), idmap_y(:,:)
+ integer, allocatable :: varsize(:)
+
+ integer :: numrivmth
+ integer, allocatable :: rivermouth(:)
+
+ integer, allocatable :: nups_nst (:), iups_nst (:), nups_all(:)
+ integer, allocatable :: ucat_next_all(:)
+ integer, allocatable :: uc_up2down(:), order_ucat(:)
+ integer, allocatable :: addr_ucat (:)
+
+ integer , allocatable :: nuc_rs(:), irank_rs(:), nrank_rs(:), nave_rs(:)
+ real(r8), allocatable :: wt_uc (:), wt_rs (:), wt_rank (:), nuc_rank(:)
+
+ integer, allocatable :: grdindex(:)
+
+
+ integer, allocatable :: idata1d(:), idata2d(:,:)
+ real(r8), allocatable :: rdata1d(:), rdata2d(:,:)
+
+ integer, allocatable :: allgrd_in_inp (:), nucat_g2d(:,:), iucat_g(:)
+
+ integer, allocatable :: idmap_uc2gd_all(:,:)
+ real(r8), allocatable :: area_uc2gd_all (:,:)
+
+ real(r8), allocatable :: ucat_area_all (:)
+
+ integer :: nlat_ucat, nlon_ucat
+ integer :: nucat, iriv, ngrdall, igrd, ngrd
+ integer :: p_np_rivsys, color
+ integer :: irank, irankdsp, self_rank
+ integer :: iloc, i, j, ithis
+ real(r8) :: sumwt
+ logical :: is_new
+
+
+#ifdef COLM_PARALLEL
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+#ifdef MPAS_EMBEDDED_COLM
+ CALL build_riverlake_network_mpas_embedded()
+ RETURN
+#endif
+
+ ! read in parameters from file.
+ parafile = DEF_UnitCatchment_file
+ IF (p_is_root) THEN
+
+#ifdef MPAS_EMBEDDED_COLM
+ CALL ncio_inquire_length (parafile, 'seq_next', totalnumucat)
+#else
+ CALL ncio_read_serial (parafile, 'seq_x', x_ucat)
+ CALL ncio_read_serial (parafile, 'seq_y', y_ucat)
+ totalnumucat = size(x_ucat)
+#endif
+
+ CALL ncio_read_serial (parafile, 'seq_next', ucat_next)
+
+ CALL ncio_inquire_length (parafile, 'lon', nlon_ucat)
+ CALL ncio_inquire_length (parafile, 'lat', nlat_ucat)
+
+#ifndef MPAS_EMBEDDED_COLM
+ CALL ncio_read_serial (parafile, 'inpmat_x', idmap_x)
+ CALL ncio_read_serial (parafile, 'inpmat_y', idmap_y)
+ CALL ncio_read_serial (parafile, 'inpmat_area', area_gd2uc)
+#endif
+
+ ENDIF
+
+ IF (p_is_root) THEN
+
+ allocate (nups_nst (totalnumucat))
+ allocate (iups_nst (totalnumucat))
+
+ nups_nst(:) = 0
+ DO i = 1, totalnumucat
+ j = ucat_next(i)
+ IF (j > 0) THEN
+ nups_nst(j) = nups_nst(j) + 1
+ ENDIF
+ ENDDO
+
+ ! sort unit catchment from upstream to downstream, recorded by "uc_up2down"
+ allocate (uc_up2down (totalnumucat))
+
+ ithis = 0
+ iups_nst(:) = 0
+ DO i = 1, totalnumucat
+ IF (iups_nst(i) == nups_nst(i)) THEN
+
+ ithis = ithis + 1
+ uc_up2down(ithis) = i
+ iups_nst(i) = -1
+
+ j = ucat_next(i)
+ DO WHILE (j > 0)
+
+ iups_nst(j) = iups_nst(j) + 1
+
+ IF (iups_nst(j) == nups_nst(j)) THEN
+ ithis = ithis + 1
+ uc_up2down(ithis) = j
+ iups_nst(j) = -1
+
+ j = ucat_next(j)
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+#ifdef COLM_PARALLEL
+ ! divide unit catchments into groups and assign to ranks
+ IF (p_is_root) THEN
+
+ allocate (wt_uc (totalnumucat)); wt_uc(:) = 1.
+
+ allocate (rivermouth (totalnumucat))
+ numrivmth = 0
+ DO i = totalnumucat, 1, -1
+ j = ucat_next(uc_up2down(i))
+ IF (j <= 0) THEN
+ numrivmth = numrivmth + 1
+ rivermouth(uc_up2down(i)) = numrivmth
+ ELSE
+ rivermouth(uc_up2down(i)) = rivermouth(j)
+ ENDIF
+ ENDDO
+
+ allocate (nuc_rs (numrivmth)); nuc_rs(:) = 0
+ allocate (wt_rs (numrivmth)); wt_rs (:) = 0.
+ DO i = 1, totalnumucat
+ nuc_rs(rivermouth(i)) = nuc_rs(rivermouth(i)) + 1
+ wt_rs (rivermouth(i)) = wt_rs (rivermouth(i)) + wt_uc(i)
+ ENDDO
+
+ sumwt = sum(wt_rs)
+
+ allocate (irank_rs (numrivmth))
+ allocate (nrank_rs (numrivmth))
+ allocate (nave_rs (numrivmth))
+
+ irankdsp = -1
+ DO i = 1, numrivmth
+ nrank_rs(i) = floor(wt_rs(i)/sumwt * p_np_compute)
+ IF (nrank_rs(i) > 1) THEN
+
+ nave_rs(i) = nuc_rs(i) / nrank_rs(i)
+ IF (mod(nuc_rs(i), nrank_rs(i)) /= 0) THEN
+ nave_rs(i) = nave_rs(i) + 1
+ ENDIF
+
+ irank_rs(i) = irankdsp + 1
+ irankdsp = irankdsp + nrank_rs(i)
+ ENDIF
+ ENDDO
+
+ allocate (nups_all (totalnumucat)); nups_all(:) = 1
+
+ DO i = 1, totalnumucat
+ j = ucat_next(uc_up2down(i))
+ IF (j > 0) THEN
+ nups_all(j) = nups_all(j) + nups_all(uc_up2down(i))
+ ENDIF
+ ENDDO
+
+ allocate (addr_ucat (totalnumucat)); addr_ucat(:) = -1
+
+ allocate (wt_rank (0:p_np_compute-1)); wt_rank (:) = 0
+ allocate (nuc_rank(0:p_np_compute-1)); nuc_rank(:) = 0
+
+ allocate (order_ucat (totalnumucat))
+ order_ucat(uc_up2down) = (/(i, i = 1, totalnumucat)/)
+
+ ithis = totalnumucat
+ DO WHILE (ithis > 0)
+
+ i = uc_up2down(ithis)
+
+ IF (addr_ucat(i) >= 0) THEN
+ ithis = ithis - 1
+ CYCLE
+ ENDIF
+
+ j = ucat_next(i)
+ IF (j > 0) THEN
+ IF (addr_ucat(j) >= 0) THEN
+ addr_ucat(i) = addr_ucat(j)
+ ithis = ithis - 1
+ CYCLE
+ ENDIF
+ ENDIF
+
+ iriv = rivermouth(i)
+ IF (nrank_rs(iriv) > 1) THEN
+ irank = irank_rs(iriv)
+ IF (nups_all(i) <= nave_rs(iriv)-nuc_rank(irank)) THEN
+
+ addr_ucat(i) = p_address_compute(irank)
+
+ nuc_rank(irank) = nuc_rank(irank) + nups_all(i)
+ IF (nuc_rank(irank) == nave_rs(iriv)) THEN
+ irank_rs(iriv) = irank_rs(iriv) + 1
+ ENDIF
+
+ j = ucat_next(i)
+ IF (j > 0) THEN
+ DO WHILE (j > 0)
+ nups_all(j) = nups_all(j) - nups_all(i)
+ ithis = order_ucat(j)
+ j = ucat_next(j)
+ ENDDO
+ ELSE
+ ithis = ithis - 1
+ ENDIF
+ ELSE
+ ithis = ithis - 1
+ ENDIF
+ ELSE
+ irank = minloc(wt_rank(irankdsp+1:p_np_compute-1), dim=1) + irankdsp
+
+ addr_ucat(i) = p_address_compute(irank)
+
+ wt_rank(irank) = wt_rank(irank) + wt_rs(iriv)
+ ithis = ithis - 1
+ ENDIF
+
+ ENDDO
+
+ deallocate (order_ucat)
+ deallocate (nups_all )
+ deallocate (nuc_rs )
+ deallocate (irank_rs )
+ deallocate (nrank_rs )
+ deallocate (nave_rs )
+ deallocate (wt_uc )
+ deallocate (wt_rs )
+ deallocate (wt_rank )
+ deallocate (nuc_rank )
+
+ ENDIF
+
+ IF (p_is_root) THEN
+
+ allocate(ucat_ucid (totalnumucat))
+ ucat_ucid = (/(i, i = 1, totalnumucat)/)
+
+ allocate (numucat_rank (0:p_np_compute-1))
+ allocate (ucat_data_address (0:p_np_compute-1))
+
+ DO irank = 0, p_np_compute-1
+ nucat = count(addr_ucat == p_address_compute(irank))
+ numucat_rank(irank) = nucat
+ IF (nucat > 0) THEN
+ allocate (ucat_data_address(irank)%val (nucat))
+ ucat_data_address(irank)%val = &
+ pack(ucat_ucid, mask = (addr_ucat == p_address_compute(irank)))
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ CALL mpi_bcast (totalnumucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+
+ ! send unit catchment index to ranks
+ IF (p_is_root) THEN
+
+ self_rank = -1
+
+ DO irank = 0, p_np_compute-1
+
+ nucat = numucat_rank(irank)
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ numucat = nucat
+ self_rank = irank
+ CYCLE
+ ENDIF
+
+ CALL mpi_send (nucat, 1, MPI_INTEGER, p_address_compute(irank), &
+ mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (nucat > 0) THEN
+
+ CALL mpi_send (ucat_data_address(irank)%val, nucat, MPI_INTEGER, &
+ p_address_compute(irank), mpi_tag_data, p_comm_glb, p_err)
+
+#ifndef MPAS_EMBEDDED_COLM
+ allocate (idata1d (nucat))
+
+ idata1d = x_ucat (ucat_data_address(irank)%val)
+ CALL mpi_send (idata1d, nucat, MPI_INTEGER, &
+ p_address_compute(irank), mpi_tag_data, p_comm_glb, p_err)
+
+ idata1d = y_ucat (ucat_data_address(irank)%val)
+ CALL mpi_send (idata1d, nucat, MPI_INTEGER, &
+ p_address_compute(irank), mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (idata1d)
+#endif
+ ENDIF
+ ENDDO
+
+ IF (self_rank >= 0) THEN
+ nucat = numucat_rank(self_rank)
+ IF (allocated(idata1d)) deallocate(idata1d)
+ allocate (idata1d (nucat))
+ IF (nucat > 0) idata1d = ucat_data_address(self_rank)%val
+
+ IF (allocated(ucat_ucid)) deallocate(ucat_ucid)
+ allocate (ucat_ucid (nucat))
+ IF (nucat > 0) ucat_ucid = idata1d
+
+#ifndef MPAS_EMBEDDED_COLM
+ IF (allocated(x_ucat)) THEN
+ IF (nucat > 0) idata1d = x_ucat(ucat_ucid)
+ deallocate (x_ucat)
+ allocate (x_ucat (nucat))
+ IF (nucat > 0) x_ucat = idata1d
+ ENDIF
+
+ IF (allocated(y_ucat)) THEN
+ IF (nucat > 0) idata1d = y_ucat(ucat_ucid)
+ deallocate (y_ucat)
+ allocate (y_ucat (nucat))
+ IF (nucat > 0) y_ucat = idata1d
+ ENDIF
+#endif
+
+ deallocate (idata1d)
+ ENDIF
+
+ ENDIF
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+
+ CALL mpi_recv (numucat, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ IF (numucat > 0) THEN
+ allocate (ucat_ucid (numucat))
+#ifndef MPAS_EMBEDDED_COLM
+ allocate (x_ucat (numucat))
+ allocate (y_ucat (numucat))
+#endif
+ CALL mpi_recv (ucat_ucid, numucat, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+#ifndef MPAS_EMBEDDED_COLM
+ CALL mpi_recv (x_ucat, numucat, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (y_ucat, numucat, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+#endif
+ ENDIF
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ numucat = totalnumucat
+
+ allocate(ucat_ucid (totalnumucat))
+ ucat_ucid = (/(i, i = 1, totalnumucat)/)
+
+ allocate (numucat_rank (0:0))
+ numucat_rank(0) = numucat
+
+ allocate (ucat_data_address (0:0))
+ allocate (ucat_data_address(0)%val (numucat))
+ ucat_data_address(0)%val = ucat_ucid
+#endif
+
+#ifdef MPAS_EMBEDDED_COLM
+ IF (p_is_compute) THEN
+ IF (numucat > 0) THEN
+ CALL ncio_read_indexed_serial (parafile, 'seq_x', ucat_ucid, x_ucat)
+ CALL ncio_read_indexed_serial (parafile, 'seq_y', ucat_ucid, y_ucat)
+ ELSE
+ IF (.not. allocated(x_ucat)) allocate (x_ucat (0))
+ IF (.not. allocated(y_ucat)) allocate (y_ucat (0))
+ ENDIF
+ ENDIF
+#endif
+
+ IF (p_is_compute .and. numucat == 0) THEN
+ IF (.not. allocated(ucat_ucid)) allocate (ucat_ucid (0))
+ IF (.not. allocated(x_ucat )) allocate (x_ucat (0))
+ IF (.not. allocated(y_ucat )) allocate (y_ucat (0))
+ ENDIF
+
+ IF (allocated(addr_ucat)) deallocate(addr_ucat)
+
+ ! ----- Part 1: between runoff input elements and unit catchments -----
+
+#ifdef COLM_PARALLEL
+ CALL mpi_bcast (nlon_ucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ CALL mpi_bcast (nlat_ucat, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+#endif
+
+ CALL griducat%define_by_ndims (nlon_ucat, nlat_ucat)
+
+ CALL build_compute_remapdata (landpatch, griducat, remap_patch2inpm)
+
+ IF (p_is_compute) 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
+
+#ifdef MPAS_EMBEDDED_COLM
+ CALL ncio_inquire_varsize (parafile, 'inpmat_x', varsize)
+ inpn = varsize(1)
+ deallocate (varsize)
+
+ IF (p_is_compute) 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)
+
+ allocate(idmap_gd2uc (inpn,numucat))
+ idmap_gd2uc = (idmap_y-1)*nlon_ucat + idmap_x
+
+ WHERE ((area_gd2uc <= 0) .or. (idmap_gd2uc <= 0))
+ idmap_gd2uc = 0
+ area_gd2uc = 0.
+ END WHERE
+ ELSE
+ allocate(idmap_gd2uc (inpn,0))
+ allocate(area_gd2uc (inpn,0))
+ ENDIF
+
+ CALL build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, &
+ nucpart, idmap_uc2gd, area_uc2gd)
+ ENDIF
+#else
+ IF (p_is_root) THEN
+
+ inpn = size(idmap_x,1)
+
+ allocate(idmap_gd2uc (inpn,totalnumucat))
+
+ idmap_gd2uc = (idmap_y-1)*nlon_ucat + idmap_x
+
+ WHERE ((area_gd2uc <= 0) .or. (idmap_gd2uc <= 0))
+ idmap_gd2uc = 0
+ area_gd2uc = 0.
+ END WHERE
+
+ allocate (nucat_g2d (nlon_ucat,nlat_ucat))
+ nucat_g2d(:,:) = 0
+
+ DO i = 1, totalnumucat
+ DO j = 1, inpn
+ IF (idmap_gd2uc(j,i) > 0) THEN
+ nucat_g2d(idmap_x(j,i),idmap_y(j,i)) = nucat_g2d(idmap_x(j,i),idmap_y(j,i)) + 1
+ ENDIF
+ ENDDO
+ ENDDO
+
+ nucpart = maxval(nucat_g2d)
+ ngrdall = count(nucat_g2d > 0)
+
+ allocate (allgrd_in_inp (ngrdall))
+
+ igrd = 0
+ DO i = 1, nlat_ucat
+ DO j = 1, nlon_ucat
+ IF (nucat_g2d(j,i) > 0) THEN
+ igrd = igrd + 1
+ allgrd_in_inp(igrd) = (i-1)*nlon_ucat + j
+ ENDIF
+ ENDDO
+ ENDDO
+
+ allocate (idmap_uc2gd_all (nucpart, ngrdall)); idmap_uc2gd_all(:,:) = 0
+ allocate (area_uc2gd_all (nucpart, ngrdall)); area_uc2gd_all (:,:) = 0.
+
+ allocate (iucat_g (ngrdall)); iucat_g(:) = 0
+
+ DO i = 1, totalnumucat
+ DO j = 1, inpn
+ IF (idmap_gd2uc(j,i) > 0) THEN
+ iloc = find_in_sorted_list1 (idmap_gd2uc(j,i), ngrdall, allgrd_in_inp(1:ngrdall))
+ iucat_g(iloc) = iucat_g(iloc) + 1
+ idmap_uc2gd_all(iucat_g(iloc),iloc) = i
+ area_uc2gd_all (iucat_g(iloc),iloc) = area_gd2uc(j,i)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+#ifdef COLM_PARALLEL
+ CALL mpi_bcast (inpn, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+
+ IF (p_is_root) THEN
+
+ self_rank = -1
+ DO irank = 0, p_np_compute-1
+
+ nucat = numucat_rank(irank)
+
+ IF (nucat > 0) THEN
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ self_rank = irank
+ CYCLE
+ ENDIF
+
+ allocate (idata2d (inpn, nucat))
+ DO i = 1, nucat
+ idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(irank)%val(i))
+ ENDDO
+
+ allocate (rdata2d (inpn, nucat))
+ DO i = 1, nucat
+ rdata2d(:,i) = area_gd2uc(:,ucat_data_address(irank)%val(i))
+ ENDDO
+
+ CALL mpi_send (idata2d, inpn*nucat, MPI_INTEGER, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+ CALL mpi_send (rdata2d, inpn*nucat, MPI_REAL8, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (idata2d)
+ deallocate (rdata2d)
+ ENDIF
+ ENDDO
+
+ IF (self_rank >= 0) THEN
+ nucat = numucat_rank(self_rank)
+ IF (nucat > 0) THEN
+ allocate (idata2d (inpn, nucat))
+ DO i = 1, nucat
+ idata2d(:,i) = idmap_gd2uc(:,ucat_data_address(self_rank)%val(i))
+ ENDDO
+
+ allocate (rdata2d (inpn, nucat))
+ DO i = 1, nucat
+ rdata2d(:,i) = area_gd2uc(:,ucat_data_address(self_rank)%val(i))
+ ENDDO
+
+ IF (allocated(idmap_gd2uc)) deallocate(idmap_gd2uc)
+ IF (allocated(area_gd2uc )) deallocate(area_gd2uc )
+ allocate (idmap_gd2uc (inpn, nucat))
+ allocate (area_gd2uc (inpn, nucat))
+ idmap_gd2uc = idata2d
+ area_gd2uc = rdata2d
+
+ deallocate (idata2d)
+ deallocate (rdata2d)
+ ENDIF
+ ENDIF
+
+ IF (.not. (p_is_compute .and. numucat > 0)) THEN
+ IF (allocated(idmap_gd2uc)) deallocate (idmap_gd2uc)
+ IF (allocated(area_gd2uc )) deallocate (area_gd2uc )
+ IF (p_is_compute) THEN
+ allocate (idmap_gd2uc (inpn,0))
+ allocate (area_gd2uc (inpn,0))
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+
+ IF (numucat > 0) THEN
+
+ allocate (idmap_gd2uc (inpn, numucat))
+ CALL mpi_recv (idmap_gd2uc, inpn*numucat, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (area_gd2uc (inpn, numucat))
+ CALL mpi_recv (area_gd2uc, inpn*numucat, MPI_REAL8, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ ENDIF
+
+ ENDIF
+
+ CALL mpi_bcast (nucpart, 1, mpi_integer, p_address_root, p_comm_glb, p_err)
+
+ IF (p_is_root) THEN
+
+ DO irank = 0, p_np_compute-1
+
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ ngrd = numinpm
+ ELSE
+ CALL mpi_recv (ngrd, 1, MPI_INTEGER, &
+ p_address_compute(irank), mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ ENDIF
+
+ IF (ngrd > 0) THEN
+
+ allocate (grdindex (ngrd))
+ allocate (idata2d (nucpart, ngrd)); idata2d(:,:) = 0
+ allocate (rdata2d (nucpart, ngrd)); rdata2d(:,:) = 0.
+
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ grdindex = inpm_gdid
+ ELSE
+ CALL mpi_recv (grdindex, ngrd, MPI_INTEGER, &
+ p_address_compute(irank), mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+
+ DO i = 1, ngrd
+ iloc = find_in_sorted_list1 (grdindex(i), ngrdall, allgrd_in_inp(1:ngrdall))
+ IF (iloc > 0) THEN
+ idata2d(:,i) = idmap_uc2gd_all(:,iloc)
+ rdata2d(:,i) = area_uc2gd_all (:,iloc)
+ ENDIF
+ ENDDO
+
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ IF (allocated(idmap_uc2gd)) deallocate(idmap_uc2gd)
+ IF (allocated(area_uc2gd )) deallocate(area_uc2gd )
+ allocate (idmap_uc2gd (nucpart, ngrd))
+ allocate (area_uc2gd (nucpart, ngrd))
+ idmap_uc2gd = idata2d
+ area_uc2gd = rdata2d
+ ELSE
+ CALL mpi_send (idata2d, nucpart*ngrd, MPI_INTEGER, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+ CALL mpi_send (rdata2d, nucpart*ngrd, MPI_REAL8, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ deallocate (grdindex)
+ deallocate (idata2d )
+ deallocate (rdata2d )
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+
+ CALL mpi_send (numinpm, 1, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (numinpm > 0) THEN
+
+ CALL mpi_send (inpm_gdid, numinpm, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_err)
+
+ allocate (idmap_uc2gd (nucpart,numinpm))
+ CALL mpi_recv (idmap_uc2gd, nucpart*numinpm, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (area_uc2gd (nucpart,numinpm))
+ CALL mpi_recv (area_uc2gd, nucpart*numinpm, MPI_REAL8, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ ENDIF
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ allocate (idmap_uc2gd (nucpart,numinpm))
+ allocate (area_uc2gd (nucpart,numinpm))
+ idmap_uc2gd = 0
+ area_uc2gd = 0.
+
+ DO i = 1, numinpm
+ iloc = find_in_sorted_list1 (inpm_gdid(i), ngrdall, allgrd_in_inp(1:ngrdall))
+ IF (iloc > 0) THEN
+ idmap_uc2gd(:,i) = idmap_uc2gd_all(:,iloc)
+ area_uc2gd (:,i) = area_uc2gd_all (:,iloc)
+ ENDIF
+ ENDDO
+#endif
+#endif
+
+ IF (p_is_compute) THEN
+ IF (.not. allocated(idmap_gd2uc)) allocate (idmap_gd2uc (inpn,0))
+ IF (.not. allocated(area_gd2uc )) allocate (area_gd2uc (inpn,0))
+ IF (.not. allocated(idmap_uc2gd)) allocate (idmap_uc2gd (nucpart,0))
+ IF (.not. allocated(area_uc2gd )) allocate (area_uc2gd (nucpart,0))
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numucat > 0) THEN
+ allocate (ucat_gdid (numucat))
+ ucat_gdid = (y_ucat-1)*nlon_ucat + x_ucat
+ ELSE
+ allocate (ucat_gdid (0))
+ ENDIF
+ ENDIF
+
+ 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)
+ CALL build_compute_pushdata (numucat, ucat_gdid, numinpm, inpm_gdid, push_ucat2grid)
+ CALL build_compute_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm)
+
+ IF (allocated(idmap_x)) deallocate (idmap_x)
+ IF (allocated(idmap_y)) deallocate (idmap_y)
+ IF (p_is_root) THEN
+ IF (allocated(allgrd_in_inp )) deallocate (allgrd_in_inp )
+ IF (allocated(nucat_g2d )) deallocate (nucat_g2d )
+ IF (allocated(iucat_g )) deallocate (iucat_g )
+ IF (allocated(idmap_uc2gd_all)) deallocate (idmap_uc2gd_all)
+ IF (allocated(area_uc2gd_all )) deallocate (area_uc2gd_all )
+ ENDIF
+
+ ! ----- Part 2: between upstream and downstream unit catchments -----
+
+ IF (p_is_root) THEN
+
+ upnmax = maxval(nups_nst)
+ allocate (ucat_ups (upnmax,totalnumucat))
+ ucat_ups(:,:) = 0
+ allocate (ucat_next_all (totalnumucat))
+ ucat_next_all = ucat_next
+
+ iups_nst(:) = 0
+ DO i = 1, totalnumucat
+ j = ucat_next(i)
+ IF (j > 0) THEN
+ iups_nst(j) = iups_nst(j) + 1
+ ucat_ups(iups_nst(j),j) = i
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+
+#ifdef COLM_PARALLEL
+ CALL mpi_bcast (upnmax, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+
+ IF (p_is_root) THEN
+
+ self_rank = -1
+ DO irank = 0, p_np_compute-1
+
+ nucat = numucat_rank(irank)
+
+ IF (nucat > 0) THEN
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ self_rank = irank
+ CYCLE
+ ENDIF
+
+ allocate (idata1d (nucat))
+ idata1d = ucat_next(ucat_data_address(irank)%val)
+
+ allocate (idata2d (upnmax,nucat))
+ DO i = 1, nucat
+ idata2d(:,i) = ucat_ups(:,ucat_data_address(irank)%val(i))
+ ENDDO
+
+ CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+ CALL mpi_send (idata2d, upnmax*nucat, MPI_INTEGER, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (idata1d)
+ deallocate (idata2d)
+ ENDIF
+ ENDDO
+
+ IF (self_rank >= 0) THEN
+ nucat = numucat_rank(self_rank)
+ IF (nucat > 0) THEN
+ allocate (idata1d (nucat))
+ idata1d = ucat_next(ucat_data_address(self_rank)%val)
+
+ allocate (idata2d (upnmax,nucat))
+ DO i = 1, nucat
+ idata2d(:,i) = ucat_ups(:,ucat_data_address(self_rank)%val(i))
+ ENDDO
+
+ IF (allocated(ucat_next)) deallocate(ucat_next)
+ IF (allocated(ucat_ups )) deallocate(ucat_ups )
+ allocate (ucat_next (nucat))
+ allocate (ucat_ups (upnmax,nucat))
+ ucat_next = idata1d
+ ucat_ups = idata2d
+
+ deallocate (idata1d)
+ deallocate (idata2d)
+ ELSE
+ IF (allocated(ucat_next)) deallocate(ucat_next)
+ IF (allocated(ucat_ups )) deallocate(ucat_ups )
+ allocate (ucat_next (0))
+ allocate (ucat_ups (upnmax,0))
+ ENDIF
+ ENDIF
+
+ IF (.not. (p_is_compute .and. numucat > 0)) THEN
+ IF (allocated(ucat_ups)) deallocate (ucat_ups)
+ ENDIF
+
+ ENDIF
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+
+ IF (numucat > 0) THEN
+
+ allocate (ucat_next (numucat))
+ CALL mpi_recv (ucat_next, numucat, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ allocate (ucat_ups (upnmax, numucat))
+ CALL mpi_recv (ucat_ups, upnmax*numucat, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ ENDIF
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_compute) THEN
+ IF (.not. allocated(ucat_next)) allocate (ucat_next (0))
+ IF (.not. allocated(ucat_ups )) allocate (ucat_ups (upnmax,0))
+ allocate (wts_ups (upnmax,numucat))
+ IF (numucat > 0) wts_ups(:,:) = 1.
+ ENDIF
+
+ 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 )
+
+#ifdef CoLMDEBUG
+ ! IF (p_is_compute) THEN
+ ! write(*,'(A,I0,A,I0,A,I0,A)') 'rank ', p_iam_compute, ' has ', numucat, &
+ ! ' unit catchment with ', sum(push_next2ucat%n_from_other), ' downstream to other ranks'
+ ! ENDIF
+#endif
+
+ ! ----- Part 3: river systems -----
+
+#ifdef COLM_PARALLEL
+ IF (p_is_root) THEN
+ self_rank = -1
+ DO irank = 0, p_np_compute-1
+ nucat = numucat_rank(irank)
+ IF (nucat > 0) THEN
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ self_rank = irank
+ CYCLE
+ ENDIF
+
+ allocate (idata1d (nucat))
+ idata1d = rivermouth(ucat_data_address(irank)%val)
+ CALL mpi_send (idata1d, nucat, MPI_INTEGER, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+ deallocate (idata1d)
+ ENDIF
+ ENDDO
+
+ IF (self_rank >= 0) THEN
+ nucat = numucat_rank(self_rank)
+ allocate (idata1d (nucat))
+ IF (nucat > 0) idata1d = rivermouth(ucat_data_address(self_rank)%val)
+ IF (allocated(rivermouth)) deallocate(rivermouth)
+ allocate (rivermouth (nucat))
+ IF (nucat > 0) rivermouth = idata1d
+ deallocate (idata1d)
+ ENDIF
+ ENDIF
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+ IF (numucat > 0) THEN
+ allocate (rivermouth (numucat))
+ CALL mpi_recv (rivermouth, numucat, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numucat > 0) THEN
+ color = maxval(rivermouth)
+ CALL mpi_comm_split (p_comm_compute, color, p_iam_compute, p_comm_rivsys, p_err)
+ ELSE
+ CALL mpi_comm_split (p_comm_compute, MPI_UNDEFINED, p_iam_compute, p_comm_rivsys, p_err)
+ ENDIF
+
+ rivsys_by_multiple_procs = .false.
+ IF (p_comm_rivsys /= MPI_COMM_NULL) THEN
+ CALL mpi_comm_size (p_comm_rivsys, p_np_rivsys, p_err)
+ IF (p_np_rivsys > 1) THEN
+ rivsys_by_multiple_procs = .true.
+ ENDIF
+ ENDIF
+ ENDIF
+#else
+ rivsys_by_multiple_procs = .false.
+#endif
+
+ IF (p_is_compute) THEN
+
+ IF (numucat > 0) allocate (irivsys (numucat))
+
+ IF (.not. rivsys_by_multiple_procs) THEN
+ IF (numucat > 0) THEN
+
+ allocate (order_ucat (numucat))
+ order_ucat = (/(i, i = 1, numucat)/)
+
+ CALL quicksort (numucat, rivermouth, order_ucat)
+
+ numrivsys = 1
+ irivsys(order_ucat(1)) = numrivsys
+ DO i = 2, numucat
+ IF (rivermouth(i) /= rivermouth(i-1)) THEN
+ numrivsys = numrivsys + 1
+ ENDIF
+ irivsys(order_ucat(i)) = numrivsys
+ ENDDO
+
+ ENDIF
+ ELSE
+ numrivsys = 1
+ irivsys(:) = 1
+ ENDIF
+
+ ENDIF
+
+ IF (allocated(rivermouth)) deallocate(rivermouth)
+ IF (allocated(order_ucat)) deallocate(order_ucat)
+
+ ! ----- Parameters for River and Lake -----
+
+ 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 )
+
+ IF (p_is_compute) 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.
+ floodplain_curve(i)%flphgt(1:) = topo_fldhgt(:,i)
+
+ floodplain_curve(i)%flparea(0) = 0.
+ floodplain_curve(i)%flparea(1:) = topo_area(i) / floodplain_curve(i)%nlfp
+
+ floodplain_curve(i)%flpaccare(0) = 0.
+ 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.
+ DO j = 1, floodplain_curve(i)%nlfp
+ floodplain_curve(i)%flpstomax(j) = floodplain_curve(i)%flpstomax(j-1) &
+ + 0.5 * (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 (p_is_compute) THEN
+ IF (numucat > 0) THEN
+ WHERE (ucat_next > 0)
+ outletwth = (outletwth + topo_rivwth) * 0.5
+ ELSEWHERE
+ outletwth = topo_rivwth
+ END WHERE
+ ENDIF
+ ENDIF
+
+ ! ----- Mask of Grids with all upstream area in the simulation region -----
+
+ IF (p_is_root) allocate (ucat_area_all (totalnumucat))
+
+#ifdef COLM_PARALLEL
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+
+ IF (numucat > 0) THEN
+ CALL mpi_send (push_inpm2ucat%sum_area, numucat, MPI_REAL8, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ ENDIF
+
+ IF (p_is_root) THEN
+
+ DO irank = 0, p_np_compute-1
+ IF (numucat_rank(irank) > 0) THEN
+
+ allocate (rdata1d (numucat_rank(irank)))
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ rdata1d = push_inpm2ucat%sum_area
+ ELSE
+ CALL mpi_recv (rdata1d, numucat_rank(irank), MPI_REAL8, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+
+ ucat_area_all(ucat_data_address(irank)%val) = rdata1d
+
+ deallocate (rdata1d)
+ ENDIF
+
+ ENDDO
+ ENDIF
+#else
+ ucat_area_all = push_inpm2ucat%sum_area
+#endif
+
+ IF (p_is_root) THEN
+
+ allocate (allups_mask_ucat (totalnumucat))
+ allups_mask_ucat (:) = 0
+
+ iups_nst(:) = 0
+ DO i = 1, totalnumucat
+ j = uc_up2down(i)
+ IF (ucat_area_all(j) > 0.) THEN
+ IF (iups_nst(j) == nups_nst(j)) THEN
+
+ allups_mask_ucat(j) = 1
+
+ IF (ucat_next_all(j) > 0) THEN
+ iups_nst(ucat_next_all(j)) = iups_nst(ucat_next_all(j)) + 1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+#ifdef COLM_PARALLEL
+ IF (p_is_root) THEN
+ self_rank = -1
+ DO irank = 0, p_np_compute-1
+ IF (numucat_rank(irank) > 0) THEN
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ self_rank = irank
+ CYCLE
+ ENDIF
+
+ allocate (rdata1d (numucat_rank(irank)))
+ rdata1d = allups_mask_ucat(ucat_data_address(irank)%val)
+
+ CALL mpi_send (rdata1d, numucat_rank(irank), MPI_REAL8, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (rdata1d)
+ ENDIF
+ ENDDO
+
+ IF (self_rank >= 0) THEN
+ allocate (rdata1d (numucat_rank(self_rank)))
+ IF (numucat_rank(self_rank) > 0) &
+ rdata1d = allups_mask_ucat(ucat_data_address(self_rank)%val)
+ IF (allocated(allups_mask_ucat)) deallocate(allups_mask_ucat)
+ allocate (allups_mask_ucat (numucat_rank(self_rank)))
+ IF (numucat_rank(self_rank) > 0) allups_mask_ucat = rdata1d
+ deallocate (rdata1d)
+ ENDIF
+ ENDIF
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+ IF (numucat > 0) THEN
+ allocate (allups_mask_ucat (numucat))
+ CALL mpi_recv (allups_mask_ucat, numucat, MPI_REAL8, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+ ENDIF
+#endif
+
+ IF (p_is_compute .and. numucat == 0) THEN
+ IF (.not. allocated(allups_mask_ucat)) allocate (allups_mask_ucat (0))
+ ENDIF
+
+
+ IF (allocated (uc_up2down )) deallocate (uc_up2down )
+ IF (allocated (ucat_next_all)) deallocate (ucat_next_all)
+ IF (allocated (nups_nst )) deallocate (nups_nst )
+ IF (allocated (iups_nst )) deallocate (iups_nst )
+ IF (allocated (ucat_area_all)) deallocate (ucat_area_all)
+
+ END SUBROUTINE build_riverlake_network
+
+#ifdef MPAS_EMBEDDED_COLM
+ ! ---------
+ SUBROUTINE build_riverlake_network_mpas_embedded ()
+
+ USE MOD_SPMD_Task
+ 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 :: inpn
+ 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 (p_is_compute) 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, numinpm, inpm_gdid)
+
+ CALL ncio_inquire_varsize (parafile, 'inpmat_x', varsize)
+ inpn = varsize(1)
+ deallocate (varsize)
+
+ IF (p_is_compute) 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)
+
+ 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, inpn, numinpm, inpm_gdid, &
+ nucpart, idmap_uc2gd, area_uc2gd)
+ ENDIF
+
+ IF (p_is_compute) 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)
+ CALL build_compute_pushdata (numucat, ucat_ucid, numinpm, inpm_gdid, push_ucat2grid)
+ CALL build_compute_pushdata (numinpm, inpm_gdid, numinpm, inpm_gdid, allreduce_inpm)
+ ENDIF
+
+ CALL build_mpas_embedded_local_topology (parafile)
+
+ IF (p_is_compute) 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 check_mpas_embedded_downstream_ownership ()
+ CALL build_compute_pushdata (numucat, ucat_ucid, numucat, ucat_ups, wts_ups, push_ups2ucat )
+ 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 )
+
+ IF (p_is_compute) 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) / floodplain_curve(i)%nlfp
+
+ 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 (p_is_compute) THEN
+ IF (numucat > 0) THEN
+ WHERE (ucat_next > 0)
+ outletwth = (outletwth + topo_rivwth) * 0.5_r8
+ ELSEWHERE
+ outletwth = topo_rivwth
+ END WHERE
+ ENDIF
+
+ allocate (allups_mask_ucat (numucat))
+ IF (numucat > 0) THEN
+ allups_mask_ucat(:) = 0._r8
+ WHERE (push_inpm2ucat%sum_area > 0._r8)
+ allups_mask_ucat = 1._r8
+ END WHERE
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE build_riverlake_network_mpas_embedded
+
+ ! ---------
+ SUBROUTINE build_mpas_embedded_river_systems (parafile)
+
+ USE MOD_SPMD_Task
+ 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(:), all_mouths(:), global_mouths(:)
+#ifdef COLM_PARALLEL
+ integer, allocatable :: counts(:), displs(:)
+#endif
+ integer :: i, iloc, nactive, niter, nlocal_mouths, total_mouths
+ logical :: is_new
+
+ IF (.not. p_is_compute) 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) THEN
+ mouth_id(i) = ucat_ucid(i)
+ ENDIF
+ 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
+
+#ifdef COLM_PARALLEL
+ allocate (counts (0:p_np_compute-1))
+ allocate (displs (0:p_np_compute-1))
+ CALL mpi_allgather (nlocal_mouths, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, p_comm_compute, p_err)
+
+ displs(0) = 0
+ DO i = 1, p_np_compute-1
+ displs(i) = displs(i-1) + counts(i-1)
+ ENDDO
+ total_mouths = sum(counts)
+
+ allocate (all_mouths (max(1,total_mouths)))
+ CALL mpi_allgatherv (local_mouths, nlocal_mouths, MPI_INTEGER, all_mouths, counts, displs, &
+ MPI_INTEGER, p_comm_compute, p_err)
+
+ allocate (global_mouths (max(1,total_mouths)))
+ numrivsys = 0
+ DO i = 1, total_mouths
+ CALL insert_into_sorted_list1 (all_mouths(i), numrivsys, global_mouths, iloc, is_new)
+ ENDDO
+
+ p_comm_rivsys = p_comm_compute
+ rivsys_by_multiple_procs = p_np_compute > 1
+
+ deallocate (counts)
+ deallocate (displs)
+ deallocate (all_mouths)
+#else
+ total_mouths = nlocal_mouths
+ allocate (global_mouths (max(1,total_mouths)))
+ numrivsys = nlocal_mouths
+ IF (numrivsys > 0) global_mouths(1:numrivsys) = local_mouths(1:numrivsys)
+ rivsys_by_multiple_procs = .false.
+#endif
+
+ DO i = 1, numucat
+ irivsys(i) = find_in_sorted_list1 (mouth_id(i), numrivsys, global_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)
+ deallocate (global_mouths)
+
+ END SUBROUTINE build_mpas_embedded_river_systems
+
+ ! ---------
+ SUBROUTINE build_mpas_embedded_local_ucats (parafile, nlon_ucat, numinpm, inpm_gdid)
+
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_Utils
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: parafile
+ integer, intent(in) :: nlon_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 :: istart, iend, iucat, iloc, grid_id, nfound
+
+ IF (.not. p_is_compute) 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)
+
+ 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)
+
+ DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1)
+ IF (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) nfound = nfound + 1
+ ENDIF
+ ENDDO
+
+ deallocate (seq_x_blk)
+ deallocate (seq_y_blk)
+ istart = iend + 1
+ ENDDO
+ ELSE
+ nfound = 0
+ ENDIF
+
+ numucat = nfound
+ allocate (ucat_ucid (numucat))
+ allocate (x_ucat (numucat))
+ allocate (y_ucat (numucat))
+ allocate (ucat_gdid (numucat))
+
+ IF (numinpm > 0 .and. numucat > 0) THEN
+ 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)
+
+ DO iucat = lbound(seq_x_blk,1), ubound(seq_x_blk,1)
+ IF (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) THEN
+ nfound = nfound + 1
+ ucat_ucid(nfound) = iucat
+ x_ucat(nfound) = seq_x_blk(iucat)
+ y_ucat(nfound) = seq_y_blk(iucat)
+ ucat_gdid(nfound) = grid_id
+ ENDIF
+ ENDIF
+ ENDDO
+
+ deallocate (seq_x_blk)
+ deallocate (seq_y_blk)
+ istart = iend + 1
+ ENDDO
+ ENDIF
+
+ 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_SPMD_Task
+ 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. p_is_compute) 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)
+
+ 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 COLM_PARALLEL
+ CALL mpi_allreduce (local_upnmax, upnmax, 1, MPI_INTEGER, MPI_MAX, p_comm_compute, p_err)
+#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)) = iucat
+ 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 check_mpas_embedded_downstream_ownership ()
+
+ USE MOD_SPMD_Task
+ IMPLICIT NONE
+
+ logical, allocatable :: id_found(:)
+ integer :: i, irank, ireq
+ integer :: local_missing, global_missing
+ integer :: first_missing, global_first_missing
+
+ IF (.not. p_is_compute) RETURN
+
+ local_missing = 0
+ first_missing = huge(1)
+
+ IF (numucat > 0 .and. push_next2ucat%num_req_uniq > 0) THEN
+ allocate (id_found (push_next2ucat%num_req_uniq))
+ id_found(:) = .false.
+
+ IF (push_next2ucat%nself > 0) id_found(push_next2ucat%self_to) = .true.
+
+#ifdef COLM_PARALLEL
+ DO irank = 0, p_np_compute-1
+ IF (push_next2ucat%n_from_other(irank) > 0) THEN
+ id_found(push_next2ucat%other_to(irank)%val) = .true.
+ ENDIF
+ ENDDO
+#endif
+
+ DO i = 1, numucat
+ IF (ucat_next(i) > 0) THEN
+ ireq = push_next2ucat%addr_single(i)
+ IF (ireq <= 0 .or. .not. id_found(ireq)) THEN
+ local_missing = local_missing + 1
+ first_missing = min(first_missing, ucat_next(i))
+ ENDIF
+ ENDIF
+ ENDDO
+
+ deallocate (id_found)
+ ENDIF
+
+#ifdef COLM_PARALLEL
+ CALL mpi_allreduce (local_missing, global_missing, 1, MPI_INTEGER, MPI_SUM, p_comm_compute, p_err)
+ CALL mpi_allreduce (first_missing, global_first_missing, 1, MPI_INTEGER, MPI_MIN, p_comm_compute, p_err)
+#else
+ global_missing = local_missing
+ global_first_missing = first_missing
+#endif
+
+ IF (global_missing > 0) THEN
+ IF (p_is_root) THEN
+ write(*,'(A,I0,A,I0)') 'ERROR: MPAS embedded CoLM GridRiverLakeFlow is missing ', &
+ global_missing, ' downstream unit-catchment owner(s); first missing seq_next = ', &
+ global_first_missing
+ ENDIF
+ CALL CoLM_Stop ('ERROR: MPAS embedded CoLM river network ownership is incomplete.')
+ ENDIF
+
+ END SUBROUTINE check_mpas_embedded_downstream_ownership
+
+ ! ---------
+ SUBROUTINE build_mpas_embedded_uc2gd (parafile, nlon_ucat, inpn, numinpm, inpm_gdid, &
+ nucpart, idmap_uc2gd, area_uc2gd)
+
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_Utils
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: parafile
+ integer, intent(in) :: nlon_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)
+
+ 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 COLM_PARALLEL
+ CALL mpi_allreduce (nucpart_local, nucpart, 1, MPI_INTEGER, MPI_MAX, p_comm_glb, p_err)
+#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)
+
+ 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) = iucat
+ 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 readin_riverlake_parameter (parafile, varname, rdata1d, rdata2d, idata1d)
+
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ 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 (:)
+
+ ! Local Variables
+ integer :: irank, nucat, ndim1, i
+ real(r8), allocatable :: rsend1d (:)
+ real(r8), allocatable :: rsend2d (:,:)
+ integer, allocatable :: isend1d (:)
+
+#ifdef MPAS_EMBEDDED_COLM
+ IF (p_is_compute) 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
+#ifdef COLM_PARALLEL
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+ RETURN
+#endif
+
+ IF (p_is_root) THEN
+ IF (present(rdata1d)) CALL ncio_read_serial (parafile, varname, rdata1d)
+ IF (present(rdata2d)) CALL ncio_read_serial (parafile, varname, rdata2d)
+ IF (present(idata1d)) CALL ncio_read_serial (parafile, varname, idata1d)
+ ENDIF
+
+#ifdef COLM_PARALLEL
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+ IF (present(rdata2d)) THEN
+ IF (p_is_root) ndim1 = size(rdata2d,1)
+ CALL mpi_bcast (ndim1, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ ENDIF
+
+ ! send unit catchment index to ranks
+ IF (p_is_root) THEN
+
+ DO irank = 0, p_np_compute-1
+
+ nucat = numucat_rank(irank)
+
+ IF (nucat > 0) THEN
+ IF (present(rdata1d)) THEN
+ allocate (rsend1d (nucat))
+
+ rsend1d = rdata1d(ucat_data_address(irank)%val)
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ IF (allocated(rdata1d)) deallocate(rdata1d)
+ allocate (rdata1d (nucat))
+ rdata1d = rsend1d
+ ELSE
+ CALL mpi_send (rsend1d, nucat, MPI_REAL8, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ deallocate (rsend1d)
+ ENDIF
+
+ IF (present(rdata2d)) THEN
+ allocate (rsend2d (ndim1,nucat))
+
+ DO i = 1, nucat
+ rsend2d(:,i) = rdata2d(:,ucat_data_address(irank)%val(i))
+ ENDDO
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ IF (allocated(rdata2d)) deallocate(rdata2d)
+ allocate (rdata2d (ndim1,nucat))
+ rdata2d = rsend2d
+ ELSE
+ CALL mpi_send (rsend2d, ndim1*nucat, MPI_REAL8, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ deallocate (rsend2d)
+ ENDIF
+
+ IF (present(idata1d)) THEN
+ allocate (isend1d (nucat))
+
+ isend1d = idata1d(ucat_data_address(irank)%val)
+ IF (p_address_compute(irank) == p_iam_glb) THEN
+ IF (allocated(idata1d)) deallocate(idata1d)
+ allocate (idata1d (nucat))
+ idata1d = isend1d
+ ELSE
+ CALL mpi_send (isend1d, nucat, MPI_INTEGER, p_address_compute(irank), &
+ mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ deallocate (isend1d)
+ ENDIF
+ ENDIF
+ ENDDO
+
+ IF (.not. p_is_compute) THEN
+ IF (present(rdata1d)) deallocate (rdata1d)
+ IF (present(rdata2d)) deallocate (rdata2d)
+ IF (present(idata1d)) deallocate (idata1d)
+ ENDIF
+
+ ENDIF
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+
+ IF (numucat > 0) THEN
+ IF (present(rdata1d)) THEN
+ allocate (rdata1d (numucat))
+ CALL mpi_recv (rdata1d, numucat, MPI_REAL8, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+
+ IF (present(rdata2d)) THEN
+ allocate (rdata2d (ndim1,numucat))
+ CALL mpi_recv (rdata2d, ndim1*numucat, MPI_REAL8, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+
+ IF (present(idata1d)) THEN
+ allocate (idata1d (numucat))
+ CALL mpi_recv (idata1d, numucat, MPI_INTEGER, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_compute .and. numucat == 0) THEN
+ IF (present(rdata1d)) THEN
+ IF (.not. allocated(rdata1d)) allocate (rdata1d (0))
+ ENDIF
+ IF (present(rdata2d)) THEN
+ IF (.not. allocated(rdata2d)) allocate (rdata2d (ndim1,0))
+ ENDIF
+ IF (present(idata1d)) THEN
+ IF (.not. allocated(idata1d)) allocate (idata1d (0))
+ ENDIF
+ ENDIF
+
+ 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(x_ucat )) deallocate(x_ucat )
+ IF (allocated(y_ucat )) deallocate(y_ucat )
+
+ IF (allocated(ucat_ucid )) deallocate(ucat_ucid )
+ IF (allocated(ucat_gdid )) deallocate(ucat_gdid )
+
+ IF (allocated(numucat_rank )) deallocate(numucat_rank )
+ IF (allocated(ucat_data_address)) deallocate(ucat_data_address)
+
+ 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(irivsys )) deallocate(irivsys )
+
+ 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 )
+
+ IF (allocated(allups_mask_ucat )) deallocate(allups_mask_ucat )
+
+ 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..69c329d91f
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Grid_RiverLakeTimeVars.F90
@@ -0,0 +1,287 @@
+#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 :: momen_riv (:) ! unit river momentum [m^2/s]
+ real(r8), allocatable :: volresv (:) ! reservoir water volume [m^3]
+
+ ! -- 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
+
+CONTAINS
+
+ SUBROUTINE allocate_GridRiverLakeTimeVars
+
+ USE MOD_SPMD_Task
+ USE MOD_Grid_RiverLakeNetwork, only: numucat
+ USE MOD_Grid_Reservoir, only: numresv
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+
+ allocate (wdsrf_ucat (numucat))
+ allocate (veloc_riv (numucat))
+ allocate (momen_riv (numucat))
+ allocate (volresv (numresv))
+
+ ENDIF
+
+ END SUBROUTINE allocate_GridRiverLakeTimeVars
+
+
+ SUBROUTINE READ_GridRiverLakeTimeVars (file_restart)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Vector_ReadWrite
+#ifdef MPAS_EMBEDDED_COLM
+ USE MOD_NetCDFSerial, only: ncio_read_indexed_serial
+ USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_ucid
+ USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_global_index
+#else
+ USE MOD_Grid_RiverLakeNetwork, only: numucat, ucat_data_address
+ USE MOD_Grid_Reservoir, only: numresv, resv_data_address, totalnumresv
+#endif
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: file_restart
+
+ gridriver_restart_file = trim(file_restart)
+
+#ifdef MPAS_EMBEDDED_COLM
+ IF (p_is_compute .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 )
+ ENDIF
+#else
+ CALL vector_read_and_scatter (file_restart, wdsrf_ucat, numucat, 'wdsrf_ucat', ucat_data_address)
+ CALL vector_read_and_scatter (file_restart, veloc_riv, numucat, 'veloc_riv', ucat_data_address)
+#endif
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (totalnumresv > 0) THEN
+#ifdef MPAS_EMBEDDED_COLM
+ IF (p_is_compute .and. numresv > 0) THEN
+ CALL ncio_read_indexed_serial (file_restart, 'volresv', resv_global_index, volresv)
+ ENDIF
+#else
+ CALL vector_read_and_scatter (file_restart, volresv, numresv, 'volresv', resv_data_address)
+#endif
+ ENDIF
+ ENDIF
+
+ ! 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_SPMD_Task
+ USE MOD_Namelist
+#ifndef MPAS_EMBEDDED_COLM
+ USE MOD_NetCDFSerial
+ USE MOD_Vector_ReadWrite
+ USE MOD_Grid_RiverLakeNetwork, only: numucat, totalnumucat, ucat_data_address
+ USE MOD_Grid_Reservoir, only: numresv, totalnumresv, resv_data_address
+#endif
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: file_restart
+
+#ifdef MPAS_EMBEDDED_COLM
+ CALL write_gridriver_restart_mpas_embedded (file_restart)
+#else
+ IF (p_is_root) THEN
+ CALL ncio_create_file (trim(file_restart))
+ CALL ncio_define_dimension(file_restart, 'ucatch', totalnumucat)
+ ENDIF
+
+ CALL vector_gather_and_write (&
+ wdsrf_ucat, numucat, totalnumucat, ucat_data_address, file_restart, 'wdsrf_ucat', 'ucatch')
+
+ CALL vector_gather_and_write (&
+ veloc_riv, numucat, totalnumucat, ucat_data_address, file_restart, 'veloc_riv', 'ucatch')
+
+ IF (DEF_Reservoir_Method > 0) THEN
+ IF (totalnumresv > 0) THEN
+
+ IF (p_is_root) CALL ncio_define_dimension(file_restart, 'reservoir', totalnumresv)
+
+ CALL vector_gather_and_write (&
+ volresv, numresv, totalnumresv, resv_data_address, file_restart, 'volresv', 'reservoir')
+ ENDIF
+ ENDIF
+#endif
+
+#ifdef GridRiverLakeSediment
+ IF (DEF_USE_SEDIMENT) THEN
+ CALL write_sediment_restart(file_restart)
+ ENDIF
+#endif
+
+ END SUBROUTINE WRITE_GridRiverLakeTimeVars
+
+#ifdef MPAS_EMBEDDED_COLM
+ SUBROUTINE write_gridriver_restart_mpas_embedded (file_restart)
+
+ USE mpi, only: MPI_INFO_NULL, MPI_OFFSET_KIND
+ USE pnetcdf
+ USE MOD_SPMD_Task, only: p_comm_compute
+ 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_volresv
+ logical :: write_reservoir
+
+ write_reservoir = DEF_Reservoir_Method > 0 .and. totalnumresv > 0
+
+ ierr = nf90mpi_create(p_comm_compute, 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)
+
+ 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, &
+ 'wdsrf_ucat', file_restart)
+ CALL pnetcdf_write_real8_points(ncid, var_veloc, ucat_ucid, veloc_riv, numucat, &
+ 'veloc_riv', file_restart)
+
+ IF (write_reservoir) THEN
+ CALL pnetcdf_write_real8_points(ncid, var_volresv, resv_global_index, volresv, numresv, &
+ '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, varname, filename)
+
+ USE mpi, only: MPI_OFFSET_KIND
+ USE pnetcdf, only: nf90mpi_put_var
+ USE MOD_SPMD_Task, only: CoLM_stop
+ IMPLICIT NONE
+
+ integer, intent(in) :: ncid
+ integer, intent(in) :: varid
+ integer, intent(in) :: index(:)
+ real(r8), intent(in) :: data(:)
+ integer, intent(in) :: ndata
+ character(len=*), intent(in) :: varname
+ character(len=*), intent(in) :: filename
+
+ integer :: ierr
+ integer :: i
+ integer(kind=MPI_OFFSET_KIND) :: start(1)
+ real(r8) :: value
+
+ IF (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) THEN
+ CALL CoLM_stop('PnetCDF indexed write invalid index for '//trim(varname))
+ ENDIF
+
+ start(1) = int(index(i), MPI_OFFSET_KIND)
+ value = data(i)
+ ierr = nf90mpi_put_var(ncid, varid, value, start=start)
+ CALL pnetcdf_check(ierr, 'write '//trim(varname), filename)
+ ENDDO
+
+ END SUBROUTINE pnetcdf_write_real8_points
+
+ SUBROUTINE pnetcdf_check(status, action, filename)
+
+ USE pnetcdf, only: NF90_NOERR, nf90mpi_strerror
+ USE MOD_SPMD_Task, 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
+#endif
+
+ SUBROUTINE deallocate_GridRiverLakeTimeVars
+
+ IMPLICIT NONE
+
+ IF (allocated (wdsrf_ucat)) deallocate (wdsrf_ucat)
+ IF (allocated (veloc_riv )) deallocate (veloc_riv )
+ IF (allocated (momen_riv )) deallocate (momen_riv )
+ IF (allocated (volresv )) deallocate (volresv )
+
+ 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..e5ef3018ca
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Hydro_SoilWater.F90
@@ -0,0 +1,3620 @@
+#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_SPMD_Task
+ IMPLICIT NONE
+
+ integer(8), SAVE :: count_implicit_accum = 0
+ integer(8), SAVE :: count_explicit_accum = 0
+ integer(8), SAVE :: count_wet2dry_accum = 0
+ integer :: iwork
+
+#ifdef CoLMDEBUG
+ IF (p_is_compute) THEN
+#ifdef USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, count_implicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_compute, p_err)
+ CALL mpi_allreduce (MPI_IN_PLACE, count_explicit, 1, MPI_INTEGER8, MPI_SUM, p_comm_compute, p_err)
+ CALL mpi_allreduce (MPI_IN_PLACE, count_wet2dry , 1, MPI_INTEGER8, MPI_SUM, p_comm_compute, p_err)
+#endif
+ IF (p_iam_compute == p_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
+
+#ifdef USEMPI
+ CALL mpi_send (count_implicit, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (count_explicit, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (count_wet2dry, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (count_implicit_accum, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (count_explicit_accum, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (count_wet2dry_accum, 1, MPI_INTEGER8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+#endif
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+
+#ifdef USEMPI
+ iwork = p_address_compute(p_root)
+ CALL mpi_recv (count_implicit, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (count_explicit, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (count_wet2dry , 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (count_implicit_accum, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (count_explicit_accum, 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (count_wet2dry_accum , 1, MPI_INTEGER8, iwork, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+#endif
+
+ 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/HYDRO/MOD_Vector_ReadWrite.F90 b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90
new file mode 100644
index 0000000000..35d7de3e75
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/HYDRO/MOD_Vector_ReadWrite.F90
@@ -0,0 +1,291 @@
+#include
+
+MODULE MOD_Vector_ReadWrite
+!-----------------------------------------------------------------------
+! DESCRIPTION:
+!
+! Read/Write data in vector form.
+!
+! Created by Shupeng Zhang, May 2023
+!-----------------------------------------------------------------------
+
+ PUBLIC :: vector_gather_and_write
+ PUBLIC :: vector_gather_map2grid_and_write
+ PUBLIC :: vector_read_and_scatter
+
+CONTAINS
+
+ ! -------
+ SUBROUTINE vector_gather_to_root ( &
+ vector, vlen, totalvlen, data_address, wdata)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: vector (:)
+ integer, intent(in) :: vlen
+ integer, intent(in) :: totalvlen
+
+ type(pointer_int32_1d), intent(in) :: data_address (0:)
+
+ real(r8), allocatable, intent(inout) :: wdata (:)
+
+ ! Local variables
+ integer :: iwork, mesg(2), isrc, ndata
+ real(r8), allocatable :: rcache(:)
+
+ IF (totalvlen <= 0) RETURN
+
+ IF (p_is_root) THEN
+ allocate (wdata (totalvlen))
+ ENDIF
+
+#ifdef COLM_PARALLEL
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+ mesg = (/p_iam_glb, vlen/)
+ CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ IF (vlen > 0) THEN
+ CALL mpi_send (vector, vlen, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+ IF (p_is_compute .and. vlen > 0) THEN
+ wdata(data_address(p_iam_compute)%val) = vector
+ ENDIF
+
+ DO iwork = 0, p_np_compute-1
+ IF (p_address_compute(iwork) == p_iam_glb) CYCLE
+
+ CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = mesg(1)
+ ndata = mesg(2)
+ IF (ndata > 0) THEN
+ allocate(rcache (ndata))
+
+ CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ wdata(data_address(p_itis_compute(isrc))%val) = rcache
+
+ deallocate (rcache)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ wdata(data_address(0)%val) = vector
+#endif
+
+ END SUBROUTINE vector_gather_to_root
+
+ ! -------
+ SUBROUTINE vector_gather_and_write ( vector, vlen, totalvlen, data_address, &
+ fileout, varname, dimname, itime_in_file, longname, units)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_DataType
+ USE MOD_NetCDFSerial
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: vector (:)
+ integer, intent(in) :: vlen
+ integer, intent(in) :: totalvlen
+
+ type(pointer_int32_1d), intent(in) :: data_address (0:)
+
+ character(len=*), intent(in) :: fileout
+ character(len=*), intent(in) :: varname
+ character(len=*), intent(in) :: dimname
+
+ integer, intent(in), optional :: itime_in_file
+ character(len=*), intent(in), optional :: longname
+ character(len=*), intent(in), optional :: units
+
+ ! Local variables
+ real(r8), allocatable :: wdata(:)
+ logical :: write_attr
+
+
+ CALL vector_gather_to_root (vector, vlen, totalvlen, data_address, wdata)
+
+ IF (p_is_root) THEN
+
+ IF (present(itime_in_file)) THEN
+ CALL ncio_write_serial_time (fileout, varname, itime_in_file, wdata, &
+ dimname, 'time', DEF_HIST_CompressLevel)
+ ELSE
+ CALL ncio_write_serial (fileout, varname, wdata, &
+ dimname, DEF_REST_CompressLevel)
+ ENDIF
+
+ IF (present(itime_in_file)) THEN
+ write_attr = itime_in_file <= 1
+ ELSE
+ write_attr = .true.
+ ENDIF
+
+ IF (write_attr) THEN
+ CALL ncio_put_attr (fileout, varname, 'missing_value', spval)
+ IF (present(longname)) CALL ncio_put_attr (fileout, varname, 'long_name', longname)
+ IF (present(units )) CALL ncio_put_attr (fileout, varname, 'units', units )
+ ENDIF
+
+ deallocate (wdata)
+
+ ENDIF
+
+ END SUBROUTINE vector_gather_and_write
+
+ ! -------
+ SUBROUTINE vector_gather_map2grid_and_write ( &
+ vector, vlen, totalvlen, data_address, nlon, x_vec, nlat, y_vec, &
+ fileout, varname, lon_name, lat_name, itime_in_file, longname, units)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_DataType
+ USE MOD_NetCDFSerial
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: fileout
+ real(r8), intent(in) :: vector (:)
+ integer, intent(in) :: vlen
+ integer, intent(in) :: totalvlen
+ character(len=*), intent(in) :: varname
+ character(len=*), intent(in) :: lon_name, lat_name
+
+ type(pointer_int32_1d), intent(in) :: data_address (0:)
+
+ integer, intent(in) :: nlon, x_vec (:)
+ integer, intent(in) :: nlat, y_vec (:)
+
+ integer, intent(in), optional :: itime_in_file
+ character(len=*), intent(in), optional :: longname
+ character(len=*), intent(in), optional :: units
+
+ ! Local variables
+ integer :: i
+ real(r8), allocatable :: wdata(:), wdata2d(:,:)
+ logical :: write_attr
+
+ CALL vector_gather_to_root (vector, vlen, totalvlen, data_address, wdata)
+
+ IF (p_is_root) THEN
+
+ allocate (wdata2d (nlon,nlat))
+ wdata2d(:,:) = spval
+
+ DO i = 1, totalvlen
+ wdata2d(x_vec(i),y_vec(i)) = wdata(i)
+ ENDDO
+
+ IF (present(itime_in_file)) THEN
+ CALL ncio_write_serial_time (fileout, varname, itime_in_file, wdata2d, &
+ lon_name, lat_name, 'time', DEF_HIST_CompressLevel)
+ ELSE
+ CALL ncio_write_serial (fileout, varname, wdata2d, &
+ lon_name, lat_name, DEF_REST_CompressLevel)
+ ENDIF
+
+ IF (present(itime_in_file)) THEN
+ write_attr = itime_in_file == 1
+ ELSE
+ write_attr = .true.
+ ENDIF
+
+ IF (write_attr) THEN
+ CALL ncio_put_attr (fileout, varname, 'missing_value', spval)
+ IF (present(longname)) CALL ncio_put_attr (fileout, varname, 'long_name', longname)
+ IF (present(units )) CALL ncio_put_attr (fileout, varname, 'units', units )
+ ENDIF
+
+ deallocate (wdata )
+ deallocate (wdata2d)
+
+ ENDIF
+
+ END SUBROUTINE vector_gather_map2grid_and_write
+
+ ! -----
+ SUBROUTINE vector_read_and_scatter ( &
+ filein, vector, vlen, varname, data_address)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_DataType
+ USE MOD_NetCDFSerial
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: filein
+ real(r8), allocatable, intent(inout) :: vector (:)
+ integer, intent(in) :: vlen
+ character(len=*), intent(in) :: varname
+ type(pointer_int32_1d), intent(in) :: data_address (0:)
+
+ ! Local variables
+ integer :: iwork, ndata
+ real(r8), allocatable :: rdata(:), rcache(:)
+
+ IF (p_is_root) THEN
+ CALL ncio_read_serial (filein, varname, rdata)
+ ENDIF
+
+#ifdef COLM_PARALLEL
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+ IF (p_is_root) THEN
+ DO iwork = 0, p_np_compute-1
+ IF (allocated(data_address(iwork)%val)) THEN
+
+ ndata = size(data_address(iwork)%val)
+ allocate(rcache (ndata))
+ rcache = rdata(data_address(iwork)%val)
+
+ IF (p_address_compute(iwork) == p_iam_glb) THEN
+ IF (ndata > 0) THEN
+ IF (.not. allocated(vector)) allocate(vector(ndata))
+ vector = rcache
+ ENDIF
+ ELSE
+ CALL mpi_send (rcache, ndata, MPI_REAL8, &
+ p_address_compute(iwork), mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ deallocate (rcache)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (p_is_compute .and. (.not. p_is_root)) THEN
+ IF (vlen > 0) THEN
+ IF (.not. allocated(vector)) allocate(vector(vlen))
+ CALL mpi_recv (vector, vlen, MPI_REAL8, p_address_root, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ IF (.not. allocated(vector)) allocate(vector(vlen))
+ vector = rdata(data_address(0)%val)
+#endif
+
+ IF (p_is_root) deallocate(rdata)
+
+ END SUBROUTINE vector_read_and_scatter
+
+END MODULE MOD_Vector_ReadWrite
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_CheckEquilibrium.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90
new file mode 100644
index 0000000000..d479bf8cea
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CheckEquilibrium.F90
@@ -0,0 +1,685 @@
+#include
+
+MODULE MOD_CheckEquilibrium
+
+!----------------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Check equilibrium state.
+!
+! Created by Shupeng Zhang, 10/2024
+!----------------------------------------------------------------------------
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Grid
+ USE netcdf
+ USE MOD_NetCDFSerial
+ USE MOD_SpatialMapping
+ USE MOD_Forcing, only: forcmask_pch
+ USE MOD_Vars_Global, only: spval
+
+ ! ----- Variables -----
+ integer :: nyearcheck
+
+ integer :: timestrlen
+ character(len=24) :: timeform
+
+ real(r8), allocatable :: tws_last (:)
+ real(r8), allocatable :: tws_this (:)
+
+ real(r8), allocatable :: prcp_year (:)
+ real(r8), allocatable :: et_year (:)
+ real(r8), allocatable :: rnof_year (:)
+ real(r8), allocatable :: rchg_year (:)
+
+ real(r8), allocatable :: patcharea (:) ! m^2
+
+ character(len=256) :: mesg_equilibrium
+
+#ifndef SinglePoint
+ type(grid_type) :: gridcheck
+ type(grid_concat_type) :: gcheck_concat
+ type(spatial_mapping_type) :: map_check
+
+ integer :: check_data_id = 0
+#endif
+
+ PUBLIC :: CheckEqb_init
+ PUBLIC :: CheckEquilibrium
+ PUBLIC :: CheckEqb_final
+
+CONTAINS
+
+ !-----------------------------------------------------------------------
+ SUBROUTINE CheckEqb_init (n_spinupcycle, lc_year)
+
+ USE MOD_Utils
+ USE MOD_Vars_Global, only: nl_soil
+ USE MOD_Forcing, only: gforc
+ USE MOD_LandPatch, only: numpatch, landpatch
+ USE MOD_Pixel, only: pixel
+ USE MOD_Mesh, only: mesh
+ USE MOD_Vars_TimeVariables, only: wdsrf, ldew, scv, wetwat, &
+ wliq_soisno, wice_soisno, wa
+ IMPLICIT NONE
+
+ integer, intent(in) :: n_spinupcycle
+ integer, intent(in) :: lc_year
+
+ ! Local Variable
+ integer :: ilev, ip, ie, ipxl
+ character(len=256) :: filename, cyear
+ real(r8) :: totaldtws, totalprcp, pct_dtws_prcp
+
+
+ IF (.not. DEF_CheckEquilibrium) RETURN
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ allocate (tws_last (numpatch)); tws_last (:) = spval;
+ allocate (tws_this (numpatch)); tws_this (:) = spval;
+ allocate (prcp_year (numpatch)); prcp_year(:) = spval;
+ allocate (et_year (numpatch)); et_year (:) = spval;
+ allocate (rnof_year (numpatch)); rnof_year(:) = spval;
+ allocate (rchg_year (numpatch)); rchg_year(:) = spval;
+
+ ENDIF
+ ENDIF
+
+ IF (n_spinupcycle >= 10000) THEN
+ timestrlen = 16
+ timeform = "('spinup',I5.5,'-',I4.4)"
+ ELSEIF (n_spinupcycle >= 1000) THEN
+ timestrlen = 15
+ timeform = "('spinup',I4.4,'-',I4.4)"
+ ELSEIF (n_spinupcycle >= 100) THEN
+ timestrlen = 14
+ timeform = "('spinup',I3.3,'-',I4.4)"
+ ELSEIF (n_spinupcycle >= 10) THEN
+ timestrlen = 13
+ timeform = "('spinup',I2.2,'-',I4.4)"
+ ELSE
+ timestrlen = 12
+ timeform = "('spinup',I1.1,'-',I4.4)"
+ ENDIF
+
+ mesg_equilibrium = ''
+
+#ifndef SinglePoint
+ ! grid
+#ifdef GRIDBASED
+ write(cyear,'(i4.4)') lc_year
+ filename = trim(DEF_dir_landdata) // '/mesh/' //trim(cyear) // '/mesh.nc'
+ CALL gridcheck%define_from_file (filename)
+#else
+ CALL gridcheck%define_by_copy (gforc)
+#endif
+ ! grid info for output
+ CALL gcheck_concat%set (gridcheck)
+ ! mapping from patch to grid
+ CALL map_check%build_arealweighted (gridcheck, landpatch)
+#endif
+
+ IF ((p_is_compute) .and. (numpatch > 0)) THEN
+ tws_last = wdsrf ! 1. surface water
+ CALL add_spv (ldew, tws_last) ! 2. water on foliage
+ CALL add_spv (scv , tws_last) ! 3. snow cover water equivalent
+ IF (DEF_USE_VariablySaturatedFlow) THEN
+ CALL add_spv (wetwat, tws_last) ! 4. water in wetland
+ ENDIF
+ DO ilev = 1, nl_soil
+ CALL add_spv (wliq_soisno(ilev,:), tws_last) ! 5. liquid water in soil
+ CALL add_spv (wice_soisno(ilev,:), tws_last) ! 6. ice in soil
+ ENDDO
+ CALL add_spv (wa, tws_last) ! 7. water in aquifer
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ IF (numpatch > 0) THEN
+ allocate (patcharea (numpatch))
+ patcharea(:) = 0.
+ DO ip = 1, numpatch
+ ie = landpatch%ielm(ip)
+ DO ipxl = landpatch%ipxstt(ip), landpatch%ipxend(ip)
+ patcharea(ip) = patcharea(ip) + 1.0e6 * 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 (landpatch%has_shared) THEN
+ patcharea(ip) = patcharea(ip) * landpatch%pctshared(ip)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ENDIF
+
+ nyearcheck = 0
+
+ END SUBROUTINE CheckEqb_init
+
+ !-----------------------------------------------------------------------
+ SUBROUTINE CheckEqb_final ()
+
+ IMPLICIT NONE
+
+ IF (.not. DEF_CheckEquilibrium) RETURN
+
+ IF (allocated(tws_last )) deallocate(tws_last )
+ IF (allocated(tws_this )) deallocate(tws_this )
+ IF (allocated(prcp_year)) deallocate(prcp_year)
+ IF (allocated(et_year )) deallocate(et_year )
+ IF (allocated(rnof_year)) deallocate(rnof_year)
+ IF (allocated(rchg_year)) deallocate(rchg_year)
+ IF (allocated(patcharea)) deallocate(patcharea)
+
+ END SUBROUTINE CheckEqb_final
+
+ !-----------------------------------------------------------------------
+ SUBROUTINE CheckEquilibrium ( &
+ idate, deltim, i_spinupcycle, is_spinup, dir_out, casename)
+
+ USE MOD_Precision
+ USE MOD_TimeManager
+ USE MOD_DataType
+ USE MOD_LandPatch, only: numpatch
+ USE MOD_Vars_Global, only: nl_soil
+ USE MOD_Vars_1DForcing, only: forc_prc, forc_prl
+ USE MOD_Vars_1DFluxes, only: fevpa, rnof, rsur
+ USE MOD_Vars_TimeInvariants, only: patchtype, patchmask
+ USE MOD_Vars_TimeVariables, only: wdsrf, ldew, scv, wetwat, wliq_soisno, &
+ wice_soisno, wa, zwt
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: idate(3)
+ real(r8), intent(in) :: deltim
+ integer, intent(in) :: i_spinupcycle
+ logical, intent(in) :: is_spinup
+
+ character(len=*), intent(in) :: dir_out
+ character(len=*), intent(in) :: casename
+
+ ! Local variables
+ logical :: docheck
+ integer :: ilev
+ character(len=256) :: filename, timestr
+ integer :: ncid, time_id, str_id, varid
+ real(r8) :: totaldtws, totalprcp, pct_dtws_prcp
+
+ real(r8), allocatable :: rchg (:)
+ real(r8), allocatable :: dtws (:)
+ logical, allocatable :: filter (:)
+ real(r8), allocatable :: vecone (:)
+ type(block_data_real8_2d) :: sumarea
+
+
+ IF (.not. DEF_CheckEquilibrium) RETURN
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ CALL add_spv (forc_prc, prcp_year, deltim)
+ CALL add_spv (forc_prl, prcp_year, deltim)
+ CALL add_spv (fevpa, et_year, deltim)
+ CALL add_spv (rnof, rnof_year, deltim)
+
+ allocate (rchg (numpatch))
+ rchg = spval
+ WHERE ((forc_prc /= spval) .and. (forc_prl /= spval) .and. (fevpa /= spval) .and. (rsur /= spval))
+ rchg = forc_prc + forc_prl - fevpa - rsur
+ END WHERE
+
+ CALL add_spv (rchg, rchg_year, deltim)
+
+ deallocate (rchg)
+ ENDIF
+ ENDIF
+
+ docheck = isendofyear (idate, deltim)
+
+ IF (docheck) THEN
+
+ IF ((p_is_compute) .and. (numpatch > 0)) THEN
+ tws_this = wdsrf ! 1. surface water
+ CALL add_spv (ldew, tws_this) ! 2. water on foliage
+ CALL add_spv (scv , tws_this) ! 3. snow cover water equivalent
+ IF (DEF_USE_VariablySaturatedFlow) THEN
+ CALL add_spv (wetwat, tws_this) ! 4. water in wetland
+ ENDIF
+ DO ilev = 1, nl_soil
+ CALL add_spv (wliq_soisno(ilev,:), tws_this) ! 5. liquid water in soil
+ CALL add_spv (wice_soisno(ilev,:), tws_this) ! 6. ice in soil
+ ENDDO
+ CALL add_spv (wa, tws_this) ! 7. water in aquifer
+ ENDIF
+
+ nyearcheck = nyearcheck + 1
+
+ IF (nyearcheck >= 1) THEN
+
+ IF (p_is_compute) THEN
+
+ totaldtws = 0.
+ totalprcp = 0.
+
+ IF (numpatch > 0) THEN
+
+ allocate (filter (numpatch))
+ filter = patchmask
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+#ifdef CatchLateralFlow
+ filter = filter .and. (patchtype <= 4)
+#else
+ filter = filter .and. (patchtype <= 2)
+#endif
+
+ allocate (dtws (numpatch))
+ WHERE (filter)
+ dtws = tws_this - tws_last
+ ELSEWHERE
+ dtws = spval
+ END WHERE
+
+ IF (any(filter)) THEN
+ totaldtws = sum(dtws*patcharea, mask=filter)
+ totalprcp = sum(prcp_year*patcharea, mask=filter)
+ ENDIF
+
+ allocate (vecone (numpatch))
+ vecone(:) = 1.
+
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, totaldtws, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err)
+ CALL mpi_allreduce (MPI_IN_PLACE, totalprcp, 1, MPI_REAL8, MPI_SUM, p_comm_compute, p_err)
+
+ IF (totalprcp > 0.) THEN
+ pct_dtws_prcp = totaldtws/totalprcp
+ ELSE
+ pct_dtws_prcp = spval
+ ENDIF
+
+ IF (p_iam_compute == p_root) THEN
+ CALL mpi_send (pct_dtws_prcp, 1, MPI_REAL8, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ ENDIF
+#endif
+ ENDIF
+
+ IF (p_is_root) THEN
+
+ IF (is_spinup) THEN
+ write(timestr,timeform) i_spinupcycle, idate(1)
+ ELSE
+ write(timestr,'(I4.4)') idate(1)
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_recv (pct_dtws_prcp, 1, MPI_REAL8, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+#endif
+ IF (pct_dtws_prcp /= spval) THEN
+ write(mesg_equilibrium,'(A,F0.2,3A)') 'Total delTWS/precipitation is ', &
+ pct_dtws_prcp*100., '% in ', trim(timestr), '. Check history for detail.'
+ ELSE
+ write(mesg_equilibrium,'(3A)') 'Precipitation is 0 ', trim(timestr), '.'
+ ENDIF
+
+ filename = trim(dir_out) // '/' // trim(casename) //'_check_equilibrium.nc'
+
+ IF (nyearcheck == 1) THEN
+
+ CALL ncio_create_file (trim(filename))
+
+ CALL ncio_define_dimension(filename, 'iyear', 0)
+ CALL ncio_define_dimension(filename, 'timestr', timestrlen)
+
+ CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) )
+ CALL nccheck( nf90_inq_dimid(ncid, 'iyear', time_id) )
+ CALL nccheck( nf90_inq_dimid(ncid, 'timestr', str_id ) )
+ CALL nccheck( nf90_redef(ncid) )
+ CALL nccheck( nf90_def_var(ncid, 'iyear', NF90_CHAR, (/str_id,time_id/), varid) )
+ CALL nccheck( nf90_put_att(ncid, varid, 'long_name', 'iyear in all spinup cycles') )
+ CALL nccheck( nf90_enddef(ncid) )
+ CALL nccheck( nf90_close(ncid) )
+
+#ifndef SinglePoint
+ CALL ncio_define_dimension(filename, 'lat' , gcheck_concat%ginfo%nlat)
+ CALL ncio_define_dimension(filename, 'lon' , gcheck_concat%ginfo%nlon)
+
+ CALL ncio_write_serial (filename, 'lat', gcheck_concat%ginfo%lat_c, 'lat')
+ CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude')
+ CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north')
+
+ CALL ncio_write_serial (filename, 'lon', gcheck_concat%ginfo%lon_c, 'lon')
+ CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude')
+ CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east')
+#else
+ CALL ncio_define_dimension(filename, 'patch', numpatch)
+#endif
+
+ ENDIF
+
+ CALL nccheck( nf90_open(trim(filename), NF90_WRITE, ncid) )
+ CALL nccheck( nf90_inq_varid(ncid, 'iyear', varid) )
+ CALL nccheck( nf90_put_var(ncid, varid, timestr(1:timestrlen), &
+ (/1,nyearcheck/), (/timestrlen,1/)) )
+ CALL nccheck( nf90_close(ncid) )
+
+ ENDIF
+
+#ifndef SinglePoint
+ IF (p_is_active) CALL allocate_block_data (gridcheck, sumarea)
+
+ CALL map_check%get_sumarea (sumarea, filter)
+
+ IF (nyearcheck == 1) THEN
+ CALL map_and_write_check_var ( &
+ vecone, filename, 'landarea', -1, sumarea, filter, &
+ 'area of land excluding water bodies and glaciers in grid', 'km^2', &
+ amount_in_grid = .true.)
+ ENDIF
+
+ CALL map_and_write_check_var ( &
+ dtws, filename, 'tws_change', nyearcheck, sumarea, filter, &
+ 'Change in terrestrial water storage', 'mm')
+ CALL map_and_write_check_var ( &
+ prcp_year, filename, 'total_precipitation', nyearcheck, sumarea, filter, &
+ 'total precipitation in a year', 'mm')
+ CALL map_and_write_check_var ( &
+ et_year, filename, 'total_evapotranspiration', nyearcheck, sumarea, filter, &
+ 'total evapotranspiration in a year', 'mm')
+ CALL map_and_write_check_var ( &
+ rnof_year, filename, 'total_runoff', nyearcheck, sumarea, filter, &
+ 'total runoff in a year', 'mm')
+ CALL map_and_write_check_var ( &
+ rchg_year, filename, 'total_recharge', nyearcheck, sumarea, filter, &
+ 'total recharge to ground water in a year', 'mm')
+ CALL map_and_write_check_var ( &
+ zwt, filename, 'zwt', nyearcheck, sumarea, filter, &
+ 'depth to water table', 'm')
+#else
+ CALL ncio_write_serial_time (filename, 'tws_change', &
+ nyearcheck, dtws, 'patch', 'iyear')
+ IF (nyearcheck == 1) THEN
+ CALL ncio_put_attr (filename, 'tws_change', 'long_name', &
+ 'Change in terrestrial water storage')
+ CALL ncio_put_attr (filename, 'tws_change', 'units', 'mm')
+ CALL ncio_put_attr (filename, 'tws_change', 'missing_value', spval)
+ ENDIF
+
+ CALL ncio_write_serial_time (filename, 'total_precipitation', &
+ nyearcheck, prcp_year, 'patch', 'iyear')
+ IF (nyearcheck == 1) THEN
+ CALL ncio_put_attr (filename, 'total_precipitation', 'long_name', &
+ 'total precipitation in a year')
+ CALL ncio_put_attr (filename, 'total_precipitation', 'units', 'mm')
+ CALL ncio_put_attr (filename, 'total_precipitation', 'missing_value', spval)
+ ENDIF
+
+ CALL ncio_write_serial_time (filename, 'total_evapotranspiration', &
+ nyearcheck, et_year, 'patch', 'iyear')
+ IF (nyearcheck == 1) THEN
+ CALL ncio_put_attr (filename, 'total_evapotranspiration', 'long_name', &
+ 'total evapotranspiration in a year')
+ CALL ncio_put_attr (filename, 'total_evapotranspiration', 'units', 'mm')
+ CALL ncio_put_attr (filename, 'total_evapotranspiration', 'missing_value', spval)
+ ENDIF
+
+ CALL ncio_write_serial_time (filename, 'total_runoff', &
+ nyearcheck, rnof_year, 'patch', 'iyear')
+ IF (nyearcheck == 1) THEN
+ CALL ncio_put_attr (filename, 'total_runoff', 'long_name', &
+ 'total runoff in a year')
+ CALL ncio_put_attr (filename, 'total_runoff', 'units', 'mm')
+ CALL ncio_put_attr (filename, 'total_runoff', 'missing_value', spval)
+ ENDIF
+
+ CALL ncio_write_serial_time (filename, 'total_recharge', &
+ nyearcheck, rchg_year, 'patch', 'iyear')
+ IF (nyearcheck == 1) THEN
+ CALL ncio_put_attr (filename, 'total_recharge', 'long_name', &
+ 'total recharge to ground water in a year')
+ CALL ncio_put_attr (filename, 'total_recharge', 'units', 'mm')
+ CALL ncio_put_attr (filename, 'total_recharge', 'missing_value', spval)
+ ENDIF
+
+ CALL ncio_write_serial_time (filename, 'zwt', &
+ nyearcheck, zwt, 'patch', 'iyear')
+ IF (nyearcheck == 1) THEN
+ CALL ncio_put_attr (filename, 'zwt', 'long_name', 'depth to water table')
+ CALL ncio_put_attr (filename, 'zwt', 'units', 'm')
+ CALL ncio_put_attr (filename, 'zwt', 'missing_value', spval)
+ ENDIF
+#endif
+ ENDIF
+
+ IF ((p_is_compute) .and. (numpatch > 0)) THEN
+ prcp_year(:) = spval
+ et_year (:) = spval
+ rnof_year(:) = spval
+ rchg_year(:) = spval
+ tws_last = tws_this
+ ENDIF
+
+ IF (allocated(dtws )) deallocate(dtws )
+ IF (allocated(filter)) deallocate(filter)
+ IF (allocated(vecone)) deallocate(vecone)
+
+ ENDIF
+
+ END SUBROUTINE CheckEquilibrium
+
+ !-----------------------------------------------------------------------
+#ifndef SinglePoint
+ SUBROUTINE map_and_write_check_var ( &
+ vector, filename, varname, itime_in_file, sumarea, filter, &
+ longname, units, amount_in_grid)
+
+ USE MOD_Block
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: vector(:)
+
+ character(len=*), intent(in) :: filename
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ logical, intent(in), optional :: amount_in_grid
+
+ type(block_data_real8_2d), intent(in) :: sumarea
+ logical, intent(in) :: filter(:)
+
+ ! Local variables
+ type(block_data_real8_2d) :: data_xy_2d
+ integer :: xblk, yblk, xloc, yloc, xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp
+ integer :: iblkme, iblk, jblk, idata, ixseg, iyseg
+ integer :: rmesg(3), smesg(3), isrc
+ real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:)
+ logical :: amount
+
+ IF (p_is_active) CALL allocate_block_data (gridcheck, data_xy_2d)
+ CALL map_check%pset2grid (vector, data_xy_2d, spv = spval, msk = filter)
+
+ amount = .false.
+ IF (present(amount_in_grid)) amount = amount_in_grid
+
+ IF (.not. amount) THEN
+ IF (p_is_active) THEN
+ DO iblkme = 1, gblock%nblkme
+ xblk = gblock%xblkme(iblkme)
+ yblk = gblock%yblkme(iblkme)
+
+ DO yloc = 1, gridcheck%ycnt(yblk)
+ DO xloc = 1, gridcheck%xcnt(xblk)
+
+ IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN
+ IF (data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN
+ data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) &
+ = data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) &
+ / sumarea%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+ ELSE
+ data_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDDO
+ ENDIF
+ ENDIF
+
+ check_data_id = mod(check_data_id,100) + 1
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_root) THEN
+
+ allocate (vdata (gcheck_concat%ginfo%nlon, gcheck_concat%ginfo%nlat))
+ vdata(:,:) = spval
+
+#ifdef USEMPI
+ DO idata = 1, gcheck_concat%ndatablk
+ CALL mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, &
+ check_data_id, p_comm_glb, p_stat, p_err)
+
+ isrc = rmesg(1)
+ ixseg = rmesg(2)
+ iyseg = rmesg(3)
+
+ xgdsp = gcheck_concat%xsegs(ixseg)%gdsp
+ ygdsp = gcheck_concat%ysegs(iyseg)%gdsp
+ xcnt = gcheck_concat%xsegs(ixseg)%cnt
+ ycnt = gcheck_concat%ysegs(iyseg)%cnt
+
+ allocate (rbuf(xcnt,ycnt))
+
+ CALL mpi_recv (rbuf, xcnt*ycnt, MPI_REAL8, &
+ isrc, check_data_id, p_comm_glb, p_stat, p_err)
+
+ vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = rbuf
+ deallocate (rbuf)
+
+ ENDDO
+#else
+ DO iyseg = 1, gcheck_concat%nyseg
+ DO ixseg = 1, gcheck_concat%nxseg
+ iblk = gcheck_concat%xsegs(ixseg)%blk
+ jblk = gcheck_concat%ysegs(iyseg)%blk
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+ xbdsp = gcheck_concat%xsegs(ixseg)%bdsp
+ ybdsp = gcheck_concat%ysegs(iyseg)%bdsp
+ xgdsp = gcheck_concat%xsegs(ixseg)%gdsp
+ ygdsp = gcheck_concat%ysegs(iyseg)%gdsp
+ xcnt = gcheck_concat%xsegs(ixseg)%cnt
+ ycnt = gcheck_concat%ysegs(iyseg)%cnt
+
+ vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = &
+ data_xy_2d%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt)
+ ENDIF
+ ENDDO
+ ENDDO
+#endif
+
+ IF (itime_in_file >= 1) THEN
+ CALL ncio_write_serial_time (filename, varname, itime_in_file, vdata, &
+ 'lon', 'lat', 'iyear', compress = 1)
+ ELSE
+ CALL ncio_write_serial (filename, varname, vdata, 'lon', 'lat', compress = 1)
+ ENDIF
+
+ IF (itime_in_file <= 1) THEN
+ CALL ncio_put_attr (filename, varname, 'long_name', longname)
+ CALL ncio_put_attr (filename, varname, 'units', units)
+ CALL ncio_put_attr (filename, varname, 'missing_value', spval)
+ ENDIF
+
+ deallocate (vdata)
+
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_active) THEN
+ DO iyseg = 1, gcheck_concat%nyseg
+ DO ixseg = 1, gcheck_concat%nxseg
+
+ iblk = gcheck_concat%xsegs(ixseg)%blk
+ jblk = gcheck_concat%ysegs(iyseg)%blk
+
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+
+ xbdsp = gcheck_concat%xsegs(ixseg)%bdsp
+ ybdsp = gcheck_concat%ysegs(iyseg)%bdsp
+ xcnt = gcheck_concat%xsegs(ixseg)%cnt
+ ycnt = gcheck_concat%ysegs(iyseg)%cnt
+
+ allocate (sbuf (xcnt,ycnt))
+ sbuf = data_xy_2d%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt)
+
+ smesg = (/p_iam_glb, ixseg, iyseg/)
+ CALL mpi_send (smesg, 3, MPI_INTEGER, &
+ p_address_root, check_data_id, p_comm_glb, p_err)
+ CALL mpi_send (sbuf, xcnt*ycnt, MPI_REAL8, &
+ p_address_root, check_data_id, p_comm_glb, p_err)
+
+ deallocate (sbuf)
+
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+#endif
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ END SUBROUTINE map_and_write_check_var
+#endif
+
+ !-----------------------------------------------------------------------
+ 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_CheckEquilibrium
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_CropReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90
new file mode 100644
index 0000000000..cafdfd6086
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_CropReadin.F90
@@ -0,0 +1,377 @@
+#include
+
+#ifdef CROP
+MODULE MOD_CropReadin
+
+!-----------------------------------------------------------------------
+ USE MOD_Precision
+ IMPLICIT NONE
+ SAVE
+
+ ! PUBLIC MEMBER FUNCTIONS:
+ PUBLIC :: CROP_readin
+
+CONTAINS
+
+ SUBROUTINE CROP_readin ()
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+! Read in crop planting date from data, and fertilization from data.
+! Save these data in patch vector.
+!
+! Original: Shupeng Zhang, Zhongwang Wei, and Xingjie Lu, 2022
+!
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Namelist
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch
+ USE MOD_NetCDFSerial
+ USE MOD_NetCDFBlock
+ USE MOD_SpatialMapping
+ USE MOD_Vars_TimeInvariants
+ USE MOD_Vars_TimeVariables
+
+ USE MOD_Vars_Global
+ USE MOD_LandPFT
+ USE MOD_Vars_PFTimeVariables
+ USE MOD_RangeCheck
+ USE MOD_Block
+
+ IMPLICIT NONE
+
+ character(len=256) :: file_crop
+ type(grid_type) :: grid_crop
+ type(block_data_real8_2d) :: f_xy_crop
+ type(spatial_mapping_type) :: mg2patch_crop
+ type(spatial_mapping_type) :: mg2pft_crop
+ character(len=256) :: file_irrig
+ type(grid_type) :: grid_irrig
+ type(block_data_int32_2d) :: f_xy_irrig
+ type(spatial_mapping_type) :: mg2pft_irrig
+
+ character(len=256) :: file_irrigalloc
+ type(grid_type) :: grid_irrigalloc
+ type(block_data_real8_2d) :: f_xy_irrigalloc
+ type(spatial_mapping_type) :: mg2p_irrigalloc
+
+ character(len=256) :: file_fert
+ type(grid_type) :: grid_fert
+ type(block_data_real8_2d) :: f_xy_fert
+ type(spatial_mapping_type) :: mg2pft_fert
+
+ real(r8),allocatable :: pdrice2_tmp (:)
+ real(r8),allocatable :: plantdate_tmp (:)
+ real(r8),allocatable :: fertnitro_tmp (:)
+ integer ,allocatable :: irrig_method_tmp (:)
+
+ real(r8),allocatable :: fertilizer_tmp (:)
+ real(r8),allocatable :: manure_tmp (:)
+
+ ! Local variables
+ real(r8), allocatable :: lat(:), lon(:)
+ real(r8) :: missing_value
+ integer :: cft, npatch, ipft
+ character(len=2) :: cx
+ integer :: iblkme, iblk, jblk
+ integer :: maxvalue, minvalue
+
+ ! READ in crops
+
+ file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc'
+
+ CALL ncio_read_bcast_serial (file_crop, 'lat', lat)
+ CALL ncio_read_bcast_serial (file_crop, 'lon', lon)
+
+ CALL grid_crop%define_by_center (lat, lon)
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (grid_crop, f_xy_crop)
+ ENDIF
+
+ ! missing value
+ IF (p_is_root) THEN
+ CALL ncio_get_attr (file_crop, 'pdrice2', 'missing_value', missing_value)
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_bcast (missing_value, 1, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+#endif
+ IF (p_is_active) THEN
+ CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop)
+ ENDIF
+
+ CALL mg2patch_crop%build_arealweighted (grid_crop, landpatch)
+ CALL mg2patch_crop%set_missing_value (f_xy_crop, missing_value)
+
+ CALL mg2pft_crop%build_arealweighted (grid_crop, landpft)
+ CALL mg2pft_crop%set_missing_value (f_xy_crop, missing_value)
+
+ IF (allocated(lon)) deallocate(lon)
+ IF (allocated(lat)) deallocate(lat)
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) allocate(pdrice2_tmp (numpatch))
+ IF (numpft > 0) allocate(plantdate_tmp (numpft))
+ IF (numpft > 0) allocate(fertnitro_tmp (numpft))
+ IF (numpft > 0) allocate(irrig_method_tmp (numpft))
+ ENDIF
+
+ ! (1) Read in plant date for rice2.
+ file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc'
+ IF (p_is_active) THEN
+ CALL ncio_read_block (file_crop, 'pdrice2', grid_crop, f_xy_crop)
+ ENDIF
+
+ CALL mg2patch_crop%grid2pset (f_xy_crop, pdrice2_tmp)
+
+ IF (p_is_compute) THEN
+ DO npatch = 1, numpatch
+ IF (pdrice2_tmp(npatch) /= spval) THEN
+ pdrice2 (npatch) = int(pdrice2_tmp (npatch))
+ ELSE
+ pdrice2 (npatch) = 0
+ ENDIF
+ ENDDO
+ ENDIF
+
+#ifdef RangeCheck
+ CALL check_vector_data ('plant date value for rice2 ', pdrice2)
+#endif
+
+ ! (2) Read in plant date.
+ IF (p_is_compute) THEN
+ IF (numpft > 0) plantdate_p(:) = -99999999._r8
+ ENDIF
+
+ file_crop = trim(DEF_dir_runtime) // '/crop/plantdt-colm-64cfts-rice2_fillcoast.nc'
+ DO cft = 15, 78
+ write(cx, '(i2.2)') cft
+ IF (p_is_active) THEN
+ CALL ncio_read_block_time (file_crop, &
+ 'PLANTDATE_CFT_'//trim(cx), grid_crop, 1, f_xy_crop)
+ ENDIF
+
+ CALL mg2pft_crop%grid2pset (f_xy_crop, plantdate_tmp)
+
+ IF (p_is_compute) THEN
+ DO ipft = 1, numpft
+ IF(landpft%settyp(ipft) .eq. cft)THEN
+ plantdate_p(ipft) = plantdate_tmp(ipft)
+ IF(plantdate_p(ipft) <= 0._r8) THEN
+ plantdate_p(ipft) = -99999999._r8
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+#ifdef RangeCheck
+ CALL check_vector_data ('plantdate_pfts value ', plantdate_p)
+#endif
+
+ ! (3) Read in fertlization
+ IF (DEF_FERT_SOURCE == 1) THEN
+ IF (p_is_compute) THEN
+ IF (numpft > 0) fertnitro_p(:) = -99999999._r8
+ ENDIF
+
+ file_fert = trim(DEF_dir_runtime) // '/crop/fertnitro_fillcoast.nc'
+ DO cft = 15, 78
+ write(cx, '(i2.2)') cft
+ IF (p_is_active) THEN
+ CALL ncio_read_block_time (file_fert, &
+ 'CONST_FERTNITRO_CFT_'//trim(cx), grid_crop, 1, f_xy_crop)
+ ENDIF
+
+ CALL mg2pft_crop%grid2pset (f_xy_crop, fertnitro_tmp)
+
+ IF (p_is_compute) THEN
+ DO ipft = 1, numpft
+ IF(landpft%settyp(ipft) .eq. cft)THEN
+ fertnitro_p(ipft) = fertnitro_tmp(ipft)
+ IF(fertnitro_p(ipft) <= 0._r8) THEN
+ fertnitro_p(ipft) = 0._r8
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ ELSEIF (DEF_FERT_SOURCE == 2)THEN
+ IF (p_is_compute) THEN
+ IF (numpft > 0) THEN
+ allocate(fertilizer_tmp(numpft))
+ allocate(manure_tmp(numpft))
+ ENDIF
+ ENDIF
+
+ file_fert = trim(DEF_dir_runtime) // '/crop/fertilizer_2015soc.nc'
+
+ CALL ncio_read_bcast_serial (file_fert, 'lat', lat)
+ CALL ncio_read_bcast_serial (file_fert, 'lon', lon)
+ CALL grid_fert%define_by_center (lat, lon)
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (grid_fert, f_xy_fert)
+ ENDIF
+
+ CALL mg2pft_fert%build_arealweighted (grid_fert, landpft)
+
+ IF (allocated(lon)) deallocate(lon)
+ IF (allocated(lat)) deallocate(lat)
+
+ IF (p_is_compute) THEN
+ fertnitro_p(:) = -99999999._r8
+ manunitro_p(:) = -99999999._r8
+ ENDIF
+
+ ! read manure
+ IF (p_is_active) THEN
+ CALL ncio_read_block (file_fert, 'manure', grid_fert, f_xy_fert)
+ ENDIF
+
+ CALL mg2pft_fert%grid2pset (f_xy_fert, manure_tmp)
+
+ IF (p_is_compute) THEN
+ DO ipft = 1, numpft
+ IF (landpft%settyp(ipft) .ge. 15) THEN
+ manunitro_p(ipft) = manure_tmp(ipft)
+ IF (manunitro_p(ipft) < 0._r8) THEN
+ manunitro_p(ipft) = 0._r8
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ! read fertilizer
+ DO cft = 1, 64
+ IF (p_is_active) THEN
+ CALL ncio_read_block_time (file_fert, 'fertilizer', grid_fert, cft, f_xy_fert)
+ ENDIF
+
+ CALL mg2pft_fert%grid2pset (f_xy_fert, fertilizer_tmp)
+
+ IF (p_is_compute) THEN
+ DO ipft = 1, numpft
+ IF (landpft%settyp(ipft) .eq. cft+14) THEN
+ fertnitro_p(ipft) = fertilizer_tmp(ipft)
+ IF (fertnitro_p(ipft) < 0._r8) THEN
+ fertnitro_p(ipft) = 0._r8
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ IF (allocated (fertilizer_tmp)) deallocate(fertilizer_tmp)
+ IF (allocated (manure_tmp)) deallocate(manure_tmp)
+ ENDIF
+
+#ifdef RangeCheck
+ CALL check_vector_data ('fert nitro value ', fertnitro_p)
+#endif
+
+ ! (4) Read in irrigation method
+ !file_irrig = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_method.nc'
+ file_irrig = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_method_96x144.nc'
+
+ CALL ncio_read_bcast_serial (file_irrig, 'lat', lat)
+ CALL ncio_read_bcast_serial (file_irrig, 'lon', lon)
+
+ CALL grid_irrig%define_by_center (lat, lon)
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (grid_irrig, f_xy_irrig)
+ ENDIF
+
+ CALL mg2pft_irrig%build_arealweighted (grid_irrig, landpft)
+
+ IF (allocated(lon)) deallocate(lon)
+ IF (allocated(lat)) deallocate(lat)
+
+ IF (p_is_compute) THEN
+ IF (numpft > 0) irrig_method_p(:) = -99999999
+ ENDIF
+
+ DO cft = 1, N_CFT
+ IF (p_is_active) THEN
+ CALL ncio_read_block_time (file_irrig, 'irrigation_method', grid_irrig, cft, f_xy_irrig)
+ ENDIF
+
+ CALL mg2pft_irrig%grid2pset_dominant (f_xy_irrig, irrig_method_tmp)
+
+ IF (p_is_compute) THEN
+ DO ipft = 1, numpft
+
+ IF(landpft%settyp(ipft) .eq. cft + 14)THEN
+ irrig_method_p(ipft) = irrig_method_tmp(ipft)
+ IF(irrig_method_p(ipft) < 0) THEN
+ irrig_method_p(ipft) = -99999999
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+#ifdef RangeCheck
+ CALL check_vector_data ('irrigation method ', irrig_method_p)
+#endif
+
+ IF (allocated (pdrice2_tmp )) deallocate(pdrice2_tmp )
+ IF (allocated (plantdate_tmp)) deallocate(plantdate_tmp)
+ IF (allocated (fertnitro_tmp)) deallocate(fertnitro_tmp)
+ IF (allocated (irrig_method_tmp)) deallocate(irrig_method_tmp)
+
+ IF (DEF_IRRIGATION_ALLOCATION == 3) THEN
+ ! (5) Read in irrigation allocated to groundwater
+ file_irrigalloc = trim(DEF_dir_runtime) // '/crop/surfdata_irrigation_allocation.nc'
+
+ CALL ncio_read_bcast_serial (file_irrigalloc, 'lat', lat)
+ CALL ncio_read_bcast_serial (file_irrigalloc, 'lon', lon)
+
+ CALL grid_irrigalloc%define_by_center (lat, lon)
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (grid_irrigalloc, f_xy_irrigalloc)
+ ENDIF
+
+ call mg2p_irrigalloc%build_arealweighted (grid_irrigalloc, landpatch)
+
+ IF (allocated(lon)) deallocate(lon)
+ IF (allocated(lat)) deallocate(lat)
+
+ IF (p_is_compute) THEN
+ irrig_gw_alloc(:) = 0._r8
+ ENDIF
+
+ IF (p_is_active) THEN
+ CALL ncio_read_block (file_irrigalloc, 'irrig_gw_alloc', grid_irrigalloc, f_xy_irrigalloc)
+ ENDIF
+
+ call mg2p_irrigalloc%grid2pset (f_xy_irrigalloc, irrig_gw_alloc)
+
+#ifdef RangeCheck
+ CALL check_vector_data ('irrigation goundwater allocation ', irrig_gw_alloc)
+#endif
+
+ ! (6) Read in irrigation allocated to surfacewater
+ IF (p_is_compute) THEN
+ irrig_sw_alloc(:) = 0._r8
+ ENDIF
+
+ IF (p_is_active) THEN
+ CALL ncio_read_block (file_irrigalloc, 'irrig_sw_alloc', grid_irrigalloc, f_xy_irrigalloc)
+ ENDIF
+
+ call mg2p_irrigalloc%grid2pset (f_xy_irrigalloc, irrig_sw_alloc)
+
+#ifdef RangeCheck
+ CALL check_vector_data ('irrigation surfacewater allocation ', irrig_sw_alloc)
+#endif
+ ENDIF
+
+ END SUBROUTINE CROP_readin
+
+END MODULE MOD_CropReadin
+#endif
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..153f26922b
--- /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_SPMD_Task
+ 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 (p_is_active) THEN
+ CALL allocate_block_data (grid_fire, f_xy_fire)
+ ENDIF
+
+ file_fire = trim(DEF_dir_runtime) // '/fire/abm_colm_double_fillcoast.nc'
+ IF (p_is_active) 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 (p_is_active) 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_Forcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90
new file mode 100644
index 0000000000..feff68e280
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Forcing.F90
@@ -0,0 +1,1810 @@
+#include
+
+MODULE MOD_Forcing
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+! read in the atmospheric forcing using user defined interpolation method or
+! downscaling forcing
+!
+! !REVISIONS:
+! Yongjiu Dai and Hua Yuan, 04/2014: initial code from CoLM2014 (metdata.F90,
+! GETMET.F90 and rd_forcing.F90
+!
+! Shupeng Zhang, 05/2023: 1) porting codes to MPI parallel version
+! 2) codes for dealing with missing forcing value
+! 3) interface for downscaling
+!
+! !TODO...(need complement)
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Namelist
+ USE MOD_Grid
+ USE MOD_SpatialMapping
+ USE MOD_UserSpecifiedForcing
+ USE MOD_TimeManager
+ USE MOD_SPMD_Task
+ USE MOD_MonthlyinSituCO2MaunaLoa
+ USE MOD_Vars_Global, only: pi
+ USE MOD_OrbCoszen
+ USE MOD_UserDefFun
+
+ IMPLICIT NONE
+
+ type (grid_type), PUBLIC :: gforc
+
+ type (spatial_mapping_type) :: mg2p_forc ! area weighted mapping from forcing to model unit
+
+ real(r8) :: forc_missing_value
+ logical, allocatable :: forcmask_pch (:)
+
+ ! for Forcing_Downscaling
+ type(block_data_real8_2d) :: topo_grid, maxelv_grid
+
+ type(pointer_real8_1d), allocatable :: forc_topo_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_maxelv_grid (:)
+
+ type(pointer_real8_1d), allocatable :: forc_t_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_th_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_q_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_pbot_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_rho_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_prc_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_prl_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_lwrad_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_swrad_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_hgt_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_us_grid (:)
+ type(pointer_real8_1d), allocatable :: forc_vs_grid (:)
+
+ type(pointer_real8_1d), allocatable :: forc_t_part (:)
+ type(pointer_real8_1d), allocatable :: forc_th_part (:)
+ type(pointer_real8_1d), allocatable :: forc_q_part (:)
+ type(pointer_real8_1d), allocatable :: forc_pbot_part (:)
+ type(pointer_real8_1d), allocatable :: forc_rhoair_part (:)
+ type(pointer_real8_1d), allocatable :: forc_prc_part (:)
+ type(pointer_real8_1d), allocatable :: forc_prl_part (:)
+ type(pointer_real8_1d), allocatable :: forc_frl_part (:)
+ type(pointer_real8_1d), allocatable :: forc_swrad_part (:)
+ type(pointer_real8_1d), allocatable :: forc_us_part (:)
+ type(pointer_real8_1d), allocatable :: forc_vs_part (:)
+
+ logical, allocatable :: glacierss (:)
+
+ ! local variables
+ integer :: deltim_int ! model time step length
+ ! real(r8) :: deltim_real ! model time step length
+
+ ! for SinglePoint
+ type(timestamp), allocatable :: forctime (:)
+ integer, allocatable :: iforctime(:)
+
+ logical :: forcing_read_ahead
+ real(r8), allocatable :: forc_disk(:,:)
+
+ type(timestamp), allocatable :: tstamp_LB(:) ! time stamp of low boundary data
+ type(timestamp), allocatable :: tstamp_UB(:) ! time stamp of up boundary data
+
+ type(block_data_real8_2d) :: avgcos ! time-average of cos(zenith)
+ type(block_data_real8_2d) :: metdata ! forcing data
+#ifdef URBAN_MODEL
+ type(block_data_real8_2d) :: rainf
+ type(block_data_real8_2d) :: snowf
+#endif
+
+ type(block_data_real8_2d), allocatable :: forcn (:) ! forcing data
+ type(block_data_real8_2d), allocatable :: forcn_LB (:) ! forcing data at lower boundary
+ type(block_data_real8_2d), allocatable :: forcn_UB (:) ! forcing data at upper boundary
+
+ PUBLIC :: forcing_init
+ PUBLIC :: read_forcing
+
+CONTAINS
+
+!-----------------------------------------------------------------------
+ SUBROUTINE forcing_init (dir_forcing, deltatime, ststamp, lc_year, etstamp, lulcc_call)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Block
+ USE MOD_DataType
+ USE MOD_Mesh
+ USE MOD_LandElm
+ USE MOD_LandPatch
+#ifdef CROP
+ USE MOD_LandCrop
+#endif
+ USE MOD_UserSpecifiedForcing
+ USE MOD_NetCDFSerial
+ USE MOD_NetCDFVector
+ USE MOD_NetCDFBlock
+ USE MOD_Vars_TimeInvariants
+ USE MOD_Vars_1DForcing
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: dir_forcing
+ real(r8), intent(in) :: deltatime ! model time step
+ type(timestamp), intent(in) :: ststamp
+ integer, intent(in) :: lc_year ! which year of land cover data used
+ type(timestamp), intent(in), optional :: etstamp
+ logical, intent(in), optional :: lulcc_call ! whether it is a lulcc CALL
+
+ ! Local variables
+ integer :: idate(3)
+ type(timestamp) :: tstamp
+ character(len=256) :: filename, lndname, cyear
+ integer :: ivar, year, month, day, time_i
+ integer :: ielm, istt, iend
+ type(block_data_real8_2d) :: areagrid
+
+ integer :: iblkme, xblk, yblk, xloc, yloc
+
+ CALL init_user_specified_forcing
+
+ ! CO2 data initialization
+ CALL init_monthly_co2_mlo
+
+ ! get value of fmetdat and deltim
+ deltim_int = int(deltatime)
+ ! deltim_real = deltatime
+
+ ! set initial values
+ IF (allocated(tstamp_LB)) deallocate(tstamp_LB)
+ IF (allocated(tstamp_UB)) deallocate(tstamp_UB)
+ allocate (tstamp_LB(NVAR))
+ allocate (tstamp_UB(NVAR))
+ tstamp_LB(:) = timestamp(-1, -1, -1)
+ tstamp_UB(:) = timestamp(-1, -1, -1)
+
+ idate = (/ststamp%year, ststamp%day, ststamp%sec/)
+ CALL adj2begin (idate)
+
+ CALL metread_latlon (dir_forcing, idate)
+
+ IF (p_is_active) THEN
+
+ IF (allocated(forcn )) deallocate(forcn )
+ IF (allocated(forcn_LB)) deallocate(forcn_LB)
+ IF (allocated(forcn_UB)) deallocate(forcn_UB)
+ allocate (forcn (NVAR))
+ allocate (forcn_LB (NVAR))
+ allocate (forcn_UB (NVAR))
+
+ DO ivar = 1, NVAR
+ CALL allocate_block_data (gforc, forcn (ivar))
+ CALL allocate_block_data (gforc, forcn_LB(ivar))
+ CALL allocate_block_data (gforc, forcn_UB(ivar))
+ ENDDO
+
+ ! allocate memory for forcing data
+ CALL allocate_block_data (gforc, metdata) ! forcing data
+ CALL allocate_block_data (gforc, avgcos ) ! time-average of cos(zenith)
+#if (defined URBAN_MODEL && defined SinglePoint)
+ CALL allocate_block_data (gforc, rainf)
+ CALL allocate_block_data (gforc, snowf)
+#endif
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ allocate (forcmask_pch(numpatch)); forcmask_pch(:) = .true.
+ ENDIF
+ ENDIF
+
+ IF (DEF_forcing%has_missing_value) THEN
+
+ tstamp = idate
+ CALL setstampLB(tstamp, 1, year, month, day, time_i)
+ filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1))
+ tstamp_LB(1) = timestamp(-1, -1, -1)
+
+ IF (p_is_root) THEN
+ CALL ncio_get_attr (filename, vname(1), trim(DEF_forcing%missing_value_name), &
+ forc_missing_value)
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_bcast (forc_missing_value, 1, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+#endif
+
+ CALL ncio_read_block_time (filename, vname(1), gforc, time_i, metdata)
+
+ ENDIF
+
+ IF (trim(DEF_Forcing_Interp_Method) == 'arealweight') THEN
+ IF (present(lulcc_call)) CALL mg2p_forc%forc_free_mem
+ CALL mg2p_forc%build_arealweighted (gforc, landpatch)
+ ELSEIF (trim(DEF_Forcing_Interp_Method) == 'bilinear') THEN
+ IF (present(lulcc_call)) CALL mg2p_forc%forc_free_mem
+ CALL mg2p_forc%build_bilinear (gforc, landpatch)
+ ENDIF
+
+ IF (DEF_forcing%has_missing_value) THEN
+ CALL mg2p_forc%set_missing_value (metdata, forc_missing_value, forcmask_pch)
+ ENDIF
+
+ IF (p_is_compute .and. (numpatch > 0)) THEN
+ forc_topo = elvmean
+ WHERE(forc_topo == spval) forc_topo = 0.
+ ENDIF
+
+ IF ((DEF_USE_Forcing_Downscaling).or.(DEF_USE_Forcing_Downscaling_Simple)) THEN
+
+ IF (p_is_active) CALL allocate_block_data (gforc, topo_grid)
+ CALL mg2p_forc%pset2grid (forc_topo, topo_grid, msk = patchmask)
+
+ IF (p_is_active) CALL allocate_block_data (gforc, areagrid)
+ CALL mg2p_forc%get_sumarea(areagrid, patchmask)
+ CALL block_data_division (topo_grid, areagrid)
+
+ IF (p_is_active) CALL allocate_block_data (gforc, maxelv_grid)
+ CALL mg2p_forc%pset2grid_max (forc_topo, maxelv_grid, msk = patchmask)
+
+
+ CALL mg2p_forc%allocate_part (forc_topo_grid )
+ CALL mg2p_forc%allocate_part (forc_maxelv_grid)
+
+ CALL mg2p_forc%allocate_part (forc_t_grid )
+ CALL mg2p_forc%allocate_part (forc_th_grid )
+ CALL mg2p_forc%allocate_part (forc_q_grid )
+ CALL mg2p_forc%allocate_part (forc_pbot_grid )
+ CALL mg2p_forc%allocate_part (forc_rho_grid )
+ CALL mg2p_forc%allocate_part (forc_prc_grid )
+ CALL mg2p_forc%allocate_part (forc_prl_grid )
+ CALL mg2p_forc%allocate_part (forc_lwrad_grid )
+ CALL mg2p_forc%allocate_part (forc_swrad_grid )
+ CALL mg2p_forc%allocate_part (forc_hgt_grid )
+ CALL mg2p_forc%allocate_part (forc_us_grid )
+ CALL mg2p_forc%allocate_part (forc_vs_grid )
+
+ CALL mg2p_forc%allocate_part (forc_t_part )
+ CALL mg2p_forc%allocate_part (forc_th_part )
+ CALL mg2p_forc%allocate_part (forc_q_part )
+ CALL mg2p_forc%allocate_part (forc_pbot_part )
+ CALL mg2p_forc%allocate_part (forc_rhoair_part)
+ CALL mg2p_forc%allocate_part (forc_prc_part )
+ CALL mg2p_forc%allocate_part (forc_prl_part )
+ CALL mg2p_forc%allocate_part (forc_frl_part )
+ CALL mg2p_forc%allocate_part (forc_swrad_part )
+ CALL mg2p_forc%allocate_part (forc_us_part )
+ CALL mg2p_forc%allocate_part (forc_vs_part )
+
+ CALL mg2p_forc%grid2part (topo_grid, forc_topo_grid )
+ CALL mg2p_forc%grid2part (maxelv_grid, forc_maxelv_grid)
+
+ IF (p_is_compute .and. (numpatch > 0)) THEN
+ allocate (glacierss(numpatch))
+ glacierss(:) = patchtype(:) == 3
+ ENDIF
+
+ ENDIF
+
+ forcing_read_ahead = .false.
+ IF (trim(DEF_forcing%dataset) == 'POINT') THEN
+ IF (USE_SITE_ForcingReadAhead .and. present(etstamp)) THEN
+ forcing_read_ahead = .true.
+ CALL metread_time (dir_forcing, ststamp, etstamp, deltatime)
+ ELSE
+ CALL metread_time (dir_forcing)
+ ENDIF
+ allocate (iforctime(NVAR))
+ ENDIF
+
+ IF (trim(DEF_forcing%dataset) == 'POINT') THEN
+
+ filename = trim(dir_forcing)//trim(fprefix(1))
+
+#ifndef URBAN_MODEL
+ IF (ncio_var_exist(filename,'reference_height_v')) THEN
+ CALL ncio_read_serial (filename, 'reference_height_v', Height_V)
+ ENDIF
+
+ IF (ncio_var_exist(filename,'reference_height_t')) THEN
+ CALL ncio_read_serial (filename, 'reference_height_t', Height_T)
+ ENDIF
+
+ IF (ncio_var_exist(filename,'reference_height_q')) THEN
+ CALL ncio_read_serial (filename, 'reference_height_q', Height_Q)
+ ENDIF
+#else
+ IF (ncio_var_exist(filename,'measurement_height_above_ground')) THEN
+ CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_V)
+ CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_T)
+ CALL ncio_read_serial (filename, 'measurement_height_above_ground', Height_Q)
+ ENDIF
+#endif
+
+ ENDIF
+
+ END SUBROUTINE forcing_init
+
+ ! ---- forcing finalize ----
+ SUBROUTINE forcing_final ()
+
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+ IF (allocated(forcmask_pch)) deallocate(forcmask_pch)
+ IF (allocated(glacierss )) deallocate(glacierss )
+ IF (allocated(forctime )) deallocate(forctime )
+ IF (allocated(iforctime )) deallocate(iforctime )
+ IF (allocated(forc_disk )) deallocate(forc_disk )
+ IF (allocated(tstamp_LB )) deallocate(tstamp_LB )
+ IF (allocated(tstamp_UB )) deallocate(tstamp_UB )
+
+ IF ((DEF_USE_Forcing_Downscaling).or.(DEF_USE_Forcing_Downscaling_Simple)) THEN
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ CALL mg2p_forc%deallocate_part (forc_topo_grid )
+ CALL mg2p_forc%deallocate_part (forc_maxelv_grid)
+
+ CALL mg2p_forc%deallocate_part (forc_t_grid )
+ CALL mg2p_forc%deallocate_part (forc_th_grid )
+ CALL mg2p_forc%deallocate_part (forc_q_grid )
+ CALL mg2p_forc%deallocate_part (forc_pbot_grid )
+ CALL mg2p_forc%deallocate_part (forc_rho_grid )
+ CALL mg2p_forc%deallocate_part (forc_prc_grid )
+ CALL mg2p_forc%deallocate_part (forc_prl_grid )
+ CALL mg2p_forc%deallocate_part (forc_lwrad_grid )
+ CALL mg2p_forc%deallocate_part (forc_swrad_grid )
+ CALL mg2p_forc%deallocate_part (forc_hgt_grid )
+ CALL mg2p_forc%deallocate_part (forc_us_grid )
+ CALL mg2p_forc%deallocate_part (forc_vs_grid )
+
+ CALL mg2p_forc%deallocate_part (forc_t_part )
+ CALL mg2p_forc%deallocate_part (forc_th_part )
+ CALL mg2p_forc%deallocate_part (forc_q_part )
+ CALL mg2p_forc%deallocate_part (forc_pbot_part )
+ CALL mg2p_forc%deallocate_part (forc_rhoair_part)
+ CALL mg2p_forc%deallocate_part (forc_prc_part )
+ CALL mg2p_forc%deallocate_part (forc_prl_part )
+ CALL mg2p_forc%deallocate_part (forc_frl_part )
+ CALL mg2p_forc%deallocate_part (forc_swrad_part )
+ CALL mg2p_forc%deallocate_part (forc_us_part )
+ CALL mg2p_forc%deallocate_part (forc_vs_part )
+
+ ENDIF
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE forcing_final
+
+ ! ------------
+ SUBROUTINE forcing_reset ()
+
+ IMPLICIT NONE
+
+ tstamp_LB(:) = timestamp(-1, -1, -1)
+ tstamp_UB(:) = timestamp(-1, -1, -1)
+
+ END SUBROUTINE forcing_reset
+
+
+!-----------------------------------------------------------------------
+ SUBROUTINE read_forcing (idate, dir_forcing, is_spinup)
+ USE MOD_OrbCosazi
+ USE MOD_Precision
+ USE MOD_Namelist
+ USE MOD_Const_Physical, only: rgas, grav
+ USE MOD_Vars_TimeInvariants
+ USE MOD_Vars_TimeVariables, only: alb
+ USE MOD_Vars_1DForcing
+ USE MOD_Vars_2DForcing
+ USE MOD_Block
+ USE MOD_SPMD_Task
+ USE MOD_DataType
+ USE MOD_Mesh
+ USE MOD_LandPatch
+ USE MOD_RangeCheck
+ USE MOD_UserSpecifiedForcing
+ USE MOD_ForcingDownscaling, only: rair, cpair, downscale_forcings, downscale_wind, downscale_wind_simple
+ USE MOD_NetCDFVector
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: idate(3)
+ character(len=*), intent(in) :: dir_forcing
+ logical, intent(in) :: is_spinup
+
+ ! local variables:
+ integer :: ivar, istt, iend, id(3)
+ integer :: iblkme, ib, jb, i, j, ilon, ilat, np, ipart, ne
+ real(r8) :: calday ! Julian cal day (1.xx to 365.xx)
+ real(r8) :: sunang, cloud, difrat, vnrat
+ real(r8) :: a, hsolar, ratio_rvrf
+ type(block_data_real8_2d) :: forc_xy_solarin
+ integer :: ii
+ character(10) :: cyear = "2005"
+ character(256):: lndname
+
+ type(timestamp) :: mtstamp
+ integer :: dtLB, dtUB
+ real(r8) :: cosz, coszen(numpatch), cosa, cosazi(numpatch), balb
+ integer :: year, month, mday
+ logical :: has_u,has_v
+ real solar, frl, prcp, tm, us, vs, pres, qm
+ real(r8) :: pco2m
+ real(r8), dimension(12, numpatch) :: spaceship !NOTE: 12 is the dimension size of spaceship
+ integer target_server, ierr
+
+ IF (p_is_active) THEN
+ !------------------------------------------------------------
+ ! READ in THE ATMOSPHERIC FORCING
+ ! read lower and upper boundary forcing data
+ CALL metreadLBUB(idate, dir_forcing, is_spinup)
+ ! set model time stamp
+ id(:) = idate(:)
+ !CALL adj2end(id)
+ mtstamp = id
+ has_u = .true.
+ has_v = .true.
+ ! loop for variables
+ DO ivar = 1, NVAR
+ IF (ivar == 5 .and. trim(vname(ivar)) == 'NULL') has_u = .false.
+ IF (ivar == 6 .and. trim(vname(ivar)) == 'NULL') has_v = .false.
+ IF (trim(vname(ivar)) == 'NULL') CYCLE ! no data, CYCLE
+ IF (trim(tintalgo(ivar)) == 'NULL') CYCLE
+
+ ! to make sure the forcing data calculated is in the range of time
+ ! interval [LB, UB]
+ IF ( (mtstamp < tstamp_LB(ivar)) .or. (tstamp_UB(ivar) < mtstamp) ) THEN
+ write(6, *) "the data required is out of range! STOP!"; CALL CoLM_stop()
+ ENDIF
+
+ ! calculate distance to lower/upper boundary
+ dtLB = mtstamp - tstamp_LB(ivar)
+ dtUB = tstamp_UB(ivar) - mtstamp
+
+ ! linear method, for T, Pres, Q, W, LW
+ IF (tintalgo(ivar) == 'linear') THEN
+ IF ( (dtLB+dtUB) > 0 ) THEN
+ CALL block_data_linear_interp ( &
+ forcn_LB(ivar), real(dtUB,r8)/real(dtLB+dtUB,r8), &
+ forcn_UB(ivar), real(dtLB,r8)/real(dtLB+dtUB,r8), &
+ forcn(ivar))
+ ELSE
+ CALL block_data_copy (forcn_LB(ivar), forcn(ivar))
+ ENDIF
+ ENDIF
+
+ ! for precipitation, two algorithms available
+ ! nearest method, for precipitation
+ IF (tintalgo(ivar) == 'nearest') THEN
+ IF (dtLB <= dtUB) THEN
+ CALL block_data_copy (forcn_LB(ivar), forcn(ivar))
+ ELSE
+ CALL block_data_copy (forcn_UB(ivar), forcn(ivar))
+ ENDIF
+ ENDIF
+
+ ! set all the same value, for precipitation
+ IF (tintalgo(ivar) == 'uniform') THEN
+ IF (trim(timelog(ivar)) == 'forward') THEN
+ CALL block_data_copy (forcn_LB(ivar), forcn(ivar))
+ ELSE
+ CALL block_data_copy (forcn_UB(ivar), forcn(ivar))
+ ENDIF
+ ENDIF
+
+ ! coszen method, for SW
+ IF (tintalgo(ivar) == 'coszen') THEN
+ DO iblkme = 1, gblock%nblkme
+ ib = gblock%xblkme(iblkme)
+ jb = gblock%yblkme(iblkme)
+
+ DO j = 1, gforc%ycnt(jb)
+ DO i = 1, gforc%xcnt(ib)
+
+ ilat = gforc%ydsp(jb) + j
+ ilon = gforc%xdsp(ib) + i
+ IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon
+
+ calday = calendarday(mtstamp)
+ cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat))
+ cosz = max(0.001, cosz)
+ ! 10/24/2024, yuan: deal with time log with backward or forward
+ IF (trim(timelog(ivar)) == 'forward') THEN
+ forcn(ivar)%blk(ib,jb)%val(i,j) = &
+ cosz / avgcos%blk(ib,jb)%val(i,j) * forcn_LB(ivar)%blk(ib,jb)%val(i,j)
+ ELSE
+ forcn(ivar)%blk(ib,jb)%val(i,j) = &
+ cosz / avgcos%blk(ib,jb)%val(i,j) * forcn_UB(ivar)%blk(ib,jb)%val(i,j)
+ ENDIF
+
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+
+ ENDDO
+
+ ! preprocess for forcing data, only for QIAN data right now?
+ CALL metpreprocess (gforc, forcn, &
+ DEF_forcing%has_missing_value, forcn_UB(1), forc_missing_value)
+
+ CALL allocate_block_data (gforc, forc_xy_solarin)
+
+ CALL block_data_copy (forcn(1), forc_xy_t )
+ CALL block_data_copy (forcn(2), forc_xy_q )
+ CALL block_data_copy (forcn(3), forc_xy_psrf )
+ CALL block_data_copy (forcn(3), forc_xy_pbot )
+ CALL block_data_copy (forcn(4), forc_xy_prl, sca = 2/3._r8)
+ CALL block_data_copy (forcn(4), forc_xy_prc, sca = 1/3._r8)
+ CALL block_data_copy (forcn(7), forc_xy_solarin)
+ CALL block_data_copy (forcn(8), forc_xy_frl )
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ CALL block_data_copy (forcn(9), forc_xy_hpbl )
+ ENDIF
+
+ IF (has_u .and. has_v) THEN
+ CALL block_data_copy (forcn(5), forc_xy_us )
+ CALL block_data_copy (forcn(6), forc_xy_vs )
+ ELSEIF (has_u) THEN
+ CALL block_data_copy (forcn(5), forc_xy_us , sca = 1/sqrt(2.0_r8))
+ CALL block_data_copy (forcn(5), forc_xy_vs , sca = 1/sqrt(2.0_r8))
+ ELSEIF (has_v) THEN
+ CALL block_data_copy (forcn(6), forc_xy_us , sca = 1/sqrt(2.0_r8))
+ CALL block_data_copy (forcn(6), forc_xy_vs , sca = 1/sqrt(2.0_r8))
+ ELSE
+ IF (.not.trim(DEF_forcing%dataset) == 'CPL7') THEN
+ write(6, *) "At least one of the wind components must be provided! STOP!";
+ CALL CoLM_stop()
+ ENDIF
+ ENDIF
+
+ CALL flush_block_data (forc_xy_hgt_u, real(HEIGHT_V,r8))
+ CALL flush_block_data (forc_xy_hgt_t, real(HEIGHT_T,r8))
+ CALL flush_block_data (forc_xy_hgt_q, real(HEIGHT_Q,r8))
+
+ IF (solarin_all_band) THEN
+
+ IF (trim(DEF_forcing%dataset) == 'QIAN') THEN
+ !---------------------------------------------------------------
+ ! 04/2014, yuan: NOTE! codes from CLM4.5-CESM1.2.0
+ ! relationship between incoming NIR or VIS radiation and ratio of
+ ! direct to diffuse radiation calculated based on one year's worth of
+ ! hourly CAM output from CAM version cam3_5_55
+ !---------------------------------------------------------------
+ DO iblkme = 1, gblock%nblkme
+ ib = gblock%xblkme(iblkme)
+ jb = gblock%yblkme(iblkme)
+
+ DO j = 1, gforc%ycnt(jb)
+ DO i = 1, gforc%xcnt(ib)
+
+ hsolar = forc_xy_solarin%blk(ib,jb)%val(i,j)*0.5_R8
+
+ ! NIR (dir, diff)
+ ratio_rvrf = min(0.99_R8,max(0.29548_R8 + 0.00504_R8*hsolar &
+ -1.4957e-05_R8*hsolar**2 + 1.4881e-08_R8*hsolar**3,0.01_R8))
+ forc_xy_soll %blk(ib,jb)%val(i,j) = ratio_rvrf*hsolar
+ forc_xy_solld%blk(ib,jb)%val(i,j) = (1._R8 - ratio_rvrf)*hsolar
+
+ ! VIS (dir, diff)
+ ratio_rvrf = min(0.99_R8,max(0.17639_R8 + 0.00380_R8*hsolar &
+ -9.0039e-06_R8*hsolar**2 + 8.1351e-09_R8*hsolar**3,0.01_R8))
+ forc_xy_sols %blk(ib,jb)%val(i,j) = ratio_rvrf*hsolar
+ forc_xy_solsd%blk(ib,jb)%val(i,j) = (1._R8 - ratio_rvrf)*hsolar
+
+ ENDDO
+ ENDDO
+ ENDDO
+
+ ELSE
+ !---------------------------------------------------------------
+ ! as the downward solar is in full band, an empirical expression
+ ! will be used to divide fractions of band and incident
+ ! (visible, near-infrad, dirct, diffuse)
+ ! Julian calday (1.xx to 365.xx)
+ !---------------------------------------------------------------
+ DO iblkme = 1, gblock%nblkme
+ ib = gblock%xblkme(iblkme)
+ jb = gblock%yblkme(iblkme)
+
+ DO j = 1, gforc%ycnt(jb)
+ DO i = 1, gforc%xcnt(ib)
+
+ IF (DEF_forcing%has_missing_value) THEN
+ IF (forcn_UB(1)%blk(ib,jb)%val(i,j) == forc_missing_value) THEN
+ CYCLE
+ ENDIF
+ ENDIF
+
+ ilat = gforc%ydsp(jb) + j
+ ilon = gforc%xdsp(ib) + i
+ IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon
+
+ a = max(0., forc_xy_solarin%blk(ib,jb)%val(i,j))
+ calday = calendarday(idate)
+ sunang = orb_coszen (calday, gforc%rlon(ilon), gforc%rlat(ilat))
+
+ IF (sunang .eq. 0)THEN
+ cloud = 0.
+ ELSE
+ cloud = (1160.*sunang-a)/(963.*sunang)
+ ENDIF
+ cloud = max(cloud,0.)
+ cloud = min(cloud,1.)
+ cloud = max(0.58,cloud)
+
+ difrat = 0.0604/(sunang-0.0223)+0.0683
+ IF(difrat.lt.0.) difrat = 0.
+ IF(difrat.gt.1.) difrat = 1.
+
+ difrat = difrat+(1.0-difrat)*cloud
+ vnrat = (580.-cloud*464.)/((580.-cloud*499.)+(580.-cloud*464.))
+
+ forc_xy_sols %blk(ib,jb)%val(i,j) = a*(1.0-difrat)*vnrat
+ forc_xy_soll %blk(ib,jb)%val(i,j) = a*(1.0-difrat)*(1.0-vnrat)
+ forc_xy_solsd%blk(ib,jb)%val(i,j) = a*difrat*vnrat
+ forc_xy_solld%blk(ib,jb)%val(i,j) = a*difrat*(1.0-vnrat)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ ! [GET ATMOSPHERE CO2 CONCENTRATION DATA]
+ year = idate(1)
+ CALL julian2monthday (idate(1), idate(2), month, mday)
+ pco2m = get_monthly_co2_mlo(year, month)*1.e-6
+ CALL block_data_copy (forc_xy_pbot, forc_xy_pco2m, sca = pco2m )
+ CALL block_data_copy (forc_xy_pbot, forc_xy_po2m , sca = 0.209_r8 )
+
+ ENDIF
+
+ IF ((.not. DEF_USE_Forcing_Downscaling).and.(.not. DEF_USE_Forcing_Downscaling_Simple)) THEN
+
+ ! Mapping the 2d atmospheric fields [lon_points]x[lat_points]
+ ! -> the 1d vector of subgrid points [numpatch]
+ CALL mg2p_forc%grid2pset (forc_xy_pco2m, forc_pco2m)
+ CALL mg2p_forc%grid2pset (forc_xy_po2m , forc_po2m )
+ CALL mg2p_forc%grid2pset (forc_xy_us , forc_us )
+ CALL mg2p_forc%grid2pset (forc_xy_vs , forc_vs )
+
+ CALL mg2p_forc%grid2pset (forc_xy_psrf , forc_psrf )
+
+ CALL mg2p_forc%grid2pset (forc_xy_sols , forc_sols )
+ CALL mg2p_forc%grid2pset (forc_xy_soll , forc_soll )
+ CALL mg2p_forc%grid2pset (forc_xy_solsd, forc_solsd)
+ CALL mg2p_forc%grid2pset (forc_xy_solld, forc_solld)
+
+ CALL mg2p_forc%grid2pset (forc_xy_hgt_t, forc_hgt_t)
+ CALL mg2p_forc%grid2pset (forc_xy_hgt_u, forc_hgt_u)
+ CALL mg2p_forc%grid2pset (forc_xy_hgt_q, forc_hgt_q)
+
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ CALL mg2p_forc%grid2pset (forc_xy_hpbl, forc_hpbl)
+ ENDIF
+
+ CALL mg2p_forc%grid2pset (forc_xy_t , forc_t )
+ CALL mg2p_forc%grid2pset (forc_xy_q , forc_q )
+ CALL mg2p_forc%grid2pset (forc_xy_prc , forc_prc )
+ CALL mg2p_forc%grid2pset (forc_xy_prl , forc_prl )
+ CALL mg2p_forc%grid2pset (forc_xy_pbot , forc_pbot )
+ CALL mg2p_forc%grid2pset (forc_xy_frl , forc_frl )
+
+ IF (p_is_compute) THEN
+
+ DO np = 1, numpatch
+
+ IF (.not. forcmask_pch(np)) CYCLE
+
+ ! The standard measuring conditions for temperature are two meters above the ground
+ ! Scientists have measured the most frigid temperature ever
+ ! recorded on the continent's eastern highlands: about (180K) colder than dry ice.
+ IF(forc_t(np) < 180.) forc_t(np) = 180.
+ ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31;
+ ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03
+ IF(forc_t(np) > 326.) forc_t(np) = 326.
+
+ forc_rhoair(np) = (forc_pbot(np) &
+ - 0.378*forc_q(np)*forc_pbot(np)/(0.622+0.378*forc_q(np)))&
+ / (rgas*forc_t(np))
+
+ ENDDO
+
+ ENDIF
+
+ ELSE
+ ! ------------------------------------------------------
+ ! Forcing downscaling module
+ ! ------------------------------------------------------
+ ! init forcing on patches
+ CALL mg2p_forc%grid2pset (forc_xy_pco2m, forc_pco2m)
+ CALL mg2p_forc%grid2pset (forc_xy_po2m , forc_po2m )
+ CALL mg2p_forc%grid2pset (forc_xy_us , forc_us )
+ CALL mg2p_forc%grid2pset (forc_xy_vs , forc_vs )
+ CALL mg2p_forc%grid2pset (forc_xy_psrf , forc_psrf )
+ CALL mg2p_forc%grid2pset (forc_xy_sols , forc_sols )
+ CALL mg2p_forc%grid2pset (forc_xy_soll , forc_soll )
+ CALL mg2p_forc%grid2pset (forc_xy_solsd, forc_solsd)
+ CALL mg2p_forc%grid2pset (forc_xy_solld, forc_solld)
+ CALL mg2p_forc%grid2pset (forc_xy_solarin, forc_swrad)
+ CALL mg2p_forc%grid2pset (forc_xy_hgt_t, forc_hgt_t)
+ CALL mg2p_forc%grid2pset (forc_xy_hgt_u, forc_hgt_u)
+ CALL mg2p_forc%grid2pset (forc_xy_hgt_q, forc_hgt_q)
+ CALL mg2p_forc%grid2pset (forc_xy_t , forc_t )
+ CALL mg2p_forc%grid2pset (forc_xy_pbot , forc_pbot )
+ CALL mg2p_forc%grid2pset (forc_xy_q , forc_q )
+ CALL mg2p_forc%grid2pset (forc_xy_frl , forc_frl )
+
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ CALL mg2p_forc%grid2pset (forc_xy_hpbl, forc_hpbl)
+ ENDIF
+
+ ! Mapping the 2d atmospheric fields [lon_points]x[lat_points]
+ ! -> the 1d vector of subgrid points [numelm]
+ ! by selected mapping methods
+ CALL mg2p_forc%grid2part (forc_xy_t , forc_t_grid )
+ CALL mg2p_forc%grid2part (forc_xy_q , forc_q_grid )
+ CALL mg2p_forc%grid2part (forc_xy_prc , forc_prc_grid )
+ CALL mg2p_forc%grid2part (forc_xy_prl , forc_prl_grid )
+ CALL mg2p_forc%grid2part (forc_xy_pbot , forc_pbot_grid )
+ CALL mg2p_forc%grid2part (forc_xy_frl , forc_lwrad_grid)
+ CALL mg2p_forc%grid2part (forc_xy_hgt_t, forc_hgt_grid )
+ CALL mg2p_forc%grid2part (forc_xy_solarin, forc_swrad_grid)
+ CALL mg2p_forc%grid2part (forc_xy_us, forc_us_grid )
+ CALL mg2p_forc%grid2part (forc_xy_vs, forc_vs_grid )
+
+ calday = calendarday(idate)
+
+ IF (p_is_compute) THEN
+ DO np = 1, numpatch ! patches
+
+ ! calculate albedo of each patches
+ IF (forc_sols(np)+forc_solsd(np)+forc_soll(np)+forc_solld(np) == 0.) THEN
+ balb = 0
+ ELSE
+ balb = ( alb(1,1,np)*forc_sols (np) + alb(1,2,np)*forc_solsd(np) &
+ + alb(2,1,np)*forc_soll (np) + alb(2,2,np)*forc_solld(np) ) &
+ / (forc_sols(np)+forc_solsd(np)+forc_soll(np)+forc_solld(np))
+ ENDIF
+
+ DO ipart = 1, mg2p_forc%npart(np) ! part loop of each patch
+
+ IF (mg2p_forc%areapart(np)%val(ipart) == 0.) CYCLE
+
+ ! The standard measuring conditions for temperature are two meters above
+ ! the ground. Scientists have measured the most frigid temperature ever
+ ! recorded on the continent's eastern highlands: about (180K) colder than
+ ! dry ice.
+ IF (forc_t_grid(np)%val(ipart) < 180.) forc_t_grid(np)%val(ipart) = 180.
+ ! the highest air temp was found in Kuwait 326 K, Sulaibya 2012-07-31;
+ ! Pakistan, Sindh 2010-05-26; Iraq, Nasiriyah 2011-08-03
+ IF (forc_t_grid(np)%val(ipart) > 326.) forc_t_grid(np)%val(ipart) = 326.
+
+ forc_rho_grid(np)%val(ipart) = (forc_pbot_grid(np)%val(ipart) &
+ - 0.378*forc_q_grid(np)%val(ipart)*forc_pbot_grid(np)%val(ipart) &
+ /(0.622+0.378*forc_q_grid(np)%val(ipart)))/(rgas*forc_t_grid(np)%val(ipart))
+
+ forc_th_grid(np)%val(ipart) = forc_t_grid(np)%val(ipart) &
+ * (1.e5/forc_pbot_grid(np)%val(ipart)) ** (rair/cpair)
+
+ ! calculate sun zenith angle and sun azimuth angle and turn to degree
+ coszen(np) = orb_coszen(calday, patchlonr(np), patchlatr(np))
+ cosazi(np) = orb_cosazi(calday, patchlonr(np), patchlatr(np), coszen(np))
+
+ ! downscale forcing from grid to part
+ IF (DEF_USE_Forcing_Downscaling) THEN
+ ! Complex downscaling with topographic effects
+ CALL downscale_forcings ( &
+ glacierss(np), &
+
+ ! non-adjusted forcing
+ forc_topo_grid(np)%val(ipart), forc_maxelv_grid(np)%val(ipart), &
+ forc_t_grid(np)%val(ipart), forc_th_grid(np)%val(ipart), &
+ forc_q_grid(np)%val(ipart), forc_pbot_grid(np)%val(ipart), &
+ forc_rho_grid(np)%val(ipart), forc_prc_grid(np)%val(ipart), &
+ forc_prl_grid(np)%val(ipart), forc_lwrad_grid(np)%val(ipart), &
+ forc_hgt_grid(np)%val(ipart), forc_swrad_grid(np)%val(ipart), &
+ forc_us_grid(np)%val(ipart), forc_vs_grid(np)%val(ipart), &
+
+ ! topography-based factor on patch
+ slp_type_patches(:,np), asp_type_patches(:,np), cur_patches(np), &
+
+ ! other factors
+ calday, coszen(np), cosazi(np), &
+
+ ! adjusted forcing
+ forc_topo(np), forc_t_part(np)%val(ipart), &
+ forc_th_part(np)%val(ipart), forc_q_part(np)%val(ipart), &
+ forc_pbot_part(np)%val(ipart), forc_rhoair_part(np)%val(ipart), &
+ forc_prc_part(np)%val(ipart), forc_prl_part(np)%val(ipart), &
+
+ forc_frl_part(np)%val(ipart), forc_swrad_part(np)%val(ipart), &
+ forc_us_part(np)%val(ipart), forc_vs_part(np)%val(ipart), &
+
+ ! optional factors for complex downscaling
+ area_type_patches(:,np), svf_patches(np), balb, &
+#ifdef SinglePoint
+ sf_lut_patches (:,:,np) &
+#else
+ sf_curve_patches(:,:,np) &
+#endif
+ )
+
+ ELSEIF (DEF_USE_Forcing_Downscaling_Simple) THEN
+ ! Simple downscaling without optional parameters
+ CALL downscale_forcings ( &
+ glacierss(np), &
+
+ ! non-adjusted forcing
+ forc_topo_grid(np)%val(ipart), forc_maxelv_grid(np)%val(ipart), &
+ forc_t_grid(np)%val(ipart), forc_th_grid(np)%val(ipart), &
+ forc_q_grid(np)%val(ipart), forc_pbot_grid(np)%val(ipart), &
+ forc_rho_grid(np)%val(ipart), forc_prc_grid(np)%val(ipart), &
+ forc_prl_grid(np)%val(ipart), forc_lwrad_grid(np)%val(ipart), &
+ forc_hgt_grid(np)%val(ipart), forc_swrad_grid(np)%val(ipart), &
+ forc_us_grid(np)%val(ipart), forc_vs_grid(np)%val(ipart), &
+
+ ! topography-based factor on patch
+ slp_type_patches(:,np), asp_type_patches(:,np), cur_patches(np), &
+
+ ! other factors
+ calday, coszen(np), cosazi(np), &
+
+ ! adjusted forcing
+ forc_topo(np), forc_t_part(np)%val(ipart), &
+ forc_th_part(np)%val(ipart), forc_q_part(np)%val(ipart), &
+ forc_pbot_part(np)%val(ipart), forc_rhoair_part(np)%val(ipart), &
+ forc_prc_part(np)%val(ipart), forc_prl_part(np)%val(ipart), &
+
+ forc_frl_part(np)%val(ipart), forc_swrad_part(np)%val(ipart), &
+ forc_us_part(np)%val(ipart), forc_vs_part(np)%val(ipart) &
+ )
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+ ENDIF
+
+ ! mapping parts to patches
+ CALL mg2p_forc%part2pset (forc_t_part, forc_t )
+ CALL mg2p_forc%part2pset (forc_q_part, forc_q )
+ CALL mg2p_forc%part2pset (forc_pbot_part, forc_pbot )
+ CALL mg2p_forc%part2pset (forc_rhoair_part, forc_rhoair)
+ CALL mg2p_forc%part2pset (forc_prc_part, forc_prc )
+ CALL mg2p_forc%part2pset (forc_prl_part, forc_prl )
+ CALL mg2p_forc%part2pset (forc_frl_part, forc_frl )
+ CALL mg2p_forc%part2pset (forc_swrad_part, forc_swrad )
+ CALL mg2p_forc%part2pset (forc_us_part, forc_us )
+ CALL mg2p_forc%part2pset (forc_vs_part, forc_vs )
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ forc_psrf = forc_pbot
+ ENDIF
+ ENDIF
+
+ ! wind downscaling
+ IF (p_is_compute) THEN
+ IF (DEF_USE_Forcing_Downscaling) THEN
+ DO np = 1, numpatch
+ IF ((forc_us(np)==spval).or.(forc_vs(np)==spval)) cycle
+ CALL downscale_wind(forc_us(np), forc_vs(np), slp_type_patches(:,np), &
+ asp_type_patches(:,np), area_type_patches(:,np), cur_patches(np))
+ ENDDO
+
+ ELSEIF (DEF_USE_Forcing_Downscaling_Simple) THEN
+ DO np = 1, numpatch
+ IF ((forc_us(np)==spval).or.(forc_vs(np)==spval)) cycle
+ CALL downscale_wind_simple(forc_us(np), forc_vs(np), slp_type_patches(:,np), &
+ asp_type_patches(:,np), cur_patches(np))
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+#ifndef SinglePoint
+ IF (trim(DEF_DS_precipitation_adjust_scheme) == 'III') THEN
+ ! Sisi Chen, Lu Li, Yongjiu Dai et al., 2024, JGR
+ ! Using MPI to pass the forcing variable field to Python to
+ ! accomplish precipitation downscaling
+ IF (p_is_compute) THEN
+ spaceship(1,1:numpatch) = forc_topo
+ spaceship(2,1:numpatch) = forc_t
+ spaceship(3,1:numpatch) = forc_pbot
+ spaceship(4,1:numpatch) = forc_q
+ spaceship(5,1:numpatch) = forc_frl
+ spaceship(6,1:numpatch) = forc_swrad
+ spaceship(7,1:numpatch) = forc_us
+ spaceship(8,1:numpatch) = forc_vs
+ spaceship(9,1:numpatch) = INT(calday)
+ spaceship(10,1:numpatch) = patchlatr
+ spaceship(11,1:numpatch) = patchlonr
+
+ target_server = p_iam_glb/5+p_np_glb
+ CALL MPI_SEND(spaceship,12*numpatch,MPI_REAL8,target_server,0,MPI_COMM_WORLD,ierr)
+ CALL MPI_RECV(forc_prc,numpatch,MPI_REAL8,target_server,0,MPI_COMM_WORLD,&
+ MPI_STATUS_IGNORE,ierr)
+
+ forc_prl = forc_prc/3600*2/3._r8
+ forc_prc = forc_prc/3600*1/3._r8
+ ENDIF
+ ENDIF
+
+ ! mapping forc_prl to forc_prl_part, forc_prc to forc_prc_part
+ IF (p_is_compute) THEN
+ DO np = 1, numpatch ! patches
+ DO ipart = 1, mg2p_forc%npart(np) ! part loop of each patch
+ IF (mg2p_forc%areapart(np)%val(ipart) == 0.) CYCLE
+
+ forc_prl_part(np)%val(ipart) = forc_prl(np)
+ forc_prc_part(np)%val(ipart) = forc_prc(np)
+
+ ENDDO
+ ENDDO
+ ENDIF
+
+ ! Conservation of convective and large scale precipitation in the grid of forcing
+ CALL mg2p_forc%normalize (forc_xy_prc, forc_prc_part)
+ CALL mg2p_forc%normalize (forc_xy_prl, forc_prl_part)
+
+ ! mapping parts to patches
+ CALL mg2p_forc%part2pset (forc_prc_part, forc_prc)
+ CALL mg2p_forc%part2pset (forc_prl_part, forc_prl)
+
+ ! Conservation of short- and long- waves radiation in the grid of forcing
+ CALL mg2p_forc%normalize (forc_xy_solarin, forc_swrad_part)
+ CALL mg2p_forc%normalize (forc_xy_frl, forc_frl_part )
+ CALL mg2p_forc%part2pset (forc_frl_part, forc_frl )
+ CALL mg2p_forc%part2pset (forc_swrad_part, forc_swrad )
+#endif
+
+ ! divide fractions of downscaled shortwave radiation
+ IF (p_is_compute) THEN
+ DO j = 1, numpatch
+ a = forc_swrad(j)
+ IF (isnan_ud(a)) a = 0
+ calday = calendarday(idate)
+ sunang = orb_coszen (calday, patchlonr(j), patchlatr(j))
+ IF (sunang.eq.0) THEN
+ cloud = 0.
+ ELSE
+ cloud = (1160.*sunang-a)/(963.*sunang)
+ ENDIF
+ cloud = max(cloud,0.0001)
+ cloud = min(cloud,1.)
+ cloud = max(0.58,cloud)
+
+ difrat = 0.0604/(sunang-0.0223)+0.0683
+ IF(difrat.lt.0.) difrat = 0.
+ IF(difrat.gt.1.) difrat = 1.
+
+ difrat = difrat+(1.0-difrat)*cloud
+ vnrat = (580.-cloud*464.)/((580.-cloud*499.)+(580.-cloud*464.))
+
+ forc_sols(j) = a*(1.0-difrat)*vnrat
+ forc_soll(j) = a*(1.0-difrat)*(1.0-vnrat)
+ forc_solsd(j) = a*difrat*vnrat
+ forc_solld(j) = a*difrat*(1.0-vnrat)
+ ENDDO
+ ENDIF
+ ENDIF
+
+#ifdef RangeCheck
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+ IF (p_is_root) write(*,'(/, A20)') 'Checking forcing ...'
+
+ CALL check_vector_data ('Forcing us [m/s] ', forc_us )
+ CALL check_vector_data ('Forcing vs [m/s] ', forc_vs )
+ CALL check_vector_data ('Forcing t [kelvin]', forc_t )
+ CALL check_vector_data ('Forcing q [kg/kg] ', forc_q )
+ CALL check_vector_data ('Forcing prc [mm/s] ', forc_prc )
+ CALL check_vector_data ('Forcing psrf [pa] ', forc_psrf )
+ CALL check_vector_data ('Forcing prl [mm/s] ', forc_prl )
+ CALL check_vector_data ('Forcing sols [W/m2] ', forc_sols )
+ CALL check_vector_data ('Forcing soll [W/m2] ', forc_soll )
+ CALL check_vector_data ('Forcing solsd [W/m2] ', forc_solsd)
+ CALL check_vector_data ('Forcing solld [W/m2] ', forc_solld)
+ CALL check_vector_data ('Forcing frl [W/m2] ', forc_frl )
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ CALL check_vector_data ('Forcing hpbl ', forc_hpbl )
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+#endif
+
+ END SUBROUTINE read_forcing
+
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+! read lower and upper boundary forcing data, a major interface of this
+! MODULE
+!
+! !REVISIONS:
+! 04/2014, Hua Yuan: initial code
+!
+!-----------------------------------------------------------------------
+ SUBROUTINE metreadLBUB (idate, dir_forcing, is_spinup)
+
+ USE MOD_UserSpecifiedForcing
+ USE MOD_Namelist
+ USE MOD_Block
+ USE MOD_DataType
+ USE MOD_Block
+ USE MOD_NetCDFBlock
+ USE MOD_RangeCheck
+ IMPLICIT NONE
+
+ integer, intent(in) :: idate(3)
+ character(len=*), intent(in) :: dir_forcing
+ logical, intent(in) :: is_spinup
+
+ ! Local variables
+ integer :: ivar, year, month, day, time_i
+ integer :: iblkme, ib, jb, i, j
+ type(timestamp) :: mtstamp
+ character(len=256) :: filename
+
+ mtstamp = idate
+
+ DO ivar = 1, NVAR
+
+ IF (trim(vname(ivar)) == 'NULL') CYCLE ! no data, CYCLE
+
+ ! lower and upper boundary data already exist, CYCLE
+ IF ( .not.(tstamp_LB(ivar)=='NULL') .and. .not.(tstamp_UB(ivar)=='NULL') .and. &
+ tstamp_LB(ivar)<=mtstamp .and. mtstampendyr .or. (month>endmo .and. year==endyr) ) THEN
+ write(*,*) 'model year/month: ', year, month
+ write(*,*) 'forcing end year/month defined: ', endyr, endmo
+ print *, 'Warning: reaching the END of forcing data defined!'
+ ENDIF
+
+ ! read forcing data
+ filename = trim(dir_forcing)//trim(metfilename(year, month, day, ivar, is_spinup))
+ IF (trim(DEF_forcing%dataset) == 'POINT') THEN
+
+ IF (forcing_read_ahead) THEN
+ metdata%blk(gblock%xblkme(1),gblock%yblkme(1))%val = forc_disk(time_i,ivar)
+ ELSE
+#ifndef URBAN_MODEL
+ CALL ncio_read_site_time (filename, vname(ivar), time_i, metdata)
+#else
+ IF (trim(vname(ivar)) == 'Rainf') THEN
+ CALL ncio_read_site_time (filename, 'Rainf', time_i, rainf)
+ CALL ncio_read_site_time (filename, 'Snowf', time_i, snowf)
+
+ DO iblkme = 1, gblock%nblkme
+ ib = gblock%xblkme(iblkme)
+ jb = gblock%yblkme(iblkme)
+
+ metdata%blk(ib,jb)%val(1,1) = rainf%blk(ib,jb)%val(1,1) &
+ + snowf%blk(ib,jb)%val(1,1)
+ ENDDO
+ ELSE
+ CALL ncio_read_site_time (filename, vname(ivar), time_i, metdata)
+ ENDIF
+#endif
+ ENDIF
+ ELSE
+ CALL ncio_read_block_time (filename, vname(ivar), gforc, time_i, metdata)
+ ENDIF
+
+ CALL block_data_copy (metdata, forcn_UB(ivar))
+
+ ! calculate time average coszen, for shortwave radiation
+ IF (ivar == 7) THEN
+ CALL calavgcos(idate)
+ ENDIF
+ ENDIF
+
+ ENDDO
+
+ END SUBROUTINE metreadLBUB
+
+
+!-----------------------------------------------------------------------
+ SUBROUTINE metread_latlon (dir_forcing, idate)
+
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_UserSpecifiedForcing
+ USE MOD_Namelist
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: dir_forcing
+ integer, intent(in) :: idate(3)
+
+ ! Local variables
+ character(len=256) :: filename
+ integer :: year, month, day, time_i
+ type(timestamp) :: mtstamp
+ real(r8), allocatable :: latxy (:,:) ! latitude values in 2d
+ real(r8), allocatable :: lonxy (:,:) ! longitude values in 2d
+ real(r8), allocatable :: lon_in(:)
+ real(r8), allocatable :: lat_in(:)
+
+ IF (trim(DEF_forcing%dataset) == 'POINT' .or. trim(DEF_forcing%dataset) == 'CPL7' ) THEN
+ CALL gforc%define_by_ndims (360, 180)
+ ELSE
+
+ mtstamp = idate
+
+ CALL setstampLB(mtstamp, 1, year, month, day, time_i)
+ filename = trim(dir_forcing)//trim(metfilename(year, month, day, 1))
+ tstamp_LB(1) = timestamp(-1, -1, -1)
+
+ IF (dim2d) THEN
+ CALL ncio_read_bcast_serial (filename, latname, latxy)
+ CALL ncio_read_bcast_serial (filename, lonname, lonxy)
+
+ allocate (lat_in (size(latxy,2)))
+ allocate (lon_in (size(lonxy,1)))
+ lat_in = latxy(1,:)
+ lon_in = lonxy(:,1)
+
+ deallocate (latxy)
+ deallocate (lonxy)
+ ELSE
+ CALL ncio_read_bcast_serial (filename, latname, lat_in)
+ CALL ncio_read_bcast_serial (filename, lonname, lon_in)
+ ENDIF
+
+ IF (.not. DEF_forcing%regional) THEN
+ CALL gforc%define_by_center (lat_in, lon_in)
+ ELSE
+ CALL gforc%define_by_center (lat_in, lon_in, &
+ south = DEF_forcing%regbnd(1), north = DEF_forcing%regbnd(2), &
+ west = DEF_forcing%regbnd(3), east = DEF_forcing%regbnd(4))
+ ENDIF
+
+ deallocate (lat_in)
+ deallocate (lon_in)
+ ENDIF
+
+ CALL gforc%set_rlon ()
+ CALL gforc%set_rlat ()
+
+ END SUBROUTINE metread_latlon
+
+!-----------------------------------------------------------------------
+ SUBROUTINE metread_time (dir_forcing, ststamp, etstamp, deltime)
+
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_UserSpecifiedForcing
+ USE MOD_Namelist
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: dir_forcing
+ type(timestamp), intent(in), optional :: ststamp, etstamp
+ real(r8), intent(in), optional :: deltime
+
+ ! Local variables
+ character(len=256) :: filename
+ character(len=256) :: timeunit, timestr
+ real(r8), allocatable :: forctime_sec(:), metcache(:,:,:)
+ integer :: year, month, day, hour, minute, second
+ integer :: itime, maxday, id(3)
+ integer*8 :: sec_long
+ integer :: ivar, ntime, its, ite, it
+ real(r8) firstsec
+
+ type(timestamp) :: etstamp_f
+ type(timestamp), allocatable :: forctime_ (:)
+
+
+ filename = trim(dir_forcing)//trim(fprefix(1))
+
+ CALL ncio_read_serial (filename, 'time', forctime_sec)
+ CALL ncio_get_attr (filename, 'time', 'units', timeunit)
+
+ timestr = timeunit(15:18) // ' ' // timeunit(20:21) // ' ' // timeunit(23:24) &
+ // ' ' // timeunit(26:27) // ' ' // timeunit(29:30) // ' ' // timeunit(32:33)
+ read(timestr,*) year, month, day, hour, minute, second
+
+ allocate (forctime (size(forctime_sec)))
+
+ id(1) = year
+ id(2) = get_calday(month*100+day, isleapyear(year))
+ id(3) = hour*3600 + minute*60 + second
+
+ firstsec = forctime_sec(1)
+ DO WHILE (firstsec > 86400)
+ CALL ticktime (86400., id)
+ firstsec = firstsec - 86400
+ ENDDO
+ CALL ticktime (firstsec, id)
+
+ !forctime(1)%year = year
+ !forctime(1)%day = get_calday(month*100+day, isleapyear(year))
+ !forctime(1)%sec = hour*3600 + minute*60 + second + forctime_sec(1)
+
+ !id(:) = (/forctime(1)%year, forctime(1)%day, forctime(1)%sec/)
+ CALL adj2end(id)
+ forctime(1) = id
+
+ ntime = size(forctime)
+
+ DO itime = 2, ntime
+ id(:) = (/forctime(itime-1)%year, forctime(itime-1)%day, forctime(itime-1)%sec/)
+ CALL ticktime (forctime_sec(itime)-forctime_sec(itime-1), id)
+ forctime(itime) = id
+ ENDDO
+
+ IF (forcing_read_ahead) THEN
+
+ CALL ticktime (deltime, id)
+ etstamp_f = id
+
+ IF ((ststamp < forctime(1)) .or. (etstamp_f < etstamp)) THEN
+ write(*,*) 'Error: Forcing does not cover simulation period!'
+ write(*,*) 'Model start ', ststamp, ' -> Model END ', etstamp
+ write(*,*) 'Forc start ', forctime(1), ' -> Forc END ', etstamp_f
+ CALL CoLM_stop ()
+ ELSE
+ its = 1
+ DO WHILE (.not. (ststamp < forctime(its+1)))
+ its = its + 1
+ IF (its >= ntime) EXIT
+ ENDDO
+
+ ite = ntime
+ DO WHILE (etstamp < forctime(ite-1))
+ ite = ite - 1
+ IF (ite <= 1) EXIT
+ ENDDO
+
+ ntime = ite-its+1
+
+ allocate (forctime_(ntime))
+ DO it = 1, ntime
+ forctime_(it) = forctime(it+its-1)
+ ENDDO
+
+ deallocate (forctime)
+ allocate (forctime (ntime))
+ DO it = 1, ntime
+ forctime(it) = forctime_(it)
+ ENDDO
+
+ deallocate(forctime_)
+ ENDIF
+
+ allocate (forc_disk (size(forctime),NVAR))
+
+ filename = trim(dir_forcing)//trim(metfilename(-1,-1,-1,-1))
+ DO ivar = 1, NVAR
+ IF (trim(vname(ivar)) /= 'NULL') THEN
+#ifndef URBAN_MODEL
+ CALL ncio_read_period_serial (filename, vname(ivar), its, ite, metcache)
+ forc_disk(:,ivar) = metcache(1,1,:)
+#else
+ IF (trim(vname(ivar)) == 'Rainf') THEN
+ CALL ncio_read_period_serial (filename, 'Rainf', its, ite, metcache)
+ forc_disk(:,ivar) = metcache(1,1,:)
+
+ CALL ncio_read_period_serial (filename, 'Snowf', its, ite, metcache)
+ forc_disk(:,ivar) = forc_disk(:,ivar) + metcache(1,1,:)
+ ELSE
+ CALL ncio_read_period_serial (filename, vname(ivar), its, ite, metcache)
+ forc_disk(:,ivar) = metcache(1,1,:)
+ ENDIF
+#endif
+ ENDIF
+ ENDDO
+
+ IF (allocated(metcache)) deallocate(metcache)
+ ENDIF
+
+ END SUBROUTINE metread_time
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+! set the lower boundary time stamp and record information,
+! a KEY FUNCTION of this MODULE
+!
+! - for time stamp, set it regularly as the model time step.
+! - for record information, account for:
+! o year alternation
+! o month alternation
+! o leap year
+! o required data just beyond the first record
+!
+! !REVISIONS:
+! 04/2014, Hua Yuan: initial code
+!
+!-----------------------------------------------------------------------
+ SUBROUTINE setstampLB(mtstamp, var_i, year, month, mday, time_i)
+
+ IMPLICIT NONE
+ type(timestamp), intent(in) :: mtstamp
+ integer, intent(in) :: var_i
+ integer, intent(out) :: year
+ integer, intent(out) :: month
+ integer, intent(out) :: mday
+ integer, intent(out) :: time_i
+
+ integer :: i, day, sec, ntime
+ integer :: months(0:12)
+
+ year = mtstamp%year
+ day = mtstamp%day
+ sec = mtstamp%sec
+
+ IF (trim(DEF_forcing%dataset) == 'POINT') THEN
+
+ ntime = size(forctime)
+ time_i = 1
+
+ IF ((mtstamp < forctime(1)) .or. (forctime(ntime) < mtstamp)) THEN
+ write(*,*) 'Error: Forcing does not cover simulation period!'
+ write(*,*) 'Need ', mtstamp, ', Forc start ', forctime(1), ', Forc END', forctime(ntime)
+ CALL CoLM_stop ()
+ ELSE
+ DO WHILE (.not. (mtstamp < forctime(time_i+1)))
+ time_i = time_i + 1
+ ENDDO
+ iforctime(var_i) = time_i
+ tstamp_LB(var_i) = forctime(iforctime(var_i))
+ ENDIF
+
+ RETURN
+ ENDIF
+
+ tstamp_LB(var_i)%year = year
+ tstamp_LB(var_i)%day = day
+
+ ! in the case of one year one file
+ IF ( trim(groupby) == 'year' ) THEN
+
+ ! calculate the initial second
+ sec = 86400*(day-1) + sec
+ time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1
+ sec = (time_i-1)*dtime(var_i) + offset(var_i) - 86400*(day-1)
+ tstamp_LB(var_i)%sec = sec
+
+ ! set time stamp (ststamp_LB)
+ IF (sec < 0) THEN
+ tstamp_LB(var_i)%sec = 86400 + sec
+ tstamp_LB(var_i)%day = day - 1
+ IF (tstamp_LB(var_i)%day == 0) THEN
+ tstamp_LB(var_i)%year = year - 1
+ IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN
+ tstamp_LB(var_i)%day = 366
+ ELSE
+ tstamp_LB(var_i)%day = 365
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ! set record info (year, time_i)
+ IF ( sec<0 .or. (sec==0 .and. offset(var_i).NE.0) ) THEN
+
+ ! IF the required data just behind the first record
+ ! -> set to the first record
+ IF ( year==startyr .and. month==startmo .and. day==1 ) THEN
+ sec = offset(var_i)
+
+ ! ELSE, set to one record backward
+ ELSE
+ sec = 86400 + sec
+ day = day - 1
+ IF (day == 0) THEN
+ year = year - 1
+ IF ( isleapyear(year) ) THEN
+ day = 366
+ ELSE
+ day = 365
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF ! ENDIF (sec <= 0)
+
+ ! in case of leapyear with a non-leapyear calendar
+ ! USE the data 1 day before after FEB 28th (Julian day 59).
+ IF ( .not. leapyear .and. isleapyear(year) .and. day>59 ) THEN
+ day = day - 1
+ ENDIF
+
+ ! get record time index
+ sec = 86400*(day-1) + sec
+ time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1
+ ENDIF
+
+ ! in the case of one month one file
+ IF ( trim(groupby) == 'month' ) THEN
+
+ IF ( isleapyear(year) ) THEN
+ months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/)
+ ELSE
+ months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/)
+ ENDIF
+
+ ! calculate initial month and day values
+ CALL julian2monthday(year, day, month, mday)
+
+ ! calculate initial second value
+ sec = 86400*(mday-1) + sec
+ time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1
+ sec = (time_i-1)*dtime(var_i) + offset(var_i) - 86400*(mday-1)
+ tstamp_LB(var_i)%sec = sec
+
+ ! set time stamp (ststamp_LB)
+ IF (sec < 0) THEN
+ tstamp_LB(var_i)%sec = 86400 + sec
+ tstamp_LB(var_i)%day = day - 1
+ IF (tstamp_LB(var_i)%day == 0) THEN
+ tstamp_LB(var_i)%year = year - 1
+ IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN
+ tstamp_LB(var_i)%day = 366
+ ELSE
+ tstamp_LB(var_i)%day = 365
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ! set record info (year, month, time_i)
+ IF ( sec<0 .or. (sec==0 .and. offset(var_i).ne.0) ) THEN
+
+ ! IF just behind the first record -> set to first record
+ IF ( year==startyr .and. month==startmo .and. mday==1 ) THEN
+ sec = offset(var_i)
+
+ ! set to one record backward
+ ELSE
+ sec = 86400 + sec
+ mday = mday - 1
+ IF (mday == 0) THEN
+ month = month - 1
+ ! bug found by Zhu Siguang & Zhang Xiangxiang, 05/19/2014
+ ! move the below line in the 'ELSE' statement
+ !mday = months(month) - months(month-1)
+ IF (month == 0) THEN
+ month = 12
+ year = year - 1
+ mday = 31
+ ELSE
+ mday = months(month) - months(month-1)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ! in case of leapyear with a non-leapyear calendar
+ ! USE the data 1 day before, i.e., FEB 28th.
+ IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN
+ mday = 28
+ ENDIF
+
+ ! get record time index
+ sec = 86400*(mday-1) + sec
+ time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1
+ ENDIF
+
+ ! in the case of one day one file
+ IF ( trim(groupby) == 'day' ) THEN
+
+ ! calculate initial month and day values
+ CALL julian2monthday(year, day, month, mday)
+
+ ! calculate initial second value
+ time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1
+ sec = (time_i-1)*dtime(var_i) + offset(var_i)
+ tstamp_LB(var_i)%sec = sec
+
+ ! set time stamp (ststamp_LB)
+ IF (sec < 0) THEN
+ tstamp_LB(var_i)%sec = 86400 + sec
+ tstamp_LB(var_i)%day = day - 1
+ IF (tstamp_LB(var_i)%day == 0) THEN
+ tstamp_LB(var_i)%year = year - 1
+ IF ( isleapyear(tstamp_LB(var_i)%year) ) THEN
+ tstamp_LB(var_i)%day = 366
+ ELSE
+ tstamp_LB(var_i)%day = 365
+ ENDIF
+ ENDIF
+
+ IF ( year==startyr .and. month==startmo .and. mday==1 ) THEN
+ sec = offset(var_i)
+ ! set to one record backward
+ ELSE
+ sec = 86400 + sec
+ year = tstamp_LB(var_i)%year
+ CALL julian2monthday(tstamp_LB(var_i)%year, tstamp_LB(var_i)%day, month, mday)
+ ENDIF
+ ENDIF
+
+ ! in case of leapyear with a non-leapyear calendar
+ ! USE the data 1 day before, i.e., FEB 28th.
+ IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN
+ mday = 28
+ ENDIF
+
+ ! get record time index
+ time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1
+ ENDIF
+
+ IF (time_i <= 0) THEN
+ write(6, *) "got the wrong time record of forcing! STOP!"; CALL CoLM_stop()
+ ENDIF
+
+ RETURN
+
+ END SUBROUTINE setstampLB
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+! set the upper boundary time stamp and record information,
+! a KEY FUNCTION of this MODULE
+!
+! !REVISIONS:
+! 04/2014, Hua Yuan: initial code
+!
+!-----------------------------------------------------------------------
+ SUBROUTINE setstampUB(var_i, year, month, mday, time_i)
+
+ IMPLICIT NONE
+ integer, intent(in) :: var_i
+ integer, intent(out) :: year
+ integer, intent(out) :: month
+ integer, intent(out) :: mday
+ integer, intent(out) :: time_i
+
+ integer :: day, sec
+ integer :: months(0:12)
+
+ IF (trim(DEF_forcing%dataset) == 'POINT') THEN
+ IF ( tstamp_UB(var_i) == 'NULL' ) THEN
+ tstamp_UB(var_i) = forctime(iforctime(var_i)+1)
+ ELSE
+ iforctime(var_i) = iforctime(var_i) + 1
+ tstamp_LB(var_i) = forctime(iforctime(var_i))
+ tstamp_UB(var_i) = forctime(iforctime(var_i)+1)
+ ENDIF
+
+ time_i = iforctime(var_i)+1
+ year = tstamp_UB(var_i)%year
+ day = tstamp_UB(var_i)%day
+
+ CALL julian2monthday(year, day, month, mday)
+
+ RETURN
+ ENDIF
+
+ ! calculate the time stamp
+ IF ( tstamp_UB(var_i) == 'NULL' ) THEN
+ tstamp_UB(var_i) = tstamp_LB(var_i) + dtime(var_i)
+ ELSE
+ tstamp_LB(var_i) = tstamp_UB(var_i)
+ tstamp_UB(var_i) = tstamp_UB(var_i) + dtime(var_i)
+ ENDIF
+
+ ! calculate initial year, day, and second values
+ year = tstamp_UB(var_i)%year
+ day = tstamp_UB(var_i)%day
+ sec = tstamp_UB(var_i)%sec
+
+ IF ( trim(groupby) == 'year' ) THEN
+
+ ! adjust year value
+ IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN
+ sec = 0
+ day = day + 1
+ IF( isleapyear(year) .and. day==367) THEN
+ year = year + 1; day = 1
+ ENDIF
+ IF( .not. isleapyear(year) .and. day==366) THEN
+ year = year + 1; day = 1
+ ENDIF
+ ENDIF
+
+ ! in case of leapyear with a non-leapyear calendar
+ ! USE the data 1 day before after FEB 28th (Julian day 59).
+ IF ( .not. leapyear .and. isleapyear(year) .and. day>59 ) THEN
+ day = day - 1
+ ENDIF
+
+ ! set record index
+ sec = 86400*(day-1) + sec
+ time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1
+ ENDIF
+
+ IF ( trim(groupby) == 'month' ) THEN
+
+ IF ( isleapyear(year) ) THEN
+ months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/)
+ ELSE
+ months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/)
+ ENDIF
+
+ ! calculate initial month and day values
+ CALL julian2monthday(year, day, month, mday)
+
+ ! record in the next day, adjust year, month and second values
+ IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN
+ sec = 0
+ mday = mday + 1
+ IF ( mday > (months(month)-months(month-1)) ) THEN
+ mday = 1
+ ! bug found by Zhu Siguang, 05/25/2014
+ ! move the below line in the 'ELSE' statement
+ !month = month + 1
+ IF (month == 12) THEN
+ month = 1
+ year = year + 1
+ ELSE
+ month = month + 1
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ! in case of leapyear with a non-leapyear calendar
+ ! for day 29th Feb, USE the data 1 day before, i.e., 28th FEB.
+ IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN
+ mday = 28
+ ENDIF
+
+ ! set record index
+ sec = 86400*(mday-1) + sec
+ time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1
+ ENDIF
+
+ IF ( trim(groupby) == 'day' ) THEN
+ IF ( isleapyear(year) ) THEN
+ months = (/0,31,60,91,121,152,182,213,244,274,305,335,366/)
+ ELSE
+ months = (/0,31,59,90,120,151,181,212,243,273,304,334,365/)
+ ENDIF
+
+ ! calculate initial month and day values
+ CALL julian2monthday(year, day, month, mday)
+ !mday = day
+
+ ! record in the next day, adjust year, month and second values
+ IF ( sec==86400 .and. offset(var_i).eq.0 ) THEN
+ sec = 0
+ mday = mday + 1
+ IF ( mday > (months(month)-months(month-1)) ) THEN
+ mday = 1
+ ! bug found by Zhu Siguang, 05/25/2014
+ ! move the below line in the 'ELSE' statement
+ !month = month + 1
+ IF (month == 12) THEN
+ month = 1
+ year = year + 1
+ ELSE
+ month = month + 1
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ! in case of leapyear with a non-leapyear calendar
+ ! for day 29th Feb, USE the data 1 day before, i.e., 28th FEB.
+ IF ( .not. leapyear .and. isleapyear(year) .and. month==2 .and. mday==29 ) THEN
+ mday = 28
+ ENDIF
+
+ ! set record index
+ time_i = floor( (sec-offset(var_i)) *1. / dtime(var_i) ) + 1
+ ENDIF
+
+ IF (time_i < 0) THEN
+ write(6, *) "got the wrong time record of forcing! STOP!"; CALL CoLM_stop()
+ ENDIF
+
+ RETURN
+
+ END SUBROUTINE setstampUB
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+! calculate time average coszen value between [LB, UB]
+!
+! !REVISIONS:
+! 04/2014, Hua Yuan: this method is adapted from CLM
+!
+!-----------------------------------------------------------------------
+ SUBROUTINE calavgcos(idate)
+
+ USE MOD_Block
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ integer, intent(in) :: idate(3)
+
+ integer :: ntime, iblkme, ib, jb, i, j, ilon, ilat
+ real(r8) :: calday, cosz
+ type(timestamp) :: tstamp
+
+ tstamp = idate !tstamp_LB(7)
+ ntime = 0
+ DO WHILE (tstamp < tstamp_UB(7))
+ ntime = ntime + 1
+ tstamp = tstamp + deltim_int
+ ENDDO
+
+ tstamp = idate !tstamp_LB(7)
+ CALL flush_block_data (avgcos, 0._r8)
+
+ DO WHILE (tstamp < tstamp_UB(7))
+
+ DO iblkme = 1, gblock%nblkme
+ ib = gblock%xblkme(iblkme)
+ jb = gblock%yblkme(iblkme)
+ DO j = 1, gforc%ycnt(jb)
+ DO i = 1, gforc%xcnt(ib)
+
+ ilat = gforc%ydsp(jb) + j
+ ilon = gforc%xdsp(ib) + i
+ IF (ilon > gforc%nlon) ilon = ilon - gforc%nlon
+
+ calday = calendarday(tstamp)
+ cosz = orb_coszen(calday, gforc%rlon(ilon), gforc%rlat(ilat))
+ cosz = max(0.001, cosz)
+ avgcos%blk(ib,jb)%val(i,j) = avgcos%blk(ib,jb)%val(i,j) &
+ + cosz / real(ntime,r8) ! * deltim_real /real(tstamp_UB(7)-tstamp_LB(7))
+
+ ENDDO
+ ENDDO
+ ENDDO
+
+ tstamp = tstamp + deltim_int
+
+ ENDDO
+
+ END SUBROUTINE calavgcos
+
+END MODULE MOD_Forcing
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90
new file mode 100644
index 0000000000..c557b30784
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_ForcingDownscaling.F90
@@ -0,0 +1,1049 @@
+#include
+
+MODULE MOD_ForcingDownscaling
+
+!-----------------------------------------------------------------------------
+! !DESCRIPTION:
+! Downscaling meteorological forcings
+!
+! !INITIAL:
+! The Community Land Model version 5.0 (CLM5.0)
+!
+! !REVISIONS:
+! Updated by Yongjiu Dai, January 16, 2023
+! Revised by Lu Li, January 24, 2024
+! Revised by Sisi Chen, Lu Li, June, 2024
+!-----------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Qsadv
+ USE MOD_Namelist
+ USE MOD_Const_Physical
+ USE MOD_Vars_Global
+ USE MOD_UserDefFun
+
+ IMPLICIT NONE
+
+ real(r8), parameter :: SHR_CONST_MWDAIR = 28.966_r8 ! molecular weight dry air [kg/kmole]
+ real(r8), parameter :: SHR_CONST_MWWV = 18.016_r8 ! molecular weight water vapor
+ real(r8), parameter :: SHR_CONST_AVOGAD = 6.02214e26_r8 ! Avogadro's number [molecules/kmole]
+ real(r8), parameter :: SHR_CONST_BOLTZ = 1.38065e-23_r8 ! Boltzmann's constant [J/K/molecule]
+ ! Universal gas constant [J/K/kmole]
+ real(r8), parameter :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ
+ ! Dry air gas constant [J/K/kg]
+ real(r8), parameter :: rair = SHR_CONST_RGAS/SHR_CONST_MWDAIR
+
+ ! On the windward side of the range, annual mean lapse rates of 3.9-5.2 (deg km-1), substantially
+ ! smaller than the often-assumed 6.5 (deg km-1). The data sets show similar seasonal and diurnal
+ ! variability, with lapse rates smallest (2.5-3.5 deg km-1) in late-summer minimum temperatures,
+ ! and largest (6.5-7.5 deg km-1) in spring maximum temperatures. Geographic (windward versus lee
+ ! side) differences in lapse rates are substantial. [Minder et al., 2010, Surface temperature
+ ! lapse rates over complex terrain: Lessons from the Cascade Mountains. JGR, 115,
+ ! doi:10.1029/2009JD013493]
+ !
+ ! Kunkel, K. E., 1989: Simple procedures for extrapolation of humidity variables in the
+ ! mountainous western United States. J. Climate, 2, 656-669. lapse_rate = /Jan -
+ ! Dec/4.4,5.9,7.1,7.8,8.1,8.2,8.1,8.1,7.7,6.8,5.5,4.7/ (deg km-1)
+ real(r8), parameter :: lapse_rate = 0.006_r8 ! surface temperature lapse rate (deg m-1)
+
+ SAVE
+
+! PUBLIC MEMBER FUNCTIONS:
+ PUBLIC :: downscale_forcings ! Downscale atmospheric forcing
+
+! PRIVATE MEMBER FUNCTIONS:
+ PRIVATE :: rhos ! calculate atmospheric density
+
+!-----------------------------------------------------------------------------
+
+CONTAINS
+
+!-----------------------------------------------------------------------------
+
+ PURE FUNCTION rhos(qbot, pbot, tbot)
+
+!-----------------------------------------------------------------------------
+! DESCRIPTION:
+! Compute atmospheric density (kg/m**3)
+!-----------------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ ! ARGUMENTS:
+ real(r8) :: rhos ! function result: atmospheric density (kg/m**3)
+ real(r8), intent(in) :: qbot ! atmospheric specific humidity (kg/kg)
+ real(r8), intent(in) :: pbot ! atmospheric pressure (Pa)
+ real(r8), intent(in) :: tbot ! atmospheric temperature (K)
+
+ ! LOCAL VARIABLES:
+ real(r8) :: egcm
+ real(r8) :: wv_to_dair_weight_ratio ! ratio of molecular weight of water vapor to dry air [-]
+
+ wv_to_dair_weight_ratio = SHR_CONST_MWWV/SHR_CONST_MWDAIR
+
+ egcm = qbot*pbot / (wv_to_dair_weight_ratio + (1._r8 - wv_to_dair_weight_ratio)*qbot)
+ rhos = (pbot - (1._r8 - wv_to_dair_weight_ratio)*egcm) / (rair*tbot)
+
+ END FUNCTION rhos
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE downscale_forcings (&
+ glaciers, &
+
+ ! non-adjusted forcing
+ forc_topo_g ,forc_maxelv_g ,forc_t_g ,forc_th_g ,forc_q_g ,&
+ forc_pbot_g ,forc_rho_g ,forc_prc_g ,forc_prl_g ,forc_lwrad_g ,&
+ forc_hgt_g ,forc_swrad_g ,forc_us_g ,forc_vs_g , &
+
+ ! topography-based factor on patch
+ slp_type_c, asp_type_c, cur_c, &
+
+ ! other factors
+ julian_day, coszen, cosazi, &
+
+ ! adjusted forcing
+ forc_topo_c ,forc_t_c ,forc_th_c ,forc_q_c ,forc_pbot_c ,&
+ forc_rho_c ,forc_prc_c ,forc_prl_c ,forc_lwrad_c, forc_swrad_c, &
+ forc_us_c ,forc_vs_c, &
+
+ ! optional parameters for full downscaling
+ area_type_c, svf_c, alb, &
+#ifdef SinglePoint
+ sf_lut_c &
+#else
+ sf_curve_c &
+#endif
+ )
+
+!-----------------------------------------------------------------------------
+! !DESCRIPTION:
+! Downscale atmospheric forcing fields.
+!
+! Downscaling is done based on the difference between each land model
+! column's elevation and the atmosphere's surface elevation (which is
+! the elevation at which the atmospheric forcings are valid).
+!
+! Note that the downscaling procedure can result in changes in grid
+! cell mean values compared to what was provided by the atmosphere. We
+! conserve fluxes of mass and energy, but allow states such as
+! temperature to differ.
+!-----------------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ integer, parameter :: S = 1370 ! solar constant (W/m**2)
+ real(r8), parameter :: thr = 85*PI/180 ! threshold of zenith angle
+
+ ! ARGUMENTS:
+ logical, intent(in) :: glaciers ! true: glacier column (itypwat = 3)
+ real(r8), intent(in) :: julian_day ! day of year
+ real(r8), intent(in) :: coszen ! cosine of sun zenith angle at an hour
+ real(r8), intent(in) :: cosazi ! cosine of sun azimuth angle at an hour
+
+ ! topography-based factor
+ real(r8), intent(in) :: cur_c ! curvature
+ ! topographic aspect of each type of one patch(rad) - can be different dimensions
+ real(r8), intent(in) :: asp_type_c (:)
+ ! topographic slope of each character of one patch - can be different dimensions
+ real(r8), intent(in) :: slp_type_c (:)
+
+ ! optional parameters for complex downscaling
+ real(r8), intent(in), optional :: alb ! blue sky albedo
+ real(r8), intent(in), optional :: svf_c ! sky view factor
+ ! area percentage of each character of one patch
+ real(r8), intent(in), optional :: area_type_c(:)
+#ifdef SinglePoint
+ ! look up table of shadow mask of a patch
+ real(r8), intent(in), optional :: sf_lut_c (:,:)
+#else
+ ! curve of shadow mask of a patch
+ real(r8), intent(in), optional :: sf_curve_c (:,:)
+#endif
+
+ ! non-downscaled fields:
+ real(r8), intent(in) :: forc_topo_g ! atmospheric surface height [m]
+ real(r8), intent(in) :: forc_maxelv_g ! max atmospheric surface height [m]
+ real(r8), intent(in) :: forc_t_g ! atmospheric temperature [Kelvin]
+ real(r8), intent(in) :: forc_th_g ! atmospheric potential temperature [Kelvin]
+ real(r8), intent(in) :: forc_q_g ! atmospheric specific humidity [kg/kg]
+ real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa]
+ real(r8), intent(in) :: forc_rho_g ! atmospheric density [kg/m**3]
+ real(r8), intent(in) :: forc_prc_g ! convective precipitation in grid [mm/s]
+ real(r8), intent(in) :: forc_prl_g ! large-scale precipitation in grid [mm/s]
+ real(r8), intent(in) :: forc_lwrad_g ! grid downward longwave [W/m**2]
+ real(r8), intent(in) :: forc_swrad_g ! grid downward shortwave [W/m**2]
+ real(r8), intent(in) :: forc_hgt_g ! atmospheric reference height [m]
+ real(r8), intent(in) :: forc_us_g ! eastward wind [m/s]
+ real(r8), intent(in) :: forc_vs_g ! northward wind [m/s]
+
+ ! downscaled fields:
+ real(r8), intent(in) :: forc_topo_c ! column surface height [m]
+ real(r8), intent(out) :: forc_t_c ! atmospheric temperature [Kelvin]
+ real(r8), intent(out) :: forc_th_c ! atmospheric potential temperature [Kelvin]
+ real(r8), intent(out) :: forc_q_c ! atmospheric specific humidity [kg/kg]
+ real(r8), intent(out) :: forc_pbot_c ! atmospheric pressure [Pa]
+ real(r8), intent(out) :: forc_rho_c ! atmospheric density [kg/m**3]
+ real(r8), intent(out) :: forc_prc_c ! column convective precipitation [mm/s]
+ real(r8), intent(out) :: forc_prl_c ! column large-scale precipitation [mm/s]
+ real(r8), intent(out) :: forc_lwrad_c ! column downward longwave [W/m**2]
+ real(r8), intent(out) :: forc_swrad_c ! column downward shortwave [W/m**2]
+ real(r8), intent(out) :: forc_us_c ! column eastward wind [m/s]
+ real(r8), intent(out) :: forc_vs_c ! column northward wind [m/s]
+
+ ! Local variables for topo downscaling:
+ real(r8) :: hsurf_g, hsurf_c
+ real(r8) :: Hbot, zbot
+ real(r8) :: tbot_g, pbot_g, thbot_g, qbot_g, qs_g, es_g, rhos_g
+ real(r8) :: tbot_c, pbot_c, thbot_c, qbot_c, qs_c, es_c, rhos_c
+ real(r8) :: rhos_c_estimate, rhos_g_estimate
+ real(r8) :: dum1, dum2
+ real(r8) :: max_elev_c ! the maximum column level elevation value within the grid
+ real(r8) :: delta_prc_c ! deviation of the column convective prec. from the grid level prec.
+ real(r8) :: delta_prl_c ! deviation of the column large-scale prec. from the grid level prec.
+
+!-----------------------------------------------------------------------------
+
+ ! --------------------------------------------------------------------------------------
+ ! 1. adjust air temperature, potential temperature, specific humidity, pressure, density
+ ! --------------------------------------------------------------------------------------
+ hsurf_g = forc_topo_g ! gridcell sfc elevation
+ tbot_g = forc_t_g ! atm sfc temp
+ thbot_g = forc_th_g ! atm sfc pot temp
+ qbot_g = forc_q_g ! atm sfc spec humid
+ pbot_g = forc_pbot_g ! atm sfc pressure
+ rhos_g = forc_rho_g ! atm density
+ zbot = forc_hgt_g ! atm ref height
+
+ hsurf_c = forc_topo_c ! column sfc elevation
+ tbot_c = tbot_g-lapse_rate*(hsurf_c-hsurf_g) ! adjust [temp] for column
+ Hbot = rair*0.5_r8*(tbot_g+tbot_c)/grav ! scale ht at avg temp
+ pbot_c = pbot_g*exp(-(hsurf_c-hsurf_g)/Hbot) ! adjust [press] for column
+
+ ! Derivation of potential temperature calculation:
+ !
+ ! The textbook definition would be:
+ ! thbot_c = tbot_c * (p0/pbot_c)^(rair/cpair)
+ !
+ ! Note that pressure is related to scale height as:
+ ! pbot_c = p0 * exp(-zbot/Hbot)
+ !
+ ! Plugging this in to the textbook definition, then manipulating, we get:
+ ! thbot_c = tbot_c * (p0/(p0*exp(-zbot/Hbot)))^(rair/cpair)
+ ! = tbot_c * (1/exp(-zbot/Hbot))^(rair/cpair)
+ ! = tbot_c * (exp(zbot/Hbot))^(rair/cpair)
+ ! = tbot_c * exp((zbot/Hbot) * (rair/cpair))
+
+ ! But we want everything expressed in delta form, resulting in:
+ ! adjust [pot temp] for column
+ thbot_c = thbot_g + (tbot_c - tbot_g)*exp((zbot/Hbot)*(rair/cpair))
+
+ CALL Qsadv(tbot_g,pbot_g,es_g,dum1,qs_g,dum2) ! es, qs for gridcell
+ CALL Qsadv(tbot_c,pbot_c,es_c,dum1,qs_c,dum2) ! es, qs for column
+ qbot_c = qbot_g*(qs_c/qs_g) ! adjust [q] for column
+
+ rhos_c_estimate = rhos(qbot=qbot_c, pbot=pbot_c, tbot=tbot_c)
+ rhos_g_estimate = rhos(qbot=qbot_g, pbot=pbot_g, tbot=tbot_g)
+ rhos_c = rhos_g * (rhos_c_estimate / rhos_g_estimate) ! adjust [density] for column
+
+ ! save
+ forc_t_c = tbot_c
+ forc_th_c = thbot_c
+ forc_q_c = qbot_c
+ forc_pbot_c = pbot_c
+ forc_rho_c = rhos_c
+
+ ! --------------------------------------------------------------------------------------
+ ! 2. adjust wind speed
+ ! --------------------------------------------------------------------------------------
+ forc_us_c = forc_us_g
+ forc_vs_c = forc_vs_g
+
+ ! --------------------------------------------------------------------------------------
+ ! 3. adjust longwave radiation and shortwave radiation
+ ! --------------------------------------------------------------------------------------
+ CALL downscale_longwave (glaciers, &
+ forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, &
+ forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c)
+
+ ! Check if optional parameters are present for complex downscaling
+ IF (present(area_type_c) .and. present(svf_c) .and. present(alb) .and. &
+#ifdef SinglePoint
+ present(sf_lut_c) &
+#else
+ present(sf_curve_c) &
+#endif
+ ) THEN
+ ! Complex downscaling with topographic effects
+ CALL downscale_shortwave(&
+ forc_topo_g, forc_pbot_g, forc_swrad_g, &
+ forc_topo_c, forc_pbot_c, forc_swrad_c, &
+ julian_day, coszen, cosazi, alb, &
+ slp_type_c, asp_type_c, svf_c, &
+#ifdef SinglePoint
+ sf_lut_c, &
+#else
+ sf_curve_c, &
+#endif
+ area_type_c)
+ ELSE
+ ! Simple downscaling
+ CALL downscale_shortwave_simple(&
+ forc_topo_g, forc_pbot_g, forc_swrad_g, &
+ forc_topo_c, forc_pbot_c, forc_swrad_c, &
+ julian_day, coszen, cosazi, &
+ slp_type_c, asp_type_c)
+ ENDIF
+
+ ! --------------------------------------------------------------------------------------
+ ! 4. adjust precipitation
+ ! --------------------------------------------------------------------------------------
+ IF (trim(DEF_DS_precipitation_adjust_scheme) == 'I') THEN
+ ! Tesfa et al, 2020: Exploring Topography-Based Methods for Downscaling
+ ! Subgrid Precipitation for Use in Earth System Models. Equation (5)
+ ! https://doi.org/ 10.1029/2019JD031456
+
+ IF (forc_maxelv_g /= 0.) THEN
+ delta_prc_c = forc_prc_g * (forc_topo_c - forc_topo_g) / forc_maxelv_g
+ ELSE
+ delta_prc_c = 0.
+ ENDIF
+ forc_prc_c = forc_prc_g + delta_prc_c ! convective precipitation [mm/s]
+ IF (forc_prc_c<=0) forc_prc_c = forc_prc_g ! the limit value is non-negative
+ IF (forc_prc_c==0) forc_prc_c = 1.0e-10_r8 ! avoid denominator being 0 when conserving water quantity
+
+ IF (forc_maxelv_g /= 0.) THEN
+ delta_prl_c = forc_prl_g * (forc_topo_c - forc_topo_g) / forc_maxelv_g
+ ELSE
+ delta_prl_c = 0.
+ ENDIF
+ forc_prl_c = forc_prl_g + delta_prl_c ! large scale precipitation [mm/s]
+ IF (forc_prl_c<=0) forc_prl_c = forc_prl_g ! the limit value is non-negative
+ IF (forc_prl_c==0) forc_prl_c = 1.0e-10_r8 ! avoid denominator being 0 when conserving water quantity
+
+ ELSEIF (trim(DEF_DS_precipitation_adjust_scheme) == 'II') THEN
+ ! Liston, G. E. and Elder, K.: A meteorological distribution system
+ ! for high-resolution terrestrial modeling (MicroMet), J. Hydrometeorol., 7, 217-234, 2006.
+ ! Equation (33) and Table 1: chi range from January to December:
+ ! [0.35,0.35,0.35,0.30,0.25,0.20,0.20,0.20,0.20,0.25,0.30,0.35] (1/km)
+
+ delta_prc_c = forc_prc_g *1.0*0.27*(forc_topo_c - forc_topo_g) &
+ /(1.0 - 0.27*(forc_topo_c - forc_topo_g))
+ forc_prc_c = forc_prc_g + delta_prc_c ! large scale precipitation [mm/s]
+
+ delta_prl_c = forc_prl_g *1.0*0.27*(forc_topo_c - forc_topo_g) &
+ /(1.0 - 0.27*(forc_topo_c - forc_topo_g))
+ forc_prl_c = forc_prl_g + delta_prl_c ! large scale precipitation [mm/s]
+ ENDIF
+
+ IF (forc_prl_c < 0) THEN
+ write(*,*) 'negative prl', forc_prl_g, forc_maxelv_g, forc_topo_c, forc_topo_g
+ forc_prl_c = 0.
+ ENDIF
+
+ IF (forc_prc_c < 0) THEN
+ write(*,*) 'negative prc', forc_prc_g, forc_maxelv_g, forc_topo_c, forc_topo_g
+ forc_prc_c = 0.
+ ENDIF
+
+ END SUBROUTINE downscale_forcings
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE downscale_wind(forc_us_g, forc_vs_g, &
+ slp_type_c, asp_type_c, area_type_c, cur_c)
+
+!-----------------------------------------------------------------------------
+! !DESCRIPTION:
+! Downscale wind speed
+!
+! Liston, G. E. and Elder, K.: A meteorological distribution system for
+! high-resolution terrestrial modeling (MicroMet), J. Hydrometeorol.,
+! 7, 217-234, 2006.
+!-----------------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ ! ARGUMENTS:
+ real(r8), intent(inout) :: forc_us_g ! eastward wind (m/s)
+ real(r8), intent(inout) :: forc_vs_g ! northward wind (m/s)
+
+ real(r8), intent(in) :: cur_c ! curvature
+ ! topographic aspect of each character of one patch
+ real(r8), intent(in) :: asp_type_c (1:num_slope_type)
+ ! topographic slope of each character of one patch
+ real(r8), intent(in) :: slp_type_c (1:num_slope_type)
+ ! area percentage of each character of one patch
+ real(r8), intent(in) :: area_type_c (1:num_slope_type)
+
+ ! local variables
+ real(r8) :: wind_dir ! wind direction
+ real(r8) :: ws_g ! non-downscaled wind speed
+ real(r8) :: wind_dir_slp (1:num_slope_type) ! the slope in the direction of the wind
+ real(r8) :: ws_c_type(1:num_slope_type) ! downscaled wind speed of each type in each patch
+ real(r8) :: ws_c ! downscaled wind speed
+ real(r8) :: scale_factor ! Combined scaling factor for regulating wind speed
+ integer :: g, c, i
+
+!-----------------------------------------------------------------------------
+
+ ! calculate wind direction
+ IF (forc_us_g == 0.) THEN
+ wind_dir = PI/2
+ ELSE
+ wind_dir = atan(forc_vs_g /forc_us_g)
+ ENDIF
+
+ ! non-adjusted wind speed
+ ws_g = sqrt(forc_vs_g *forc_vs_g +forc_us_g *forc_us_g )
+
+ ! compute the slope in the direction of the wind
+ DO i = 1, num_slope_type
+ wind_dir_slp(i) = slp_type_c(i)*cos(wind_dir-asp_type_c(i))
+ ENDDO
+
+ ! compute wind speed adjustment
+ DO i = 1, num_slope_type
+ scale_factor = (1+(0.58*wind_dir_slp(i))+0.42*cur_c)
+ ! Limiting the scope of proportionality adjustments
+ IF (scale_factor>1.5) THEN
+ scale_factor = 1.5
+ ELSEIF (scale_factor<-1.5) THEN
+ scale_factor = -1.5
+ ENDIF
+ ws_c_type(i) = ws_g *scale_factor*area_type_c(i)
+ ENDDO
+
+ ! adjusted wind speed
+ ws_c = sum(ws_c_type(:))
+ forc_us_g = ws_c*cos(wind_dir)
+ forc_vs_g = ws_c*sin(wind_dir)
+
+ END SUBROUTINE downscale_wind
+
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE downscale_wind_simple(forc_us_g, forc_vs_g, &
+ slp_type_c, area_type_c, cur_c)
+
+!-----------------------------------------------------------------------------
+! !DESCRIPTION:
+! Downscale wind speed using a simple method for land-atmosphere coupling models
+!-----------------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ ! ARGUMENTS:
+ real(r8), intent(inout) :: forc_us_g ! eastward wind (m/s)
+ real(r8), intent(inout) :: forc_vs_g ! northward wind (m/s)
+
+ real(r8), intent(in) :: cur_c ! curvature
+ ! topographic slope of each character of one patch
+ real(r8), intent(in) :: slp_type_c (1:num_aspect_type)
+ ! area percentage of each character of one patch
+ real(r8), intent(in) :: area_type_c (1:num_aspect_type)
+
+ ! local variables
+ real(r8) :: asp_type_c(1:num_aspect_type) ! topographic aspect of each type of one patch (rad)
+ real(r8) :: slp_type_c_rad ! Convert tan slope value to slope angle value
+
+ real(r8) :: wind_dir ! wind direction
+ real(r8) :: ws_g ! non-downscaled wind speed
+ real(r8) :: wind_dir_slp (1:num_aspect_type) ! the slope in the direction of the wind
+ real(r8) :: ws_c_type(1:num_aspect_type) ! downscaled wind speed of each type in each patch
+ real(r8) :: ws_c ! downscaled wind speed
+ real(r8) :: scale_factor ! Combined scaling factor for regulating wind speed
+ integer :: u_sign, v_sign, i, wind_dir_u, wind_dir_v
+
+ ! Initialize aspect type
+ asp_type_c(1) = 0.0_r8*PI/180 ! north
+ asp_type_c(2) = 45.0_r8*PI/180 ! northeast
+ asp_type_c(3) = 90.0_r8*PI/180 ! east
+ asp_type_c(4) = 135.0_r8*PI/180 ! southeast
+ asp_type_c(5) = 180.0_r8*PI/180 ! south
+ asp_type_c(6) = 225.0_r8*PI/180 ! southwest
+ asp_type_c(7) = 270.0_r8*PI/180 ! west
+ asp_type_c(8) = 315.0_r8*PI/180 ! northwest
+ asp_type_c(9) = -9999.0_r8 ! flat
+!-----------------------------------------------------------------------------
+
+ ! calculate wind direction
+ IF (forc_us_g == 0.) THEN
+ wind_dir = PI/2
+ ELSE
+ wind_dir = atan2(forc_vs_g, forc_us_g)
+ ENDIF
+
+ ! convert to 0-2*PI range
+ !wind_dir = wind_dir + 3*PI/2
+ !wind_dir = mod(wind_dir, 2*PI)
+
+ ! 0° is north
+ IF (wind_dir > PI/2) THEN
+ wind_dir = 2*PI - wind_dir + PI/2
+ ELSE
+ wind_dir = PI/2 - wind_dir
+ ENDIF
+
+ ! non-adjusted wind speed
+ ws_g = sqrt(forc_vs_g *forc_vs_g +forc_us_g *forc_us_g )
+
+ ! log the + - sign of the u,v direction
+ IF (forc_us_g >= 0.0_r8) THEN
+ u_sign = 1
+ ELSE
+ u_sign = -1
+ ENDIF
+ IF (forc_vs_g >= 0.0_r8) THEN
+ v_sign = 1
+ ELSE
+ v_sign = -1
+ ENDIF
+
+
+ ! compute the slope in the direction of the wind
+ DO i = 1, num_aspect_type
+ IF (slp_type_c(i) == -1.0e36) THEN
+ ! no slope in the direction of the aspect
+ wind_dir_slp(i) = -1.0e36
+ ELSE
+ ! slope in the direction of the wind
+ slp_type_c_rad = atan(slp_type_c(i))
+ wind_dir_slp(i) = slp_type_c_rad*cos(wind_dir-asp_type_c(i))
+ ENDIF
+ ENDDO
+
+ ! compute wind speed adjustment
+ DO i = 1, num_aspect_type
+ ! For the flat area, we do not adjust the wind speed
+ IF (asp_type_c(i) == -9999.0_r8) THEN
+ scale_factor = 1.0_r8
+ ELSE IF ((wind_dir_slp(i) == -1.0e36).or.(cur_c == -1.0e36)) THEN
+ ! no slope in the direction of the aspect
+ scale_factor = -1.0e36
+ ELSE
+ scale_factor = (1+(0.58*wind_dir_slp(i))+0.42*cur_c)
+ !write(*,*) 'scale_factor', scale_factor, 'wind_dir_slp(i)', wind_dir_slp(i), 'cur_c', cur_c
+ ENDIF
+
+ ! Limiting the scope of proportionality adjustments
+ IF (scale_factor>1.5) THEN
+ scale_factor = 1.5
+ ELSEIF (scale_factor<-1.5) THEN
+ scale_factor = -1.5
+ ENDIF
+
+ ! Downscale wind speed for each type in each patch
+ IF ((scale_factor == -1.0e36).or.(area_type_c(i) == -1.0e36)) THEN
+ ws_c_type(i) = -1.0e36
+ ELSE
+ ws_c_type(i) = ws_g *scale_factor*area_type_c(i)
+ ENDIF
+
+ ENDDO
+
+ ! adjusted wind speed
+ ws_c = sum(ws_c_type(:),mask=ws_c_type(:) /= -1.0e36)
+
+ ! caculate u and v components of the wind
+ IF (wind_dir > PI/2) THEN
+ wind_dir = 2*PI - wind_dir + PI/2
+ ELSE
+ wind_dir = PI/2 - wind_dir
+ ENDIF
+
+ forc_us_g = u_sign*sqrt((ws_c*cos(wind_dir))**2)
+ forc_vs_g = v_sign*sqrt((ws_c*sin(wind_dir))**2)
+
+ END SUBROUTINE downscale_wind_simple
+!-----------------------------------------------------------------------------
+
+ SUBROUTINE downscale_longwave (glaciers, &
+ forc_topo_g, forc_t_g, forc_q_g, forc_pbot_g, forc_lwrad_g, &
+ forc_topo_c, forc_t_c, forc_q_c, forc_pbot_c, forc_lwrad_c)
+
+!-----------------------------------------------------------------------------
+! !DESCRIPTION:
+! Downscale longwave radiation
+!-----------------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ ! ARGUMENTS:
+ logical, intent(in) :: glaciers ! true: glacier column
+
+ real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m)
+ real(r8), intent(in) :: forc_t_g ! atmospheric temperature [Kelvin]
+ real(r8), intent(in) :: forc_q_g ! atmospheric specific humidity [kg/kg]
+ real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa]
+ real(r8), intent(in) :: forc_lwrad_g ! downward longwave (W/m**2)
+
+ real(r8), intent(in) :: forc_topo_c ! column surface height (m)
+ real(r8), intent(in) :: forc_t_c ! atmospheric temperature [Kelvin]
+ real(r8), intent(in) :: forc_q_c ! atmospheric specific humidity [kg/kg]
+ real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa]
+ real(r8), intent(out):: forc_lwrad_c ! downward longwave (W/m**2)
+
+ ! LOCAL VARIABLES:
+ real(r8) :: hsurf_c ! column-level elevation (m)
+ real(r8) :: hsurf_g ! gridcell-level elevation (m)
+
+ real(r8) :: pv_g ! the water vapor pressure at grid cell (hPa)
+ real(r8) :: pv_c ! the water vapor pressure at column (hPa)
+ real(r8) :: emissivity_clearsky_g ! clear-sky emissivity at grid cell
+ real(r8) :: emissivity_clearsky_c ! clear-sky emissivity at grid column
+ real(r8) :: emissivity_allsky_g ! all-sky emissivity at grid cell
+ real(r8) :: es_g, es_c, dum1, dum2, dum3
+
+ real(r8), parameter :: lapse_rate_longwave = 0.032_r8 ! longwave radiation lapse rate (W m-2 m-1)
+ ! relative limit for how much longwave downscaling can be done (unitless)
+ real(r8), parameter :: longwave_downscaling_limit = 0.5_r8
+
+!--------------------------------------------------------------------------
+
+ ! Initialize (needs to be done for ALL active columns)
+ forc_lwrad_c = forc_lwrad_g
+ hsurf_g = forc_topo_g
+ hsurf_c = forc_topo_c
+
+ IF (trim(DEF_DS_longwave_adjust_scheme) == 'I') THEN
+ ! Fiddes and Gruber, 2014, TopoSCALE v.1.0: downscaling gridded climate data in complex
+ ! terrain. Geosci. Model Dev., 7, 387-405. doi:10.5194/gmd-7-387-2014. Equation (1) (2)
+ ! (3); here, the empirical parameters x1 and x2 are different from Konzelmann et al. (1994)
+ ! where x1 = 0.443 and x2 = 8 (optimal for measurements on the Greenland ice sheet)
+
+ CALL Qsadv(forc_t_g, forc_pbot_g, es_g,dum1,dum2,dum3)
+ CALL Qsadv(forc_t_c, forc_pbot_c, es_c,dum1,dum2,dum3)
+ pv_g = forc_q_g*es_g/100._r8 ! (hPa)
+ pv_c = forc_q_c*es_c/100._r8 ! (hPa)
+
+ emissivity_clearsky_g = 0.23_r8 + 0.43_r8*(pv_g/forc_t_g)**(1._r8/5.7_r8)
+ emissivity_clearsky_c = 0.23_r8 + 0.43_r8*(pv_c/forc_t_c)**(1._r8/5.7_r8)
+ emissivity_allsky_g = forc_lwrad_g / (5.67e-8_r8*forc_t_g**4)
+
+ forc_lwrad_c = &
+ (emissivity_clearsky_c + (emissivity_allsky_g - emissivity_clearsky_g)) &
+ * 5.67e-8_r8*forc_t_c**4
+ ELSE
+ ! Longwave radiation is downscaled by assuming a linear decrease in downwelling longwave
+ ! radiation with increasing elevation (0.032 W m-2 m-1, limited to 0.5 - 1.5 times the
+ ! gridcell mean value, then normalized to conserve gridcell total energy) (Van Tricht et
+ ! al., 2016, TC) Figure 6, doi:10.5194/tc-10-2379-2016
+
+ IF (glaciers) THEN
+ forc_lwrad_c = forc_lwrad_g - lapse_rate_longwave * (hsurf_c-hsurf_g)
+
+ ! Here we assume that deltaLW = (dLW/dT)*(dT/dz)*deltaz
+ ! We get dLW/dT = 4*eps*sigma*T^3 = 4*LW/T from the Stefan-Boltzmann law,
+ ! evaluated at the mean temp. We assume the same temperature lapse rate as above.
+
+ ELSE
+ forc_lwrad_c = forc_lwrad_g &
+ - 4.0_r8 * forc_lwrad_g/(0.5_r8*(forc_t_c+forc_t_g)) &
+ * lapse_rate * (hsurf_c - hsurf_g)
+ ENDIF
+ ENDIF
+
+ ! But ensure that we don't depart too far from the atmospheric forcing value:
+ ! negative values of lwrad are certainly bad, but small positive values might
+ ! also be bad. We can especially run into trouble due to the normalization: a
+ ! small lwrad value in one column can lead to a big normalization factor,
+ ! leading to huge lwrad values in other columns.
+
+ forc_lwrad_c = min(forc_lwrad_c, forc_lwrad_g * (1._r8 + longwave_downscaling_limit))
+ forc_lwrad_c = max(forc_lwrad_c, forc_lwrad_g * (1._r8 - longwave_downscaling_limit))
+
+ END SUBROUTINE downscale_longwave
+
+!-----------------------------------------------------------------------------
+ SUBROUTINE downscale_shortwave( &
+ forc_topo_g, forc_pbot_g, forc_swrad_g, &
+ forc_topo_c, forc_pbot_c, forc_swrad_c, &
+ julian_day, coszen, cosazi, alb, &
+ slp_type_c, asp_type_c, svf_c, &
+#ifdef SinglePoint
+ sf_lut_c, &
+#else
+ sf_curve_c, &
+#endif
+ area_type_c)
+
+!-----------------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Rouf, T., Mei, Y., Maggioni, V., Houser, P., & Noonan, M. (2020). A
+! Physically Based Atmospheric Variables Downscaling Technique. Journal
+! of Hydrometeorology, 21(1), 93-108.
+! https://doi.org/10.1175/JHM-D-19-0109.1
+!
+! Sisi Chen, Lu Li, Yongjiu Dai, et al. Exploring Topography
+! Downscaling Methods for Hyper-Resolution Land Surface Modeling.
+! Authorea. April 25, 2024. DOI: 10.22541/au.171403656.68476353/v1
+!
+! Must be done after downscaling of surface pressure
+!-----------------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ integer, parameter :: S = 1370 ! solar constant (W/m**2)
+ real(r8), parameter :: thr = 85*PI/180 ! threshold of zenith
+ ! relative limit for how much shortwave downscaling can be done (unitless)
+ real(r8), parameter :: shortwave_downscaling_limit = 0.5_r8
+
+ ! ARGUMENTS:
+ real(r8), intent(in) :: julian_day ! day of year
+ real(r8), intent(in) :: coszen ! zenith angle at an hour
+ real(r8), intent(in) :: cosazi ! azimuth angle at an hour
+ real(r8), intent(in) :: alb ! blue sky albedo
+
+ real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m)
+ real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa]
+ real(r8), intent(in) :: forc_swrad_g ! downward shortwave (W/m**2)
+
+ real(r8), intent(in) :: forc_topo_c ! column surface height (m)
+ real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa]
+ real(r8), intent(out):: forc_swrad_c ! downward shortwave (W/m**2)
+
+ real(r8), intent(in) :: svf_c ! sky view factor
+# ifdef SinglePoint
+ ! look up table of shadow mask of a patch
+ real(r8), intent(in) :: sf_lut_c (1:num_azimuth,1:num_zenith)
+# else
+ ! curve of shadow mask of a patch
+ real(r8), intent(in) :: sf_curve_c (1:num_azimuth,1:num_zenith_parameter)
+# endif
+ ! topographic aspect of each character of one patch (°)
+ real(r8), intent(in) :: asp_type_c (1:num_slope_type)
+ ! topographic slope of each character of one patch
+ real(r8), intent(in) :: slp_type_c (1:num_slope_type)
+ ! area percentage of each character of one patch
+ real(r8), intent(in) :: area_type_c(1:num_slope_type)
+
+ ! LOCAL VARIABLES:
+ real(r8) :: zen_rad, zen_deg, azi_rad, azi_deg ! rad and deg of sun zenith and azimuth angle
+ integer :: idx_azi, idx_zen ! index used to cal shadow factor from
+ ! look up table
+ real(r8) :: sf_c ! shadow factor
+ real(r8) :: rt_R ! The ratio of the current distance between
+ ! the sun and the earth
+ real(r8) :: toa_swrad ! top of atmosphere shortwave radiation
+ real(r8) :: clr_idx ! atmospheric transparency
+ real(r8) :: diff_wgt ! diffuse weight
+ real(r8) :: k_c ! column broadband attenuation coefficient [Pa^-1]
+ real(r8) :: opt_factor ! optical length factor
+ real(r8) :: a_p
+ real(r8) :: svf, balb
+
+ real(r8) :: diff_swrad_g, beam_swrad_g ! diffuse and beam radiation
+ real(r8) :: diff_swrad_c, beam_swrad_c, refl_swrad_c! downscaled diffuse, beam radiation
+ ! and reflect radiation
+ real(r8) :: beam_swrad_type (1:num_slope_type) ! beam radiation of one characterized patch
+ real(r8) :: refl_swrad_type (1:num_slope_type) ! refl. radiation of one characterized patch
+ real(r8) :: tcf_type (1:num_slope_type) ! terrain configure factor
+ real(r8) :: cosill_type (1:num_slope_type) ! illumination angle (cos) at defined types
+
+ real(r8) :: zenith_segment, a1, a2 ! Segmented function segmentation
+ ! points (rad), parameter1, parameter2
+
+ integer :: i
+
+!-----------------------------------------------------------------------------
+
+ ! calculate shadow factor according to sun zenith and azimuth angle
+ zen_rad = acos(coszen)
+ azi_rad = acos(cosazi)
+ azi_deg = azi_rad*180.0/PI ! turn deg
+
+ idx_azi = INT(azi_deg*num_azimuth/360)
+
+ IF (idx_azi==0) idx_azi = 1
+
+#ifdef SinglePoint
+ zen_deg = zen_rad*180/PI ! turn deg
+ idx_zen = INT(zen_deg*num_zenith/90)
+ IF (idx_zen==0) idx_zen = 1
+ !constrain the upper boundary of zenith angle to 90 deg
+ IF (idx_zen>num_zenith) idx_zen = num_zenith
+
+ sf_c = sf_lut_c(idx_azi, idx_zen)
+#else
+ ! Constructing a shadow factor function from zenith angle parameters
+ ! shadow factor = exp(-1*exp(a1*zenith+a2))
+ zenith_segment = sf_curve_c(idx_azi, 1) ! Segmented function segmentation points (rad)
+ a1 = sf_curve_c(idx_azi, 2) ! parameter of function
+ a2 = sf_curve_c(idx_azi, 3) ! parameter of function
+
+ IF (zen_rad <= zenith_segment) THEN
+ sf_c = 1.
+ ELSEIF (a1<=1e-10) THEN
+ sf_c = 1.
+ ELSE
+ sf_c = exp(-1*exp(min(a1*zen_rad+a2,3.5)))
+ ENDIF
+#endif
+
+ IF (sf_c<0) sf_c = 0
+ IF (sf_c>1) sf_c = 1
+
+ ! calculate top-of-atmosphere incident shortwave radiation
+ rt_R = 1-0.01672*cos(0.9856*(julian_day-4))
+ toa_swrad = S*(rt_R**2)*coszen
+
+ ! calculate clearness index
+ IF (toa_swrad.eq.0) THEN
+ clr_idx = 0
+ ELSE
+ clr_idx = forc_swrad_g/toa_swrad
+ ENDIF
+ IF (clr_idx>1) clr_idx = 1
+
+ ! calculate diffuse weight
+ ! Ruiz-Arias, J. A., Alsamamra, H., Tovar-Pescador, J., & Pozo-Vázquez, D. (2010).
+ ! Proposal of a regressive model for the hourly diffuse solar radiation under all sky
+ ! conditions. Energy Conversion and Management, 51(5), 881-893.
+ ! https://doi.org/10.1016/j.enconman.2009.11.024
+ diff_wgt = 0.952-1.041*exp(-1*exp(min(2.3-4.702*clr_idx,3.5)))
+ IF (diff_wgt>1) diff_wgt = 1
+ IF (diff_wgt<0) diff_wgt = 0
+
+ ! calculate diffuse and beam radiation
+ diff_swrad_g = forc_swrad_g*diff_wgt
+ beam_swrad_g = forc_swrad_g*(1-diff_wgt)
+
+ ! calculate broadband attenuation coefficient [Pa^-1]
+ IF (clr_idx.le.0) THEN
+ k_c = 0
+ ELSE
+ k_c = log(clr_idx)/forc_pbot_c
+ ENDIF
+
+ ! calculate factor to account for the difference of optical path length
+ ! due to pressure difference
+ opt_factor = exp(k_c*(forc_pbot_g-forc_pbot_c))
+ ! Control the boundary of optical path length
+ IF ((opt_factor>10000).or.(opt_factor<-10000)) opt_factor = 0
+
+ ! Adjust the zenith angle so that the range of zenith angles is less than 85°
+ IF (zen_rad>thr) zen_rad=thr
+
+ ! loop for four defined types to downscale beam radiation
+ DO i = 1, num_slope_type
+ ! calculate the cosine of solar illumination angle, cos(θ),
+ ! ranging between −1 and 1, indicates if the sun is below or
+ ! above the local horizon (note that values lower than 0 are set to 0 indicate self shadow)
+ cosill_type(i) = cos(slp_type_c(i))+tan(zen_rad)*sin(slp_type_c(i))*cos(asp_type_c(i))
+ IF (cosill_type(i)>1) cosill_type(i) = 1
+ IF (cosill_type(i)<0) cosill_type(i) = 0
+
+ ! downscaling beam radiation
+ a_p = area_type_c(i)
+ IF (a_p.gt.1.0) a_p = 1
+ IF (a_p.lt.0) a_p = 0
+ beam_swrad_type(i) = sf_c*cosill_type(i)*opt_factor*a_p*beam_swrad_g
+ ENDDO
+ beam_swrad_c = sum(beam_swrad_type)
+
+ ! downscaling diffuse radiation
+ svf = svf_c
+ IF (svf>1) svf = 1
+ IF (svf<0) svf = 0
+ diff_swrad_c = svf*diff_swrad_g
+
+ ! downscaling reflected radiation
+ balb = alb
+ DO i = 1, num_slope_type
+ tcf_type(i) = (1+cos(slp_type_c(i)))/2-svf
+ IF (tcf_type(i)<0) tcf_type(i) = 0
+
+ IF (isnan_ud(alb)) THEN
+ refl_swrad_type(i) = -1.0e36
+ ELSE
+ IF ((balb<0).or.(balb>1)) balb = 0
+ refl_swrad_type(i) = balb*tcf_type(i)*(beam_swrad_c*coszen+(1-svf)*diff_swrad_c)
+ ENDIF
+ ENDDO
+ refl_swrad_c = sum(refl_swrad_type, mask = refl_swrad_type /= -1.0e36)
+ forc_swrad_c = beam_swrad_c+diff_swrad_c+refl_swrad_c
+
+ ! But ensure that we don't depart too far from the atmospheric forcing value:
+ ! negative values of swrad are certainly bad, but small positive values might
+ ! also be bad. We can especially run into trouble due to the normalization: a
+ ! small swrad value in one column can lead to a big normalization factor,
+ ! leading to huge swrad values in other columns.
+
+ forc_swrad_c = min(forc_swrad_c, &
+ forc_swrad_g * (1._r8 + shortwave_downscaling_limit))
+ forc_swrad_c = max(forc_swrad_c, &
+ forc_swrad_g * (1._r8 - shortwave_downscaling_limit))
+ ! Ensure that the denominator is not 0 during shortwave normalization
+ IF (forc_swrad_c==0.) forc_swrad_c = 0.0001
+
+ END SUBROUTINE downscale_shortwave
+
+!-----------------------------------------------------------------------------
+ SUBROUTINE downscale_shortwave_simple( &
+ forc_topo_g, forc_pbot_g, forc_swrad_g, &
+ forc_topo_c, forc_pbot_c, forc_swrad_c, &
+ julian_day, coszen, cosazi, &
+ slp_type_c, area_type_c)
+!-----------------------------------------------------------------------------
+! !DESCRIPTION:
+! This subroutine performs a simple downscaling of shortwave radiation for
+! land-atmosphere coupling models. The adjustments are only made for direct
+! radiation without considering the impact of shadow factor.
+!
+ IMPLICIT NONE
+
+ integer, parameter :: S = 1370 ! solar constant (W/m**2)
+ real(r8), parameter :: thr = 85*PI/180 ! threshold of zenith
+ ! relative limit for how much shortwave downscaling can be done (unitless)
+ real(r8), parameter :: shortwave_downscaling_limit = 0.2_r8
+
+ ! ARGUMENTS:
+ real(r8), intent(in) :: julian_day ! day of year
+ real(r8), intent(in) :: coszen ! zenith angle at an hour
+ real(r8), intent(in) :: cosazi ! azimuth angle at an hour
+
+ real(r8), intent(in) :: forc_topo_g ! atmospheric surface height (m)
+ real(r8), intent(in) :: forc_pbot_g ! atmospheric pressure [Pa]
+ real(r8), intent(in) :: forc_swrad_g ! downward shortwave (W/m**2)
+
+ real(r8), intent(in) :: forc_topo_c ! column surface height (m)
+ real(r8), intent(in) :: forc_pbot_c ! atmospheric pressure [Pa]
+ real(r8), intent(out):: forc_swrad_c ! downward shortwave (W/m**2)
+
+ ! tan value of topographic slope of each direction of one patch
+ real(r8), intent(in) :: slp_type_c (1:num_aspect_type)
+ ! area percentage of each character of one patch
+ real(r8), intent(in) :: area_type_c(1:num_aspect_type)
+
+ ! LOCAL VARIABLES:
+
+ real(r8) :: asp_type_c (1:num_aspect_type) ! topographic aspect fraction of one patch (%100) num_aspect_type = 1:north, 2:northeast, 3:east,
+ ! 4:southeast, 5:south, 6:southwest, 7:west, 8:northwest, 9:flat
+ real(r8) :: slp_type_c_rad ! Convert tan slope value to slope angle value
+
+ real(r8) :: zen_rad, azi_rad ! rad of sun zenith and azimuth angle
+ integer :: idx_azi, idx_zen ! index used to cal shadow factor from
+ ! look up table
+ real(r8) :: sf_c ! shadow factor
+ real(r8) :: rt_R ! The ratio of the current distance between
+ ! the sun and the earth
+ real(r8) :: toa_swrad ! top of atmosphere shortwave radiation
+ real(r8) :: clr_idx ! atmospheric transparency
+ real(r8) :: diff_wgt ! diffuse weight
+ real(r8) :: k_c ! column broadband attenuation coefficient [Pa^-1]
+ real(r8) :: opt_factor ! optical length factor
+ real(r8) :: a_p
+ real(r8) :: diff_swrad_g, beam_swrad_g ! diffuse and beam radiation
+ real(r8) :: diff_swrad_c, beam_swrad_c ! downscaled diffuse, beam radiation
+
+ real(r8) :: beam_swrad_type (1:num_aspect_type) ! beam radiation of one characterized patch
+ real(r8) :: cosill_type (1:num_aspect_type) ! illumination angle (cos) at defined types
+
+ integer :: i
+!------------------------------------------------------------------------------
+
+ ! Initialize aspect type
+ asp_type_c(1) = 0.0_r8*PI/180 ! north
+ asp_type_c(2) = 45.0_r8*PI/180 ! northeast
+ asp_type_c(3) = 90.0_r8*PI/180 ! east
+ asp_type_c(4) = 135.0_r8*PI/180 ! southeast
+ asp_type_c(5) = 180.0_r8*PI/180 ! south
+ asp_type_c(6) = 225.0_r8*PI/180 ! southwest
+ asp_type_c(7) = 270.0_r8*PI/180 ! west
+ asp_type_c(8) = 315.0_r8*PI/180 ! northwest
+ asp_type_c(9) = -9999.0_r8 ! flat
+
+ ! calculate shadow factor according to sun zenith and azimuth angle
+ zen_rad = acos(coszen)
+ azi_rad = acos(cosazi)
+
+ ! calculate top-of-atmosphere incident shortwave radiation
+ rt_R = 1-0.01672*cos(0.9856*(julian_day-4))
+ toa_swrad = S*(rt_R**2)*coszen
+
+ ! calculate clearness index
+ IF (toa_swrad < 1.e-7) THEN
+ clr_idx = 0
+ ELSE
+ clr_idx = forc_swrad_g/toa_swrad
+ ENDIF
+ IF (clr_idx>1) clr_idx = 1
+
+ ! calculate diffuse weight
+ ! Ruiz-Arias, J. A., Alsamamra, H., Tovar-Pescador, J., & Pozo-Vázquez, D. (2010).
+ ! Proposal of a regressive model for the hourly diffuse solar radiation under all sky
+ ! conditions. Energy Conversion and Management, 51(5), 881-893.
+ ! https://doi.org/10.1016/j.enconman.2009.11.024
+ diff_wgt = 0.952-1.041*exp(-1*exp(min(2.3-4.702*clr_idx,3.5)))
+ IF (diff_wgt>1) diff_wgt = 1
+ IF (diff_wgt<0) diff_wgt = 0
+
+ ! calculate diffuse and beam radiation
+ diff_swrad_g = forc_swrad_g*diff_wgt
+ beam_swrad_g = forc_swrad_g*(1-diff_wgt)
+
+ ! calculate broadband attenuation coefficient [Pa^-1]
+ IF (clr_idx.le.0) THEN
+ k_c = 0
+ ELSE
+ k_c = log(clr_idx)/forc_pbot_c
+ ENDIF
+
+ ! calculate factor to account for the difference of optical path length
+ ! due to pressure difference
+ opt_factor = exp(k_c*(forc_pbot_g-forc_pbot_c))
+ ! Control the boundary of optical path length
+ IF ((opt_factor>10000).or.(opt_factor<-10000)) opt_factor = 0
+
+ ! Adjust the zenith angle so that the range of zenith angles is less than 85°
+ IF (zen_rad>thr) zen_rad = thr
+
+ ! loop for four defined types to downscale beam radiation
+ DO i = 1, num_aspect_type
+ ! calculate the cosine of solar illumination angle, cos(θ),
+ ! ranging between −1 and 1, indicates if the sun is below or
+ ! above the local horizon (note that values lower than 0 are set to 0 indicate self shadow)
+ IF (i == 9) THEN
+ ! flat area, no slope
+ cosill_type(i) = 1.0_r8
+ ELSE
+ slp_type_c_rad = atan(slp_type_c(i))
+ cosill_type(i) = cos(slp_type_c_rad)+tan(zen_rad)*sin(slp_type_c_rad)*cos(asp_type_c(i))
+ ENDIF
+
+ ! Ensure that the cosine of illumination angle is between 0 and 1
+ IF (cosill_type(i)>1) cosill_type(i) = 1
+ IF (cosill_type(i)<0) cosill_type(i) = 0
+
+ ! downscaling beam radiation
+ a_p = area_type_c(i)
+ IF (a_p.gt.1.0) a_p = 1
+ IF (a_p.lt.0) a_p = 0
+ beam_swrad_type(i) = cosill_type(i)*opt_factor*a_p*beam_swrad_g
+ ENDDO
+ beam_swrad_c = sum(beam_swrad_type)
+
+ ! do not downscale diffuse radiation
+ diff_swrad_c = diff_swrad_g
+
+ forc_swrad_c = beam_swrad_c+diff_swrad_c
+
+ ! But ensure that we don't depart too far from the atmospheric forcing value:
+ ! negative values of swrad are certainly bad, but small positive values might
+ ! also be bad. We can especially run into trouble due to the normalization: a
+ ! small swrad value in one column can lead to a big normalization factor,
+ ! leading to huge swrad values in other columns.
+
+ forc_swrad_c = min(forc_swrad_c, &
+ forc_swrad_g * (1._r8 + shortwave_downscaling_limit))
+ forc_swrad_c = max(forc_swrad_c, &
+ forc_swrad_g * (1._r8 - shortwave_downscaling_limit))
+ ! Ensure that the denominator is not 0 during shortwave normalization
+ IF (forc_swrad_c < 1.e-4) forc_swrad_c = 0.0001
+
+ END SUBROUTINE downscale_shortwave_simple
+
+
+
+END MODULE MOD_ForcingDownscaling
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..07f8a0894c
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Glacier.F90
@@ -0,0 +1,1142 @@
+#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
+ 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)
+ STOP
+ 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..bf41b8b68b
--- /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_SPMD_Task
+ 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_Hist.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90
new file mode 100644
index 0000000000..e60eeee954
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Hist.F90
@@ -0,0 +1,5033 @@
+#include
+
+MODULE MOD_Hist
+
+!----------------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Write out gridded model results to history files.
+!
+! Original version: Yongjiu Dai, September 15, 1999, 03/2014
+!
+! !REVISIONS:
+! Shupeng Zhang, 05/2023: 1) porting codes to MPI parallel version
+!
+! TODO...(need complement)
+!----------------------------------------------------------------------------
+
+ USE MOD_Vars_1DAccFluxes
+ USE MOD_Vars_Global, only: spval
+ USE MOD_NetCDFSerial
+
+ USE MOD_HistGridded
+#if (defined UNSTRUCTURED || defined CATCHMENT)
+ USE MOD_HistVector
+#endif
+#ifdef SinglePoint
+ USE MOD_HistSingle
+#endif
+#ifdef CatchLateralFlow
+ USE MOD_Catch_Hist
+#endif
+#ifdef GridRiverLakeFlow
+ USE MOD_Grid_RiverLakeHist
+#endif
+#ifdef EXTERNAL_LAKE
+ USE MOD_Lake_Hist
+#endif
+
+ PUBLIC :: hist_init
+ PUBLIC :: hist_out
+ PUBLIC :: hist_final
+
+ character(len=10) :: HistForm ! 'Gridded', 'Vector', 'Single'
+
+ character(len=256) :: file_last = 'null'
+
+!--------------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE hist_init (dir_hist, lulcc_call)
+
+ IMPLICIT NONE
+
+ character(len=*) , intent(in) :: dir_hist
+ logical, optional, intent(in) :: lulcc_call
+
+ CALL allocate_acc_fluxes ()
+ CALL FLUSH_acc_fluxes ()
+
+ HistForm = 'Gridded'
+#if (defined UNSTRUCTURED || defined CATCHMENT)
+ IF (DEF_HISTORY_IN_VECTOR) THEN
+ HistForm = 'Vector'
+ ENDIF
+#endif
+#ifdef SinglePoint
+ HistForm = 'Single'
+#endif
+
+ IF (HistForm == 'Gridded') THEN
+ IF (present(lulcc_call)) THEN
+ CALL hist_gridded_init (dir_hist, lulcc_call)
+ ELSE
+ CALL hist_gridded_init (dir_hist)
+ ENDIF
+#ifdef SinglePoint
+ ELSEIF (HistForm == 'Single') THEN
+ CALL hist_single_init ()
+#endif
+ ENDIF
+
+#ifdef CatchLateralFlow
+ CALL hist_basin_init ()
+#endif
+
+#ifdef GridRiverLakeFlow
+ CALL hist_grid_riverlake_init (HistForm)
+#endif
+
+ END SUBROUTINE hist_init
+
+
+ SUBROUTINE hist_final ()
+
+ IMPLICIT NONE
+
+ CALL deallocate_acc_fluxes ()
+
+#ifdef SinglePoint
+ CALL hist_single_final ()
+#endif
+
+#ifdef CatchLateralFlow
+ CALL hist_basin_final ()
+#endif
+
+#ifdef GridRiverLakeFlow
+ CALL hist_grid_riverlake_final ()
+#endif
+
+ END SUBROUTINE hist_final
+
+
+ SUBROUTINE hist_out (idate, deltim, itstamp, etstamp, ptstamp, &
+ dir_hist, casename)
+
+!=======================================================================
+! Original version: Yongjiu Dai, September 15, 1999, 03/2014
+!=======================================================================
+
+ USE MOD_Precision
+ USE MOD_Namelist
+ USE MOD_TimeManager
+ USE MOD_SPMD_Task
+ USE MOD_Vars_1DAccFluxes, filter_dt_ => filter_dt
+ USE MOD_Vars_1DFluxes, only: nsensor
+ USE MOD_Vars_TimeVariables, only: wa, wat, wetwat, wdsrf
+ USE MOD_Block
+ USE MOD_DataType
+ USE MOD_LandPatch
+ USE MOD_SpatialMapping
+ USE MOD_Vars_TimeInvariants, only: patchtype, patchclass, patchmask
+#ifdef URBAN_MODEL
+ USE MOD_LandUrban
+#endif
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ USE MOD_Vars_PFTimeInvariants, only: pftclass
+ USE MOD_LandPFT, only: patch_pft_s
+#endif
+ USE MOD_Forcing, only: forcmask_pch
+#ifdef DataAssimilation
+ USE MOD_DA_TWS, only: fslp_k_mon
+ USE MOD_Vars_Global
+ USE MOD_DA_Vars_TimeVariables
+ USE MOD_Const_Physical, only: denh2o
+#endif
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: idate(3)
+ real(r8), intent(in) :: deltim
+ type(timestamp), intent(in) :: itstamp
+ type(timestamp), intent(in) :: etstamp
+ type(timestamp), intent(in) :: ptstamp
+
+ character(len=*), intent(in) :: dir_hist
+ character(len=*), intent(in) :: casename
+
+ ! Local variables
+ logical :: lwrite
+ character(len=256) :: file_hist
+ integer :: itime_in_file
+ integer :: month, day
+ integer :: days_month(1:12)
+ character(len=10) :: cdate
+
+ type(block_data_real8_2d) :: sumarea
+ type(block_data_real8_2d) :: sumarea_dt
+ type(block_data_real8_2d) :: sumarea_urb
+ type(block_data_real8_2d) :: sumarea_one
+ real(r8), allocatable :: vecacc (:)
+ real(r8), allocatable :: nac_one (:)
+ logical, allocatable :: filter (:)
+ logical, allocatable :: filter_dt (:)
+
+#ifdef CROP
+ type(block_data_real8_2d) :: sumarea_crop
+ type(block_data_real8_2d) :: sumarea_irrig
+ logical, allocatable :: filter_crop (:)
+ logical, allocatable :: filter_irrig (:)
+#endif
+
+ integer i, u
+#ifdef URBAN_MODEL
+ logical, allocatable :: filter_urb (:)
+#endif
+
+#ifdef DataAssimilation
+ integer :: np
+ real(r8), allocatable :: a_wliq_h2osoi_5cm (:)
+ real(r8), allocatable :: a_t_soisno_5cm (:)
+ real(r8), allocatable :: a_wliq_soisno_ens_mean (:,:)
+ real(r8), allocatable :: a_wliq_soisno_5cm_ens (:,:)
+ real(r8), allocatable :: a_wliq_h2osoi_5cm_a (:)
+ real(r8), allocatable :: a_t_soisno_ens_mean (:,:)
+ real(r8), allocatable :: a_t_soisno_5cm_ens (:,:)
+ real(r8), allocatable :: a_t_soisno_5cm_a (:)
+ real(r8), allocatable :: a_t_brt_smap_a (:,:)
+ real(r8), allocatable :: a_t_brt_fy3d_a (:,:)
+ real(r8), allocatable :: a_wliq_soisno_5cm_ens_std (:)
+ real(r8), allocatable :: a_t_soisno_5cm_ens_std (:)
+ real(r8), allocatable :: a_t_brt_smap_ens_std (:,:)
+ real(r8), allocatable :: a_t_brt_fy3d_ens_std (:,:)
+#endif
+
+ IF (itstamp <= ptstamp) THEN
+ CALL FLUSH_acc_fluxes ()
+ RETURN
+ ELSE
+ CALL accumulate_fluxes ()
+ ENDIF
+
+ select CASE (trim(adjustl(DEF_HIST_FREQ)))
+ CASE ('TIMESTEP')
+ lwrite = .true.
+ CASE ('HOURLY')
+ lwrite = isendofhour (idate, deltim) .or. (.not. (itstamp < etstamp))
+ CASE ('DAILY')
+ lwrite = isendofday (idate, deltim) .or. (.not. (itstamp < etstamp))
+ CASE ('MONTHLY')
+ lwrite = isendofmonth(idate, deltim) .or. (.not. (itstamp < etstamp))
+ CASE ('YEARLY')
+ lwrite = isendofyear (idate, deltim) .or. (.not. (itstamp < etstamp))
+ CASE default
+ lwrite = .false.
+ write(*,*) &
+ 'Warning : Please USE one of TIMESTEP/HOURLY/DAILY/MONTHLY/YEARLY for history frequency.'
+ write(*,*) &
+ ' Set to FALSE by default. '
+ END select
+
+ IF (lwrite) THEN
+
+ CALL julian2monthday(idate(1), idate(2), month, day)
+
+ days_month = (/31,28,31,30,31,30,31,31,30,31,30,31/)
+ IF (isleapyear(idate(1))) days_month(2) = 29
+
+ IF ( trim(DEF_HIST_groupby) == 'YEAR' ) THEN
+ write(cdate,'(i4.4)') idate(1)
+#ifdef SinglePoint
+ IF (USE_SITE_HistWriteBack) THEN
+ memory_to_disk = isendofyear(idate,deltim) .or. (.not. (itstamp < etstamp))
+ ENDIF
+#endif
+ ELSEIF ( trim(DEF_HIST_groupby) == 'MONTH' ) THEN
+ write(cdate,'(i4.4,"-",i2.2)') idate(1), month
+#ifdef SinglePoint
+ IF (USE_SITE_HistWriteBack) THEN
+ memory_to_disk = isendofmonth(idate,deltim) .or. (.not. (itstamp < etstamp))
+ ENDIF
+#endif
+ ELSEIF ( trim(DEF_HIST_groupby) == 'DAY' ) THEN
+ write(cdate,'(i4.4,"-",i2.2,"-",i2.2)') idate(1), month, day
+#ifdef SinglePoint
+ IF (USE_SITE_HistWriteBack) THEN
+ memory_to_disk = isendofday(idate,deltim) .or. (.not. (itstamp < etstamp))
+ ENDIF
+#endif
+ ELSE
+ write(*,*) 'Warning : Please USE one of DAY/MONTH/YEAR for history group.'
+ ENDIF
+
+ file_hist = trim(dir_hist) // '/' // trim(casename) //'_hist_'//trim(cdate)//'.nc'
+
+ CALL hist_write_time (file_hist, file_last, 'time', idate, itime_in_file)
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ allocate (filter (numpatch))
+ allocate (filter_dt (numpatch))
+ allocate (vecacc (numpatch))
+ ENDIF
+#ifdef URBAN_MODEL
+ IF (numurban > 0) THEN
+ allocate (filter_urb (numurban))
+ ENDIF
+#endif
+#ifdef CROP
+ IF (numpatch > 0) THEN
+ allocate (filter_crop (numpatch))
+ allocate (filter_irrig (numpatch))
+ ENDIF
+#endif
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ IF (p_is_active) THEN
+ CALL allocate_block_data (ghist, sumarea)
+ CALL allocate_block_data (ghist, sumarea_dt)
+#ifdef URBAN_MODEL
+ CALL allocate_block_data (ghist, sumarea_urb)
+#endif
+#ifdef CROP
+ CALL allocate_block_data (ghist, sumarea_crop)
+ CALL allocate_block_data (ghist, sumarea_irrig)
+#endif
+ ENDIF
+ ENDIF
+
+ ! ---------------------------------------------------
+ ! Meteorological forcing and patch mask filter applying.
+ ! ---------------------------------------------------
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ filter(:) = patchtype < 99
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+
+ filter = filter .and. patchmask
+ filter_dt = filter .and. patchmask .and. (nac_dt > 0)
+
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ CALL mp2g_hist%get_sumarea (sumarea_dt, filter_dt)
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ IF (trim(file_hist) /= trim(file_last)) THEN
+ CALL hist_write_var_real8_2d (file_hist, 'landarea', ghist, -1, sumarea, &
+ compress = 1, longname = 'land area', units = 'km2')
+ CALL hist_write_var_real8_2d (file_hist, 'landfraction', ghist, -1, landfraction, &
+ compress = 1, longname = 'land fraction', units = '-')
+ ENDIF
+ ENDIF
+
+#ifdef CROP
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ filter_crop(:) = patchtype < 99
+ filter_crop(:) = patchclass == 12
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter_crop = filter_crop .and. forcmask_pch
+ ENDIF
+
+ filter_crop = filter_crop .and. patchmask
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea_crop, filter_crop)
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ IF (trim(file_hist) /= trim(file_last)) THEN
+ CALL hist_write_var_real8_2d (file_hist, 'croparea', ghist, 1, sumarea_crop, &
+ compress = 1, longname = 'crop area', units = 'km2')
+ ENDIF
+ ENDIF
+
+ IF (DEF_USE_IRRIGATION) THEN
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF((pftclass(patch_pft_s(i)).GE.npcropmin).and.(MOD(pftclass(patch_pft_s(i)),2).EQ.0))THEN
+ filter_irrig(i) = .true.
+ ELSE
+ filter_irrig(i) = .false.
+ ENDIF
+ ELSE
+ filter_irrig(i) = .false.
+ ENDIF
+ ENDDO
+ IF (DEF_forcing%has_missing_value) THEN
+ filter_irrig = filter_irrig .and. forcmask_pch
+ ENDIF
+ filter_irrig = filter_irrig .and. patchmask
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea_irrig, filter_irrig)
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ IF (trim(file_hist) /= trim(file_last)) THEN
+ CALL hist_write_var_real8_2d (file_hist, 'irrigarea', ghist, 1, sumarea_irrig, &
+ compress = 1, longname = 'irrigation area', units = 'km2')
+ ENDIF
+ ENDIF
+#endif
+
+ ! wind in eastward direction [m/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_us, &
+ a_us, file_hist, 'f_xy_us', itime_in_file, sumarea, filter, &
+ 'wind in eastward direction', 'm/s')
+
+ ! wind in northward direction [m/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_vs, &
+ a_vs, file_hist, 'f_xy_vs', itime_in_file, sumarea, filter, &
+ 'wind in northward direction','m/s')
+
+ ! temperature at reference height [kelvin]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_t, &
+ a_t, file_hist, 'f_xy_t', itime_in_file, sumarea, filter, &
+ 'temperature at reference height','kelvin')
+
+ ! specific humidity at reference height [kg/kg]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_q, &
+ a_q, file_hist, 'f_xy_q', itime_in_file, sumarea, filter, &
+ 'specific humidity at reference height','kg/kg')
+
+ ! convective precipitation [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_prc, &
+ a_prc, file_hist, 'f_xy_prc', itime_in_file, sumarea, filter, &
+ 'convective precipitation','mm/s')
+
+ ! large scale precipitation [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_prl, &
+ a_prl, file_hist, 'f_xy_prl', itime_in_file, sumarea, filter, &
+ 'large scale precipitation','mm/s')
+
+ ! atmospheric pressure at the surface [pa]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_pbot, &
+ a_pbot, file_hist, 'f_xy_pbot', itime_in_file, sumarea, filter, &
+ 'atmospheric pressure at the surface','pa')
+
+ ! atmospheric infrared (longwave) radiation [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_frl, &
+ a_frl, file_hist, 'f_xy_frl', itime_in_file, sumarea, filter, &
+ 'atmospheric infrared (longwave) radiation','W/m2')
+
+ ! downward solar radiation at surface [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_solarin, &
+ a_solarin, file_hist, 'f_xy_solarin', itime_in_file, sumarea, filter, &
+ 'downward solar radiation at surface','W/m2')
+
+ ! rain [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_rain, &
+ a_rain, file_hist, 'f_xy_rain', itime_in_file, sumarea, filter, &
+ 'rain','mm/s')
+
+ ! snow [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_snow, &
+ a_snow, file_hist, 'f_xy_snow', itime_in_file, sumarea, filter, &
+ 'snow','mm/s')
+
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ ! atmospheric boundary layer height [m]
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_hpbl, &
+ a_hpbl, file_hist, 'f_xy_hpbl', itime_in_file, sumarea, filter, &
+ 'boundary layer height','m')
+ ENDIF
+
+ IF (DEF_USE_OZONESTRESS)THEN
+ CALL write_history_variable_2d ( DEF_hist_vars%o3uptakesun, &
+ a_o3uptakesun, file_hist, 'f_o3uptakesun', itime_in_file, sumarea, filter, &
+ 'Accumulated ozone uptake by sunlit leaf','mmol O3 m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%o3uptakesha, &
+ a_o3uptakesha, file_hist, 'f_o3uptakesha', itime_in_file, sumarea, filter, &
+ 'Accumulated ozone uptake by shaded leaf','mmol O3 m-2')
+ ENDIF
+
+ ! ------------------------------------------------------------------------------------------
+ ! Mapping the fluxes and state variables at patch [numpatch] to grid
+ ! ------------------------------------------------------------------
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ filter(:) = patchtype < 99
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+
+ filter = filter .and. patchmask
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! wind stress: E-W [kg/m/s2]
+ CALL write_history_variable_2d ( DEF_hist_vars%taux, &
+ a_taux, file_hist, 'f_taux', itime_in_file, sumarea, filter, &
+ 'wind stress: E-W','kg/m/s2')
+
+ ! wind stress: N-S [kg/m/s2]
+ CALL write_history_variable_2d ( DEF_hist_vars%tauy, &
+ a_tauy, file_hist, 'f_tauy', itime_in_file, sumarea, filter, &
+ 'wind stress: N-S','kg/m/s2')
+
+ ! sensible heat from canopy height to atmosphere [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%fsena, &
+ a_fsena, file_hist, 'f_fsena', itime_in_file, sumarea, filter, &
+ 'sensible heat from canopy height to atmosphere','W/m2')
+
+ ! latent heat flux from canopy height to atmosphere [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%lfevpa, &
+ a_lfevpa, file_hist, 'f_lfevpa', itime_in_file, sumarea, filter, &
+ 'latent heat flux from canopy height to atmosphere','W/m2')
+
+ ! evapotranspiration from canopy to atmosphere [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%fevpa, &
+ a_fevpa, file_hist, 'f_fevpa', itime_in_file, sumarea, filter, &
+ 'evapotranspiration from canopy height to atmosphere','mm/s')
+
+ ! sensible heat from leaves [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%fsenl, &
+ a_fsenl, file_hist, 'f_fsenl', itime_in_file, sumarea, filter, &
+ 'sensible heat from leaves','W/m2')
+
+ ! evaporation+transpiration from leaves [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%fevpl, &
+ a_fevpl, file_hist, 'f_fevpl', itime_in_file, sumarea, filter, &
+ 'evaporation+transpiration from leaves','mm/s')
+
+ ! transpiration rate [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%etr, &
+ a_etr, file_hist, 'f_etr', itime_in_file, sumarea, filter, &
+ 'transpiration rate','mm/s')
+
+ ! sensible heat flux from ground [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%fseng, &
+ a_fseng, file_hist, 'f_fseng', itime_in_file, sumarea, filter, &
+ 'sensible heat flux from ground','W/m2')
+
+ ! evaporation heat flux from ground [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%fevpg, &
+ a_fevpg, file_hist, 'f_fevpg', itime_in_file, sumarea, filter, &
+ 'evaporation flux from ground','mm/s')
+
+ ! ground heat flux [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%fgrnd, &
+ a_fgrnd, file_hist, 'f_fgrnd', itime_in_file, sumarea, filter, &
+ 'ground heat flux','W/m2')
+
+ ! solar absorbed by sunlit canopy [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%sabvsun, &
+ a_sabvsun, file_hist, 'f_sabvsun', itime_in_file, sumarea, filter, &
+ 'solar absorbed by sunlit canopy','W/m2')
+
+ ! solar absorbed by shaded [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%sabvsha, &
+ a_sabvsha, file_hist, 'f_sabvsha', itime_in_file, sumarea, filter, &
+ 'solar absorbed by shaded','W/m2')
+
+ ! solar absorbed by ground [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%sabg, &
+ a_sabg, file_hist, 'f_sabg', itime_in_file, sumarea, filter, &
+ 'solar absorbed by ground','W/m2')
+
+ ! outgoing long-wave radiation from ground+canopy [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%olrg, &
+ a_olrg, file_hist, 'f_olrg', itime_in_file, sumarea, filter, &
+ 'outgoing long-wave radiation from ground+canopy','W/m2')
+
+ ! net radiation [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%rnet, &
+ a_rnet, file_hist, 'f_rnet', itime_in_file, sumarea, filter, &
+ 'net radiation','W/m2')
+
+ ! the error of water balance [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%xerr, &
+ a_xerr, file_hist, 'f_xerr', itime_in_file, sumarea, filter, &
+ 'the error of water banace','mm/s')
+
+ ! the error of energy balance [W/m2]
+ CALL write_history_variable_2d ( DEF_hist_vars%zerr, &
+ a_zerr, file_hist, 'f_zerr', itime_in_file, sumarea, filter, &
+ 'the error of energy balance','W/m2')
+
+ ! surface runoff [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%rsur, &
+ a_rsur, file_hist, 'f_rsur', itime_in_file, sumarea, filter, &
+ 'surface runoff','mm/s')
+
+#ifndef CatchLateralFlow
+ ! saturation excess surface runoff [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%rsur_se, &
+ a_rsur_se, file_hist, 'f_rsur_se', itime_in_file, sumarea, filter, &
+ 'saturation excess surface runoff','mm/s')
+
+ ! infiltration excess surface runoff [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%rsur_ie, &
+ a_rsur_ie, file_hist, 'f_rsur_ie', itime_in_file, sumarea, filter, &
+ 'infiltration excess surface runoff','mm/s')
+#endif
+
+ ! subsurface runoff [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%rsub, &
+ a_rsub, file_hist, 'f_rsub', itime_in_file, sumarea, filter, &
+ 'subsurface runoff','mm/s')
+
+ ! total runoff [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%rnof, &
+ a_rnof, file_hist, 'f_rnof', itime_in_file, sumarea, filter, &
+ 'total runoff','mm/s')
+
+#ifdef DataAssimilation
+ IF (DEF_DA_TWS_GRACE) THEN
+ ! slope factors for runoff [-]
+ IF (p_is_compute .and. (numpatch > 0)) THEN
+ vecacc = fslp_k_mon(month, :)
+ WHERE (vecacc /= spval) vecacc = vecacc*nac
+ ENDIF
+ CALL write_history_variable_2d(.true., &
+ vecacc, file_hist, 'f_slope_factor_k', itime_in_file, sumarea, filter, &
+ 'slope factor [k] for runoff', '-')
+ ENDIF
+#endif
+
+#ifdef CatchLateralFlow
+ ! rate of surface water depth change [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%xwsur, &
+ a_xwsur, file_hist, 'f_xwsur', itime_in_file, sumarea, filter, &
+ 'rate of surface water depth change','mm/s')
+
+ ! rate of ground water change [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%xwsub, &
+ a_xwsub, file_hist, 'f_xwsub', itime_in_file, sumarea, filter, &
+ 'rate of ground water change','mm/s')
+
+ ! fraction of flooded area [-]
+ CALL write_history_variable_2d ( DEF_hist_vars%fldarea, &
+ a_fldarea, file_hist, 'f_fldarea', itime_in_file, sumarea, filter, &
+ 'fraction of flooded area','-')
+#endif
+
+ ! interception [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%qintr, &
+ a_qintr, file_hist, 'f_qintr', itime_in_file, sumarea, filter, &
+ 'interception','mm/s')
+
+ ! infiltration [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%qinfl, &
+ a_qinfl, file_hist, 'f_qinfl', itime_in_file, sumarea, filter, &
+ 'f_qinfl','mm/s')
+
+ ! throughfall [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%qdrip, &
+ a_qdrip, file_hist, 'f_qdrip', itime_in_file, sumarea, filter, &
+ 'total throughfall','mm/s')
+
+ ! total water storage [mm]
+ CALL write_history_variable_2d ( DEF_hist_vars%wat, &
+ a_wat, file_hist, 'f_wat', itime_in_file, sumarea, filter, &
+ 'total water storage','mm')
+
+ ! instantaneous total water storage [mm]
+ IF (p_is_compute .and. (numpatch > 0)) THEN
+ vecacc = wat
+ WHERE(vecacc /= spval) vecacc = vecacc * nac
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%wat_inst, &
+ vecacc, file_hist, 'f_wat_inst', itime_in_file, sumarea, filter, &
+ 'instantaneous total water storage','mm')
+
+ ! canopy assimilation rate [mol m-2 s-1]
+ CALL write_history_variable_2d ( DEF_hist_vars%assim, &
+ a_assim, file_hist, 'f_assim', itime_in_file, sumarea, filter, &
+ 'canopy assimilation rate','mol m-2 s-1')
+
+ ! respiration (plant+soil) [mol m-2 s-1]
+ CALL write_history_variable_2d ( DEF_hist_vars%respc, &
+ a_respc, file_hist, 'f_respc', itime_in_file, sumarea, filter, &
+ 'respiration (plant+soil)','mol m-2 s-1')
+
+ ! groundwater recharge rate [mm/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%qcharge &
+ .and. (.not.DEF_USE_VariablySaturatedFlow), &
+ a_qcharge, file_hist, 'f_qcharge', itime_in_file, sumarea, filter, &
+ 'groundwater recharge rate','mm/s')
+
+ ! ground surface temperature [K]
+ CALL write_history_variable_2d ( DEF_hist_vars%t_grnd, &
+ a_t_grnd, file_hist, 'f_t_grnd', itime_in_file, sumarea, filter, &
+ 'ground surface temperature','K')
+
+ ! leaf temperature [K]
+ CALL write_history_variable_2d ( DEF_hist_vars%tleaf, &
+ a_tleaf, file_hist, 'f_tleaf', itime_in_file, sumarea, filter, &
+ 'leaf temperature','K')
+
+ ! depth of water on foliage [mm]
+ CALL write_history_variable_2d ( DEF_hist_vars%ldew, &
+ a_ldew, file_hist, 'f_ldew', itime_in_file, sumarea, filter, &
+ 'depth of water on foliage','mm')
+
+ ! snow cover, water equivalent [mm]
+ CALL write_history_variable_2d ( DEF_hist_vars%scv, &
+ a_scv, file_hist, 'f_scv', itime_in_file, sumarea, filter, &
+ 'snow cover, water equivalent','mm')
+
+ ! snow depth [meter]
+ CALL write_history_variable_2d ( DEF_hist_vars%snowdp, &
+ a_snowdp, file_hist, 'f_snowdp', itime_in_file, sumarea, filter, &
+ 'snow depth','meter')
+
+ ! fraction of snow cover on ground
+ CALL write_history_variable_2d ( DEF_hist_vars%fsno, &
+ a_fsno, file_hist, 'f_fsno', itime_in_file, sumarea, filter, &
+ 'fraction of snow cover on ground','-')
+
+ ! fraction of saturation area on ground
+ CALL write_history_variable_2d ( DEF_hist_vars%frcsat, &
+ a_frcsat, file_hist, 'f_frcsat', itime_in_file, sumarea, filter, &
+ 'fraction of saturation area on ground','-')
+
+ ! fraction of veg cover, excluding snow-covered veg [-]
+ CALL write_history_variable_2d ( DEF_hist_vars%sigf, &
+ a_sigf, file_hist, 'f_sigf', itime_in_file, sumarea, filter, &
+ 'fraction of veg cover, excluding snow-covered veg','-')
+
+ ! leaf greenness
+ CALL write_history_variable_2d ( DEF_hist_vars%green, &
+ a_green, file_hist, 'f_green', itime_in_file, sumarea, filter, &
+ 'leaf greenness','-')
+
+ ! leaf area index
+ CALL write_history_variable_2d ( DEF_hist_vars%lai, &
+ a_lai, file_hist, 'f_lai', itime_in_file, sumarea, filter, &
+ 'leaf area index','m2/m2')
+
+ ! leaf area index
+ CALL write_history_variable_2d ( DEF_hist_vars%laisun, &
+ a_laisun, file_hist, 'f_laisun', itime_in_file, sumarea, filter, &
+ 'sunlit leaf area index','m2/m2')
+
+ ! leaf area index
+ CALL write_history_variable_2d ( DEF_hist_vars%laisha, &
+ a_laisha, file_hist, 'f_laisha', itime_in_file, sumarea, filter, &
+ 'shaded leaf area index','m2/m2')
+
+ ! stem area index
+ CALL write_history_variable_2d ( DEF_hist_vars%sai, &
+ a_sai, file_hist, 'f_sai', itime_in_file, sumarea, filter, &
+ 'stem area index','m2/m2')
+
+ ! averaged albedo [visible, direct; direct, diffuse]
+ CALL write_history_variable_4d ( DEF_hist_vars%alb, &
+ a_alb, file_hist, 'f_alb', itime_in_file, &
+ 'band', 1, 2, 'rtyp', 1, 2, sumarea_dt, filter_dt, &
+ 'averaged albedo','-',nac_dt)
+
+ ! averaged bulk surface emissivity
+ CALL write_history_variable_2d ( DEF_hist_vars%emis, &
+ a_emis, file_hist, 'f_emis', itime_in_file, sumarea, filter, &
+ 'averaged bulk surface emissivity','-')
+
+ ! effective roughness [m]
+ CALL write_history_variable_2d ( DEF_hist_vars%z0m, &
+ a_z0m, file_hist, 'f_z0m', itime_in_file, sumarea, filter, &
+ 'effective roughness','m')
+
+ ! radiative temperature of surface [K]
+ CALL write_history_variable_2d ( DEF_hist_vars%trad, &
+ a_trad, file_hist, 'f_trad', itime_in_file, sumarea, filter, &
+ 'radiative temperature of surface','kelvin')
+
+ ! 2 m height air temperature [kelvin]
+ CALL write_history_variable_2d ( DEF_hist_vars%tref, &
+ a_tref, file_hist, 'f_tref', itime_in_file, sumarea, filter, &
+ '2 m height air temperature','kelvin')
+
+IF (DEF_Output_2mWMO) THEN
+ ! 2 m WMO air temperature [kelvin]
+ CALL write_history_variable_2d ( DEF_hist_vars%t2m_wmo, &
+ a_t2m_wmo, file_hist, 'f_t2m_wmo', itime_in_file, sumarea, filter, &
+ '2 m WMO air temperature','kelvin')
+ENDIF
+
+ ! 2 m height air specific humidity [kg/kg]
+ CALL write_history_variable_2d ( DEF_hist_vars%qref, &
+ a_qref, file_hist, 'f_qref', itime_in_file, sumarea, filter, &
+ '2 m height air specific humidity','kg/kg')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ filter(:) = patchtype == 2
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+
+ filter = filter .and. patchmask
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ IF (trim(file_hist) /= trim(file_last)) THEN
+ CALL hist_write_var_real8_2d (file_hist, 'area_wetland', ghist, -1, sumarea, &
+ compress = 1, longname = 'area of wetland', units = 'km2')
+ ENDIF
+ ENDIF
+
+ ! wetland water storage [mm]
+ IF (DEF_USE_Dynamic_Wetland) THEN
+ IF (p_is_compute .and. (numpatch > 0)) THEN
+ vecacc = a_wdsrf
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%wetwat, &
+ vecacc, file_hist, 'f_wetwat', itime_in_file, sumarea, filter, &
+ 'wetland water storage','mm')
+ ELSE
+ CALL write_history_variable_2d ( DEF_hist_vars%wetwat, &
+ a_wetwat, file_hist, 'f_wetwat', itime_in_file, sumarea, filter, &
+ 'wetland water storage','mm')
+ ENDIF
+
+ ! instantaneous wetland water storage [mm]
+ IF (p_is_compute .and. (numpatch > 0)) THEN
+ vecacc = wetwat
+ WHERE(vecacc /= spval) vecacc = vecacc * nac
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%wetwat_inst, &
+ vecacc, file_hist, 'f_wetwat_inst', itime_in_file, sumarea, filter, &
+ 'instantaneous wetland water storage','mm')
+
+ IF (p_is_compute .and. (numpatch > 0)) THEN
+ vecacc = a_zwt
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%wetzwt, &
+ vecacc, file_hist, 'f_wetzwt', itime_in_file, sumarea, filter, &
+ 'the depth to water table in wetland','m')
+
+ ! ------------------------------------------------------------------
+ ! Mapping the urban variables at patch [numurban] to grid
+ ! ------------------------------------------------------------------
+
+#ifdef URBAN_MODEL
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i = 1, numpatch
+ IF (patchtype(i) == 1) THEN
+ u = patch2urban(i)
+
+ filter_urb(u) = .true.
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter_urb(u) = filter_urb(u) .and. forcmask_pch(i)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist_urb%get_sumarea (sumarea_urb, filter_urb)
+ ENDIF
+
+ ! sensible heat from building roof [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_roof, &
+ a_senroof, file_hist, 'f_fsenroof', itime_in_file, sumarea_urb, filter_urb, &
+ 'sensible heat from urban roof [W/m2]','W/m2')
+
+ ! sensible heat from building sunlit wall [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsun, &
+ a_senwsun, file_hist, 'f_fsenwsun', itime_in_file, sumarea_urb, filter_urb, &
+ 'sensible heat from urban sunlit wall [W/m2]','W/m2')
+
+ ! sensible heat from building shaded wall [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_wsha, &
+ a_senwsha, file_hist, 'f_fsenwsha', itime_in_file, sumarea_urb, filter_urb, &
+ 'sensible heat from urban shaded wall [W/m2]','W/m2')
+
+ ! sensible heat from impervious ground [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_gimp, &
+ a_sengimp, file_hist, 'f_fsengimp', itime_in_file, sumarea_urb, filter_urb, &
+ 'sensible heat from urban impervious ground [W/m2]','W/m2')
+
+ ! sensible heat from pervious ground [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_gper, &
+ a_sengper, file_hist, 'f_fsengper', itime_in_file, sumarea_urb, filter_urb, &
+ 'sensible heat from urban pervious ground [W/m2]','W/m2')
+
+ ! sensible heat from urban tree [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fsen_urbl, &
+ a_senurbl, file_hist, 'f_fsenurbl', itime_in_file, sumarea_urb, filter_urb, &
+ 'sensible heat from urban tree [W/m2]','W/m2')
+
+ ! latent heat flux from building roof [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_roof, &
+ a_lfevproof, file_hist, 'f_lfevproof', itime_in_file, sumarea_urb, filter_urb, &
+ 'latent heat from urban roof [W/m2]','W/m2')
+
+ ! latent heat flux from impervious ground [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gimp, &
+ a_lfevpgimp, file_hist, 'f_lfevpgimp', itime_in_file, sumarea_urb, filter_urb, &
+ 'latent heat from urban impervious ground [W/m2]','W/m2')
+
+ ! latent heat flux from pervious ground [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_gper, &
+ a_lfevpgper, file_hist, 'f_lfevpgper', itime_in_file, sumarea_urb, filter_urb, &
+ 'latent heat from urban pervious ground [W/m2]','W/m2')
+
+ ! latent heat flux from urban tree [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%lfevp_urbl, &
+ a_lfevpurbl, file_hist, 'f_lfevpurbl', itime_in_file, sumarea_urb, filter_urb, &
+ 'latent heat from urban tree [W/m2]','W/m2')
+
+ ! sensible flux from heat or cool AC [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fhac, &
+ a_fhac, file_hist, 'f_fhac', itime_in_file, sumarea_urb, filter_urb, &
+ 'sensible flux from heat or cool AC [W/m2]','W/m2')
+
+ ! waste heat flux from heat or cool AC [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fwst, &
+ a_fwst, file_hist, 'f_fwst', itime_in_file, sumarea_urb, filter_urb, &
+ 'waste heat flux from heat or cool AC [W/m2]','W/m2')
+
+ ! flux from inner and outer air exchange [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fach, &
+ a_fach, file_hist, 'f_fach', itime_in_file, sumarea_urb, filter_urb, &
+ 'flux from inner and outter air exchange [W/m2]','W/m2')
+
+ ! flux from total heating/cooling [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%fhah, &
+ a_fhah, file_hist, 'f_fhah', itime_in_file, sumarea_urb, filter_urb, &
+ 'flux from heating/cooling [W/m2]','W/m2')
+
+ ! flux from metabolism [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%meta, &
+ a_meta, file_hist, 'f_fmeta', itime_in_file, sumarea_urb, filter_urb, &
+ 'flux from human metabolism [W/m2]','W/m2')
+
+ ! flux from vehicle [W/m2]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%vehc, &
+ a_vehc, file_hist, 'f_fvehc', itime_in_file, sumarea_urb, filter_urb, &
+ 'flux from traffic [W/m2]','W/m2')
+
+ ! temperature of inner building [K]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%t_room, &
+ a_t_room, file_hist, 'f_t_room', itime_in_file, sumarea_urb, filter_urb, &
+ 'temperature of inner building [K]','kelvin')
+
+ ! temperature of outer building [K]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%tafu, &
+ a_tafu, file_hist, 'f_tafu', itime_in_file, sumarea_urb, filter_urb, &
+ 'temperature of outer building [K]','kelvin')
+
+ ! temperature of building roof [K]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%t_roof, &
+ a_troof, file_hist, 'f_t_roof', itime_in_file, sumarea_urb, filter_urb, &
+ 'temperature of urban roof [K]','kelvin')
+
+ ! temperature of building wall [K]
+ CALL write_history_variable_urb_2d ( DEF_hist_vars%t_wall, &
+ a_twall, file_hist, 'f_t_wall', itime_in_file, sumarea_urb, filter_urb, &
+ 'temperature of urban wall [K]','kelvin')
+#endif
+
+ ! ------------------------------------------------------------------
+ ! Mapping the fluxes and state variables at patch [numpatch] to grid
+ ! ------------------------------------------------------------------
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ filter(:) = patchtype < 99
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! 1: assimsun enf temperate
+ CALL write_history_variable_2d ( DEF_hist_vars%assimsun, &
+ a_assimsun, file_hist, 'f_assimsun', itime_in_file, sumarea, filter, &
+ 'Photosynthetic assimilation rate of sunlit leaf for needleleaf evergreen temperate tree',&
+ 'mol m-2 s-1')
+
+ ! 1: assimsha enf temperate
+ CALL write_history_variable_2d ( DEF_hist_vars%assimsha, &
+ a_assimsha, file_hist, 'f_assimsha', itime_in_file, sumarea, filter, &
+ 'Photosynthetic assimilation rate of shaded leaf for needleleaf evergreen temperate tree',&
+ 'mol m-2 s-1')
+
+ ! 1: etrsun enf temperate
+ CALL write_history_variable_2d ( DEF_hist_vars%etrsun, &
+ a_etrsun, file_hist, 'f_etrsun', itime_in_file, sumarea, filter, &
+ 'Transpiration rate of sunlit leaf for needleleaf evergreen temperate tree','mm s-1')
+
+ ! 1: etrsha enf temperate
+ CALL write_history_variable_2d ( DEF_hist_vars%etrsha, &
+ a_etrsha, file_hist, 'f_etrsha', itime_in_file, sumarea, filter, &
+ 'Transpiration rate of shaded leaf for needleleaf evergreen temperate tree','mm s-1')
+
+ ! rstfacsun
+ CALL write_history_variable_2d ( DEF_hist_vars%rstfacsun, &
+ a_rstfacsun, file_hist, 'f_rstfacsun', itime_in_file, sumarea, filter, &
+ 'Ecosystem level Water stress factor on sunlit canopy','unitless')
+
+ ! rstfacsha
+ CALL write_history_variable_2d ( DEF_hist_vars%rstfacsha, &
+ a_rstfacsha, file_hist, 'f_rstfacsha', itime_in_file, sumarea, filter, &
+ 'Ecosystem level Water stress factor on shaded canopy','unitless')
+
+ ! gssun
+ CALL write_history_variable_2d ( DEF_hist_vars%gssun, &
+ a_gssun, file_hist, 'f_gssun', itime_in_file, sumarea, filter, &
+ 'Ecosystem level canopy conductance on sunlit canopy','mol m-2 s-1')
+
+ ! gssha
+ CALL write_history_variable_2d ( DEF_hist_vars%gssha, &
+ a_gssha, file_hist, 'f_gssha', itime_in_file, sumarea, filter, &
+ 'Ecosystem level canopy conductance on shaded canopy','mol m-2 s-1')
+
+ ! soil resistance [m/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%rss, &
+ a_rss, file_hist, 'f_rss', itime_in_file, sumarea, filter, &
+ 'soil surface resistance','s/m')
+
+#ifdef BGC
+ ! leaf carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc, &
+ a_leafc, file_hist, 'f_leafc', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool','gC/m2')
+
+ ! leaf carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_storage, &
+ a_leafc_storage, file_hist, 'f_leafc_storage', itime_in_file, sumarea, filter, &
+ 'leaf carbon storage pool','gC/m2')
+
+ ! leaf carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_xfer, &
+ a_leafc_xfer, file_hist, 'f_leafc_xfer', itime_in_file, sumarea, filter, &
+ 'leaf carbon transfer pool','gC/m2')
+
+ ! fine root carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootc, &
+ a_frootc, file_hist, 'f_frootc', itime_in_file, sumarea, filter, &
+ 'fine root carbon display pool','gC/m2')
+
+ ! fine root carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootc_storage, &
+ a_frootc_storage, file_hist, 'f_frootc_storage', itime_in_file, sumarea, filter, &
+ 'fine root carbon storage pool','gC/m2')
+
+ ! fine root carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootc_xfer, &
+ a_frootc_xfer, file_hist, 'f_frootc_xfer', itime_in_file, sumarea, filter, &
+ 'fine root carbon transfer pool','gC/m2')
+
+ ! live stem carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemc, &
+ a_livestemc, file_hist, 'f_livestemc', itime_in_file, sumarea, filter, &
+ 'live stem carbon display pool','gC/m2')
+
+ ! live stem carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemc_storage, &
+ a_livestemc_storage, file_hist, 'f_livestemc_storage', itime_in_file, sumarea, filter,&
+ 'live stem carbon storage pool','gC/m2')
+
+ ! live stem carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemc_xfer, &
+ a_livestemc_xfer, file_hist, 'f_livestemc_xfer', itime_in_file, sumarea, filter, &
+ 'live stem carbon transfer pool','gC/m2')
+
+ ! dead stem carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemc, &
+ a_deadstemc, file_hist, 'f_deadstemc', itime_in_file, sumarea, filter, &
+ 'dead stem carbon display pool','gC/m2')
+
+ ! dead stem carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_storage, &
+ a_deadstemc_storage, file_hist, 'f_deadstemc_storage', itime_in_file, sumarea, filter,&
+ 'dead stem carbon storage pool','gC/m2')
+
+ ! dead stem carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_xfer, &
+ a_deadstemc_xfer, file_hist, 'f_deadstemc_xfer', itime_in_file, sumarea, filter, &
+ 'dead stem carbon transfer pool','gC/m2')
+
+ ! live coarse root carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootc, &
+ a_livecrootc, file_hist, 'f_livecrootc', itime_in_file, sumarea, filter, &
+ 'live coarse root carbon display pool','gC/m2')
+
+ ! live coarse root carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_storage, &
+ a_livecrootc_storage, file_hist, 'f_livecrootc_storage', &
+ itime_in_file, sumarea, filter, &
+ 'live coarse root carbon storage pool','gC/m2')
+
+ ! live coarse root carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_xfer, &
+ a_livecrootc_xfer, file_hist, 'f_livecrootc_xfer', itime_in_file, sumarea, filter, &
+ 'live coarse root carbon transfer pool','gC/m2')
+
+ ! dead coarse root carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc, &
+ a_deadcrootc, file_hist, 'f_deadcrootc', itime_in_file, sumarea, filter, &
+ 'dead coarse root carbon display pool','gC/m2')
+
+ ! dead coarse root carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_storage, &
+ a_deadcrootc_storage, file_hist, 'f_deadcrootc_storage', &
+ itime_in_file, sumarea, filter, &
+ 'dead coarse root carbon storage pool','gC/m2')
+
+ ! dead coarse root carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_xfer, &
+ a_deadcrootc_xfer, file_hist, 'f_deadcrootc_xfer', itime_in_file, sumarea, filter, &
+ 'dead coarse root carbon transfer pool','gC/m2')
+
+#ifdef CROP
+ ! grain carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%grainc, &
+ a_grainc, file_hist, 'f_grainc', itime_in_file, sumarea, filter, &
+ 'grain carbon display pool','gC/m2')
+
+ ! grain carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%grainc_storage, &
+ a_grainc_storage, file_hist, 'f_grainc_storage', itime_in_file, sumarea, filter, &
+ 'grain carbon storage pool','gC/m2')
+
+ ! grain carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%grainc_xfer, &
+ a_grainc_xfer, file_hist, 'f_grainc_xfer', itime_in_file, sumarea, filter, &
+ 'grain carbon transfer pool','gC/m2')
+#endif
+
+ ! leaf nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafn, &
+ a_leafn, file_hist, 'f_leafn', itime_in_file, sumarea, filter, &
+ 'leaf nitrogen display pool','gN/m2')
+
+ ! leaf nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafn_storage, &
+ a_leafn_storage, file_hist, 'f_leafn_storage', itime_in_file, sumarea, filter, &
+ 'leaf nitrogen storage pool','gN/m2')
+
+ ! leaf nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafn_xfer, &
+ a_leafn_xfer, file_hist, 'f_leafn_xfer', itime_in_file, sumarea, filter, &
+ 'leaf nitrogen transfer pool','gN/m2')
+
+ ! fine root nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootn, &
+ a_frootn, file_hist, 'f_frootn', itime_in_file, sumarea, filter, &
+ 'fine root nitrogen display pool','gN/m2')
+
+ ! fine root nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootn_storage, &
+ a_frootn_storage, file_hist, 'f_frootn_storage', itime_in_file, sumarea, filter, &
+ 'fine root nitrogen storage pool','gN/m2')
+
+ ! fine root nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootn_xfer, &
+ a_frootn_xfer, file_hist, 'f_frootn_xfer', itime_in_file, sumarea, filter, &
+ 'fine root nitrogen transfer pool','gN/m2')
+
+ ! live stem nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemn, &
+ a_livestemn, file_hist, 'f_livestemn', itime_in_file, sumarea, filter, &
+ 'live stem nitrogen display pool','gN/m2')
+
+ ! live stem nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemn_storage, &
+ a_livestemn_storage, file_hist, 'f_livestemn_storage', &
+ itime_in_file, sumarea, filter, &
+ 'live stem nitrogen storage pool','gN/m2')
+
+ ! live stem nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemn_xfer, &
+ a_livestemn_xfer, file_hist, 'f_livestemn_xfer', itime_in_file, sumarea, filter, &
+ 'live stem nitrogen transfer pool','gN/m2')
+
+ ! dead stem nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemn, &
+ a_deadstemn, file_hist, 'f_deadstemn', itime_in_file, sumarea, filter, &
+ 'dead stem nitrogen display pool','gN/m2')
+
+ ! dead stem nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_storage, &
+ a_deadstemn_storage, file_hist, 'f_deadstemn_storage', &
+ itime_in_file, sumarea, filter, &
+ 'dead stem nitrogen storage pool','gN/m2')
+
+ ! dead stem nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_xfer, &
+ a_deadstemn_xfer, file_hist, 'f_deadstemn_xfer', itime_in_file, sumarea, filter, &
+ 'dead stem nitrogen transfer pool','gN/m2')
+
+ ! live coarse root nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootn, &
+ a_livecrootn, file_hist, 'f_livecrootn', itime_in_file, sumarea, filter, &
+ 'live coarse root nitrogen display pool','gN/m2')
+
+ ! live coarse root nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_storage, &
+ a_livecrootn_storage, file_hist, 'f_livecrootn_storage', &
+ itime_in_file, sumarea, filter, &
+ 'live coarse root nitrogen storage pool','gN/m2')
+
+ ! live coarse root nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_xfer, &
+ a_livecrootn_xfer, file_hist, 'f_livecrootn_xfer', itime_in_file, sumarea, filter, &
+ 'live coarse root nitrogen transfer pool','gN/m2')
+
+ ! dead coarse root nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn, &
+ a_deadcrootn, file_hist, 'f_deadcrootn', itime_in_file, sumarea, filter, &
+ 'dead coarse root nitrogen display pool','gN/m2')
+
+ ! dead coarse root nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_storage, &
+ a_deadcrootn_storage, file_hist, 'f_deadcrootn_storage', &
+ itime_in_file, sumarea, filter, &
+ 'dead coarse root nitrogen storage pool','gN/m2')
+
+ ! dead coarse root nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_xfer, &
+ a_deadcrootn_xfer, file_hist, 'f_deadcrootn_xfer', itime_in_file, sumarea, filter, &
+ 'dead coarse root nitrogen transfer pool','gN/m2')
+
+#ifdef CROP
+ ! grain nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%grainn, &
+ a_grainn, file_hist, 'f_grainn', itime_in_file, sumarea, filter, &
+ 'grain nitrogen display pool','gN/m2')
+
+ ! grain nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%grainn_storage, &
+ a_grainn_storage, file_hist, 'f_grainn_storage', itime_in_file, sumarea, filter, &
+ 'grain nitrogen storage pool','gN/m2')
+
+ ! grain nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%grainn_xfer, &
+ a_grainn_xfer, file_hist, 'f_grainn_xfer', itime_in_file, sumarea, filter, &
+ 'grain nitrogen transfer pool','gN/m2')
+#endif
+
+ ! retranslocation nitrogen pool
+ CALL write_history_variable_2d ( DEF_hist_vars%retrasn, &
+ a_retransn, file_hist, 'f_retrasn', itime_in_file, sumarea, filter, &
+ 'retranslocation nitrogen pool','gN/m2')
+
+ ! gross primary productivity
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp, &
+ a_gpp, file_hist, 'f_gpp', itime_in_file, sumarea, filter, &
+ 'gross primary productivity','gC/m2/s')
+
+ ! gross primary productivity
+ CALL write_history_variable_2d ( DEF_hist_vars%downreg, &
+ a_downreg, file_hist, 'f_downreg', itime_in_file, sumarea, filter, &
+ 'gpp downregulation due to N limitation','unitless')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fpg, &
+ a_fpg, file_hist, 'f_fpg', itime_in_file, sumarea, filter, &
+ 'fraction of gpp potential','unitless')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fpi, &
+ a_fpi, file_hist, 'f_fpi', itime_in_file, sumarea, filter, &
+ 'fraction of immobalization','unitless')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totvegc, &
+ a_totvegc, file_hist, 'f_totvegc', itime_in_file, sumarea, filter, &
+ 'total vegetation carbon','gC m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totlitc, &
+ a_totlitc, file_hist, 'f_totlitc', itime_in_file, sumarea, filter, &
+ 'total litter carbon','gC m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totsomc, &
+ a_totsomc, file_hist, 'f_totsomc', itime_in_file, sumarea, filter, &
+ 'total soil organic carbon','gC m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totcwdc, &
+ a_totcwdc, file_hist, 'f_totcwdc', itime_in_file, sumarea, filter, &
+ 'total coarse woody debris carbon','gC m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totcolc, &
+ a_totcolc, file_hist, 'f_totcolc', itime_in_file, sumarea, filter, &
+ 'total ecosystem carbon','gC m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totvegn, &
+ a_totvegn, file_hist, 'f_totvegn', itime_in_file, sumarea, filter, &
+ 'total vegetation nitrogen','gN m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totlitn, &
+ a_totlitn, file_hist, 'f_totlitn', itime_in_file, sumarea, filter, &
+ 'total litter nitrogen','gN m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totsomn, &
+ a_totsomn, file_hist, 'f_totsomn', itime_in_file, sumarea, filter, &
+ 'total soil organic nitrogen','gN m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totcwdn, &
+ a_totcwdn, file_hist, 'f_totcwdn', itime_in_file, sumarea, filter, &
+ 'total coarse woody debris nitrogen','gN m-2')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%totcoln, &
+ a_totcoln, file_hist, 'f_totcoln', itime_in_file, sumarea, filter, &
+ 'total ecosystem nitrogen','gN m-2')
+
+ ! autotrophic respiration
+ CALL write_history_variable_2d ( DEF_hist_vars%ar , &
+ a_ar, file_hist, 'f_ar', itime_in_file, sumarea, filter, &
+ 'autotrophic respiration','gC/m2/s')
+
+! ! CWD production
+! CALL write_history_variable_2d ( DEF_hist_vars%cwdprod , &
+! a_cwdprod, file_hist, 'f_cwdprod', itime_in_file, sumarea, filter, &
+! 'CWD production','gC/m2/s')
+!
+! ! CWD decomposition
+! CALL write_history_variable_2d ( DEF_hist_vars%cwddecomp , &
+! a_cwddecomp, file_hist, 'f_cwddecomp', itime_in_file, sumarea, filter, &
+! 'CWD decomposition','gC/m2/s')
+
+ ! heterotrophic respiration
+ CALL write_history_variable_2d ( DEF_hist_vars%hr , &
+ a_hr, file_hist, 'f_hr', itime_in_file, sumarea, filter, &
+ 'heterotrophic respiration','gC/m2/s')
+
+#ifdef CROP
+ ! crop phase
+ CALL write_history_variable_2d ( DEF_hist_vars%cphase, &
+ a_cphase, file_hist, 'f_cphase', itime_in_file, sumarea, filter, &
+ 'crop phase','unitless')
+
+ ! heat unit index
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_hui (:)
+ ENDIF
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%hui, &
+ vecacc, file_hist, 'f_hui', itime_in_file, sumarea, filter, &
+ 'heat unit index','unitless')
+
+ ! gdd needed to harvest
+ CALL write_history_variable_2d ( DEF_hist_vars%gddmaturity, &
+ a_gddmaturity, file_hist, 'f_gddmaturity', itime_in_file, sumarea, filter, &
+ 'gdd needed to harvest','ddays')
+
+ ! gdd past planting date for crop
+ CALL write_history_variable_2d ( DEF_hist_vars%gddplant, &
+ a_gddplant, file_hist, 'f_gddplant', itime_in_file, sumarea, filter, &
+ 'gdd past planting date for crop','ddays')
+
+ ! vernalization response
+ CALL write_history_variable_2d ( DEF_hist_vars%vf, &
+ a_vf, file_hist, 'f_vf', itime_in_file, sumarea, filter, &
+ 'vernalization response', 'unitless')
+
+ ! 1-yr crop production carbon
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprod1c, &
+ a_cropprod1c, file_hist, 'f_cropprod1c', itime_in_file, sumarea, filter, &
+ '1-yr crop production carbon','gC/m2')
+
+ ! loss rate of 1-yr crop production carbon
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprod1c_loss, &
+ a_cropprod1c_loss, file_hist, 'f_cropprod1c_loss', itime_in_file, sumarea, filter, &
+ 'loss rate of 1-yr crop production carbon','gC/m2/s')
+
+ ! crop seed deficit
+ CALL write_history_variable_2d ( DEF_hist_vars%cropseedc_deficit, &
+ a_cropseedc_deficit, file_hist, 'f_cropseedc_deficit', &
+ itime_in_file, sumarea, filter, &
+ 'crop seed deficit','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ ! grain to crop production carbon
+ CALL write_history_variable_2d ( DEF_hist_vars%grainc_to_cropprodc, &
+ vecacc, file_hist, 'f_grainc_to_cropprodc', itime_in_file, sumarea, filter, &
+ 'grain to crop production carbon','gC/m2/s')
+
+ ! grain to crop seed carbon
+ CALL write_history_variable_2d ( DEF_hist_vars%grainc_to_seed, &
+ a_grainc_to_seed, file_hist, 'f_grainc_to_seed', itime_in_file, sumarea, filter, &
+ 'grain to crop seed carbon','gC/m2/s')
+ ! grain to crop seed carbon
+ CALL write_history_variable_2d ( DEF_hist_vars%fert_to_sminn, &
+ a_fert_to_sminn, file_hist, 'f_fert_to_sminn', itime_in_file, sumarea, filter, &
+ 'fertilization','gN/m2/s')
+
+ IF (DEF_USE_IRRIGATION) THEN
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF((pftclass(patch_pft_s(i)).GE.npcropmin).and.(MOD(pftclass(patch_pft_s(i)),2).EQ.0))THEN
+ filter_irrig(i) = .true.
+ ELSE
+ filter_irrig(i) = .false.
+ ENDIF
+ ELSE
+ filter_irrig(i) = .false.
+ ENDIF
+ ENDDO
+ IF (DEF_forcing%has_missing_value) THEN
+ filter_irrig = filter_irrig .and. forcmask_pch
+ ENDIF
+ filter_irrig = filter_irrig .and. patchmask
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea_irrig, filter_irrig)
+ ENDIF
+
+ ! total irrigation amounts at growing season
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_sum_irrig (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%sum_irrig, &
+ vecacc, file_hist, 'f_sum_irrig', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'total irrigation amounts at growing season','kg/m2')
+
+ ! total irrigation amounts demand at growing season
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_sum_deficit_irrig (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%sum_deficit_irrig, &
+ vecacc, file_hist, 'f_sum_deficit_irrig', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'total irrigation amounts demand at growing season','kg/m2')
+
+ ! total irrigation times at growing season
+ CALL write_history_variable_2d ( DEF_hist_vars%sum_irrig_count, &
+ a_sum_irrig_count, file_hist, 'f_sum_irrig_count', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'total irrigation times at growing season','-')
+
+ ! irrigation waterstorage [kg/m2]
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_waterstorage (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%waterstorage, &
+ vecacc, file_hist, 'f_waterstorage', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'irrigation waterstorage','kg/m2')
+
+ ! irrigation demand for ground water [kg/m2]
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_groundwater_demand (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%groundwater_demand, &
+ vecacc, file_hist, 'f_groundwater_demand', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'irrigation demand for ground water','kg/m2')
+
+ ! irrigation supply from ground water [kg/m2]
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_groundwater_supply (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%groundwater_supply, &
+ vecacc, file_hist, 'f_groundwater_supply', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'irrigation supply from ground water','kg/m2')
+
+ ! irrigation demand for reservoir or river [kg/m2]
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_reservoirriver_demand (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_demand, &
+ vecacc, file_hist, 'f_reservoirriver_demand', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'irrigation demand for reservoir or river','kg/m2')
+
+ ! irrigation supply from reservoir or river [kg/m2]
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_reservoirriver_supply (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, &
+ vecacc, file_hist, 'f_reservoirriver_supply', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'irrigation supply from reservoir or river','kg/m2')
+
+ ! irrigation supply from reservoir [kg/m2]
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_reservoir_supply (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, &
+ vecacc, file_hist, 'f_reservoir_supply', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'irrigation supply from reservoir','kg/m2')
+
+ ! irrigation supply from river [kg/m2]
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_river_supply (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, &
+ vecacc, file_hist, 'f_river_supply', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'irrigation supply from river','kg/m2')
+
+ ! irrigation supply from runoff [kg/m2]
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_runoff_supply (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%reservoirriver_supply, &
+ vecacc, file_hist, 'f_runoff_supply', itime_in_file, sumarea_irrig, filter_irrig, &
+ 'irrigation supply from runoff','kg/m2')
+ ENDIF
+#endif
+
+ ! grain to crop seed carbon
+ CALL write_history_variable_2d ( DEF_hist_vars%ndep_to_sminn, &
+ a_ndep_to_sminn, file_hist, 'f_ndep_to_sminn', itime_in_file, sumarea, filter, &
+ 'nitrogen deposition','gN/m2/s')
+
+ IF(DEF_USE_DiagMatrix)THEN
+ ! leaf carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafcCap, &
+ a_leafcCap, file_hist, 'f_leafcCap', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool Capacity','gC/m2')
+
+ ! leaf carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_storageCap, &
+ a_leafc_storageCap, file_hist, 'f_leafc_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'leaf carbon storage pool capacity','gC/m2')
+
+ ! leaf carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_xferCap, &
+ a_leafc_xferCap, file_hist, 'f_leafc_xferCap', itime_in_file, sumarea, filter, &
+ 'leaf carbon transfer pool capacity','gC/m2')
+
+ ! fine root carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootcCap, &
+ a_frootcCap, file_hist, 'f_frootcCap', itime_in_file, sumarea, filter, &
+ 'fine root carbon display pool Capacity','gC/m2')
+
+ ! fine root carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootc_storageCap, &
+ a_frootc_storageCap, file_hist, 'f_frootc_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'fine root carbon storage pool capacity','gC/m2')
+
+ ! fine root carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootc_xferCap, &
+ a_frootc_xferCap, file_hist, 'f_frootc_xferCap', itime_in_file, sumarea, filter, &
+ 'fine root carbon transfer pool capacity','gC/m2')
+
+ ! live stem carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemcCap, &
+ a_livestemcCap, file_hist, 'f_livestemcCap', itime_in_file, sumarea, filter, &
+ 'live stem carbon display pool Capacity','gC/m2')
+
+ ! live stem carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemc_storageCap, &
+ a_livestemc_storageCap, file_hist, 'f_livestemc_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'live stem carbon storage pool capacity','gC/m2')
+
+ ! live stem carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemc_xferCap, &
+ a_livestemc_xferCap, file_hist, 'f_livestemc_xferCap', &
+ itime_in_file, sumarea, filter, &
+ 'live stem carbon transfer pool capacity','gC/m2')
+
+ ! dead stem carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemcCap, &
+ a_deadstemcCap, file_hist, 'f_deadstemcCap', itime_in_file, sumarea, filter, &
+ 'dead stem carbon display pool Capacity','gC/m2')
+
+ ! dead stem carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_storageCap, &
+ a_deadstemc_storageCap, file_hist, 'f_deadstemc_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'dead stem carbon storage pool capacity','gC/m2')
+
+ ! dead stem carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemc_xferCap, &
+ a_deadstemc_xferCap, file_hist, 'f_deadstemc_xferCap', &
+ itime_in_file, sumarea, filter, &
+ 'dead stem carbon transfer pool capacity','gC/m2')
+
+ ! live coarse root carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootcCap, &
+ a_livecrootcCap, file_hist, 'f_livecrootcCap', itime_in_file, sumarea, filter, &
+ 'live coarse root carbon display pool Capacity','gC/m2')
+
+ ! live coarse root carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_storageCap, &
+ a_livecrootc_storageCap, file_hist, 'f_livecrootc_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'live coarse root carbon storage pool capacity','gC/m2')
+
+ ! live coarse root carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootc_xferCap, &
+ a_livecrootc_xferCap, file_hist, 'f_livecrootc_xferCap', &
+ itime_in_file, sumarea, filter, &
+ 'live coarse root carbon transfer pool capacity','gC/m2')
+
+ ! dead coarse root carbon display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootcCap, &
+ a_deadcrootcCap, file_hist, 'f_deadcrootcCap', itime_in_file, sumarea, filter, &
+ 'dead coarse root carbon display pool Capacity','gC/m2')
+
+ ! dead coarse root carbon storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_storageCap, &
+ a_deadcrootc_storageCap, file_hist, 'f_deadcrootc_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'dead coarse root carbon storage pool capacity','gC/m2')
+
+ ! dead coarse root carbon transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootc_xferCap, &
+ a_deadcrootc_xferCap, file_hist, 'f_deadcrootc_xferCap', &
+ itime_in_file, sumarea, filter, &
+ 'dead coarse root carbon transfer pool capacity','gC/m2')
+
+ ! leaf nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafnCap, &
+ a_leafnCap, file_hist, 'f_leafnCap', itime_in_file, sumarea, filter, &
+ 'leaf nitrogen display pool Capacity','gC/m2')
+
+ ! leaf nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafn_storageCap, &
+ a_leafn_storageCap, file_hist, 'f_leafn_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'leaf nitrogen storage pool capacity','gC/m2')
+
+ ! leaf nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%leafn_xferCap, &
+ a_leafn_xferCap, file_hist, 'f_leafn_xferCap', itime_in_file, sumarea, filter, &
+ 'leaf nitrogen transfer pool capacity','gC/m2')
+
+ ! fine root nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootnCap, &
+ a_frootnCap, file_hist, 'f_frootnCap', itime_in_file, sumarea, filter, &
+ 'fine root nitrogen display pool Capacity','gC/m2')
+
+ ! fine root nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootn_storageCap, &
+ a_frootn_storageCap, file_hist, 'f_frootn_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'fine root nitrogen storage pool capacity','gC/m2')
+
+ ! fine root nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%frootn_xferCap, &
+ a_frootn_xferCap, file_hist, 'f_frootn_xferCap', itime_in_file, sumarea, filter, &
+ 'fine root nitrogen transfer pool capacity','gC/m2')
+
+ ! live stem nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemnCap, &
+ a_livestemnCap, file_hist, 'f_livestemnCap', itime_in_file, sumarea, filter, &
+ 'live stem nitrogen display pool Capacity','gC/m2')
+
+ ! live stem nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemn_storageCap, &
+ a_livestemn_storageCap, file_hist, 'f_livestemn_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'live stem nitrogen storage pool capacity','gC/m2')
+
+ ! live stem nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livestemn_xferCap, &
+ a_livestemn_xferCap, file_hist, 'f_livestemn_xferCap', &
+ itime_in_file, sumarea, filter, &
+ 'live stem nitrogen transfer pool capacity','gC/m2')
+
+ ! dead stem nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemnCap, &
+ a_deadstemnCap, file_hist, 'f_deadstemnCap', itime_in_file, sumarea, filter, &
+ 'dead stem nitrogen display pool Capacity','gC/m2')
+
+ ! dead stem nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_storageCap, &
+ a_deadstemn_storageCap, file_hist, 'f_deadstemn_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'dead stem nitrogen storage pool capacity','gC/m2')
+
+ ! dead stem nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadstemn_xferCap, &
+ a_deadstemn_xferCap, file_hist, 'f_deadstemn_xferCap', &
+ itime_in_file, sumarea, filter, &
+ 'dead stem nitrogen transfer pool capacity','gC/m2')
+
+ ! live coarse root nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootnCap, &
+ a_livecrootnCap, file_hist, 'f_livecrootnCap', itime_in_file, sumarea, filter, &
+ 'live coarse root nitrogen display pool Capacity','gC/m2')
+
+ ! live coarse root nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_storageCap, &
+ a_livecrootn_storageCap, file_hist, 'f_livecrootn_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'live coarse root nitrogen storage pool capacity','gC/m2')
+
+ ! live coarse root nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%livecrootn_xferCap, &
+ a_livecrootn_xferCap, file_hist, 'f_livecrootn_xferCap', &
+ itime_in_file, sumarea, filter, &
+ 'live coarse root nitrogen transfer pool capacity','gC/m2')
+
+ ! dead coarse root nitrogen display pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootnCap, &
+ a_deadcrootnCap, file_hist, 'f_deadcrootnCap', itime_in_file, sumarea, filter, &
+ 'dead coarse root nitrogen display pool Capacity','gC/m2')
+
+ ! dead coarse root nitrogen storage pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_storageCap, &
+ a_deadcrootn_storageCap, file_hist, 'f_deadcrootn_storageCap', &
+ itime_in_file, sumarea, filter, &
+ 'dead coarse root nitrogen storage pool capacity','gC/m2')
+
+ ! dead coarse root nitrogen transfer pool
+ CALL write_history_variable_2d ( DEF_hist_vars%deadcrootn_xferCap, &
+ a_deadcrootn_xferCap, file_hist, 'f_deadcrootn_xferCap', &
+ itime_in_file, sumarea, filter, &
+ 'dead coarse root nitrogen transfer pool capacity','gC/m2')
+
+ ENDIF
+
+ IF(DEF_USE_OZONESTRESS)THEN
+ ! ozone concentration
+ CALL write_history_variable_2d ( DEF_hist_vars%xy_ozone, &
+ a_ozone, file_hist, 'f_xy_ozone', itime_in_file, sumarea, filter, &
+ 'Ozone concentration','mol/mol')
+ ENDIF
+
+ ! litter 1 carbon density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr1c_vr, &
+ a_litr1c_vr, file_hist, 'f_litr1c_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 1 carbon density in soil layers','gC/m3')
+
+ ! litter 2 carbon density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr2c_vr, &
+ a_litr2c_vr, file_hist, 'f_litr2c_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 2 carbon density in soil layers','gC/m3')
+
+ ! litter 3 carbon density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr3c_vr, &
+ a_litr3c_vr, file_hist, 'f_litr3c_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 3 carbon density in soil layers','gC/m3')
+
+ ! soil 1 carbon density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil1c_vr, &
+ a_soil1c_vr, file_hist, 'f_soil1c_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 1 carbon density in soil layers','gC/m3')
+
+ ! soil 2 carbon density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil2c_vr, &
+ a_soil2c_vr, file_hist, 'f_soil2c_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 2 carbon density in soil layers','gC/m3')
+
+ ! soil 3 carbon density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil3c_vr, &
+ a_soil3c_vr, file_hist, 'f_soil3c_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 3 carbon density in soil layers','gC/m3')
+
+ ! coarse woody debris carbon density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%cwdc_vr, &
+ a_cwdc_vr, file_hist, 'f_cwdc_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'coarse woody debris carbon density in soil layers','gC/m3')
+
+ ! litter 1 nitrogen density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr1n_vr, &
+ a_litr1n_vr, file_hist, 'f_litr1n_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 1 nitrogen density in soil layers','gN/m3')
+
+ ! litter 2 nitrogen density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr2n_vr, &
+ a_litr2n_vr, file_hist, 'f_litr2n_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 2 nitrogen density in soil layers','gN/m3')
+
+ ! litter 3 nitrogen density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr3n_vr, &
+ a_litr3n_vr, file_hist, 'f_litr3n_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 3 nitrogen density in soil layers','gN/m3')
+
+ ! soil 1 nitrogen density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil1n_vr, &
+ a_soil1n_vr, file_hist, 'f_soil1n_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 1 nitrogen density in soil layers','gN/m3')
+
+ ! soil 2 nitrogen density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil2n_vr, &
+ a_soil2n_vr, file_hist, 'f_soil2n_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 2 nitrogen density in soil layers','gN/m3')
+
+ ! soil 3 nitrogen density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil3n_vr, &
+ a_soil3n_vr, file_hist, 'f_soil3n_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 3 nitrogen density in soil layers','gN/m3')
+
+ ! coarse woody debris nitrogen density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%cwdn_vr, &
+ a_cwdn_vr, file_hist, 'f_cwdn_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'coarse woody debris nitrogen density in soil layers','gN/m3')
+
+ ! mineral nitrogen density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%sminn_vr, &
+ a_sminn_vr, file_hist, 'f_sminn_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'mineral nitrogen density in soil layers','gN/m3')
+
+ ! total nitrogen percentage in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%totsoiln_vr, &
+ a_totsoiln_vr, file_hist, 'f_totsoiln_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,&
+ 'Total nitrogen in soil layers, percentage of total soil nitrogen in total soil mass','%')
+
+ ! bulk density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%BD_all, &
+ a_BD_all, file_hist, 'f_BD_all', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'bulk density in soil layers','kg/m3')
+
+ ! field capacity in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%wfc, &
+ a_wfc, file_hist, 'f_wfc', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'field capacity in soil layers','m3/m3')
+
+ ! organic matter density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%OM_density, &
+ a_OM_density, file_hist, 'f_OM_density', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'organic matter density in soil layers','kg/m3')
+
+ IF (DEF_USE_NITRIF) THEN
+ ! O2 soil Concentration for non-inundated area
+ CALL write_history_variable_3d ( DEF_hist_vars%CONC_O2_UNSAT, &
+ a_conc_o2_unsat, file_hist, 'f_CONC_O2_UNSAT', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'O2 soil Concentration for non-inundated area','mol/m3')
+
+ ! O2 consumption from HR and AR for non-inundated area
+ CALL write_history_variable_3d ( DEF_hist_vars%O2_DECOMP_DEPTH_UNSAT, &
+ a_o2_decomp_depth_unsat, file_hist, 'f_O2_DECOMP_DEPTH_UNSAT', &
+ itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'O2 consumption from HR and AR for non-inundated area','mol/m3/s')
+ ENDIF
+
+ IF (DEF_USE_FIRE) THEN
+ CALL write_history_variable_2d ( DEF_hist_vars%abm, &
+ vecacc, file_hist, 'f_abm', itime_in_file, sumarea, filter, &
+ 'peak crop fire month','unitless')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%gdp, &
+ vecacc, file_hist, 'f_gdp', itime_in_file, sumarea, filter, &
+ 'gdp','unitless')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%peatf, &
+ vecacc, file_hist, 'f_peatf', itime_in_file, sumarea, filter, &
+ 'peatf','unitless')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%hdm, &
+ vecacc, file_hist, 'f_hdm', itime_in_file, sumarea, filter, &
+ 'hdm','unitless')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%lnfm, &
+ vecacc, file_hist, 'f_lnfm', itime_in_file, sumarea, filter, &
+ 'lnfm','unitless')
+ ENDIF
+
+ IF(DEF_USE_DiagMatrix)THEN
+ ! litter 1 carbon capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr1cCap_vr, &
+ a_litr1cCap_vr, file_hist, 'f_litr1cCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 1 carbon capacity density in soil layers','gC/m3')
+
+ ! litter 2 carbon capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr2cCap_vr, &
+ a_litr2cCap_vr, file_hist, 'f_litr2cCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 2 carbon capacity density in soil layers','gC/m3')
+
+ ! litter 3 carbon capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr3cCap_vr, &
+ a_litr3cCap_vr, file_hist, 'f_litr3cCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 3 carbon capacity density in soil layers','gC/m3')
+
+ ! soil 1 carbon capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil1cCap_vr, &
+ a_soil1cCap_vr, file_hist, 'f_soil1cCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 1 carbon capacity density in soil layers','gC/m3')
+
+ ! soil 2 carbon capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil2cCap_vr, &
+ a_soil2cCap_vr, file_hist, 'f_soil2cCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 2 carbon capacity density in soil layers','gC/m3')
+
+ ! soil 3 carbon capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil3cCap_vr, &
+ a_soil3cCap_vr, file_hist, 'f_soil3cCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 3 carbon capacity density in soil layers','gC/m3')
+
+ ! coarse woody debris carbon capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%cwdcCap_vr, &
+ a_cwdcCap_vr, file_hist, 'f_cwdcCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'coarse woody debris carbon capacity density in soil layers','gC/m3')
+
+ ! litter 1 nitrogen capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr1nCap_vr, &
+ a_litr1nCap_vr, file_hist, 'f_litr1nCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 1 nitrogen capacity density in soil layers','gN/m3')
+
+ ! litter 2 nitrogen capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr2nCap_vr, &
+ a_litr2nCap_vr, file_hist, 'f_litr2nCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 2 nitrogen capacity density in soil layers','gN/m3')
+
+ ! litter 3 nitrogen capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%litr3nCap_vr, &
+ a_litr3nCap_vr, file_hist, 'f_litr3nCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'litter 3 nitrogen capacity density in soil layers','gN/m3')
+
+ ! soil 1 nitrogen capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil1nCap_vr, &
+ a_soil1nCap_vr, file_hist, 'f_soil1nCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 1 nitrogen capacity density in soil layers','gN/m3')
+
+ ! soil 2 nitrogen capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil2nCap_vr, &
+ a_soil2nCap_vr, file_hist, 'f_soil2nCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 2 nitrogen capacity density in soil layers','gN/m3')
+
+ ! soil 3 nitrogen capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%soil3nCap_vr, &
+ a_soil3nCap_vr, file_hist, 'f_soil3nCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,'soil 3 nitrogen capacity density in soil layers','gN/m3')
+
+ ! coarse woody debris nitrogen capacity density in soil layers
+ CALL write_history_variable_3d ( DEF_hist_vars%cwdnCap_vr, &
+ a_cwdnCap_vr, file_hist, 'f_cwdnCap_vr', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter,&
+ 'coarse woody debris nitrogen capacity density in soil layers','gN/m3')
+
+ ! Temperature environmental scalar
+ CALL write_history_variable_3d ( DEF_hist_vars%t_scalar, &
+ a_t_scalar, file_hist, 'f_t_scalar', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter, 'Temperature environmental scalar','unitless')
+
+ ! Water environmental scalar
+ CALL write_history_variable_3d ( DEF_hist_vars%w_scalar, &
+ a_w_scalar, file_hist, 'f_w_scalar', itime_in_file, 'soil', 1, nl_soil, &
+ sumarea, filter, 'Water environmental scalar','unitless')
+
+ ENDIF
+
+
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) .ne. 12 .and. patchtype(i) .eq. 0)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! 1: gpp enf temperate
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_enftemp, &
+ a_gpp_enftemp, file_hist, 'f_gpp_enftemp', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for needleleaf evergreen temperate tree','gC/m2/s')
+
+ ! 1: leaf carbon display pool enf temperate
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_enftemp, &
+ a_leafc_enftemp, file_hist, 'f_leafc_enftemp', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for needleleaf evergreen temperate tree','gC/m2')
+
+ ! 1: leaf area index enf temperate
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_enftemp, &
+ a_lai_enftemp, file_hist, 'f_lai_enftemp', itime_in_file, sumarea, filter, &
+ 'leaf area index for needleleaf evergreen temperate tree','m2/m2')
+
+ ! 1: npp enf temperate
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_enftemp, &
+ a_npp_enftemp, file_hist, 'f_npp_enftemp', itime_in_file, sumarea, filter, &
+ 'npp for needleleaf evergreen temperate tree','m2/m2')
+
+ ! 1: npp to leafc enf temperate
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_enftemp, &
+ a_npptoleafc_enftemp, file_hist, 'f_npptoleafc_enftemp', itime_in_file, sumarea, filter, &
+ 'npp to leafc for needleleaf evergreen temperate tree','m2/m2')
+
+ ! 2: gpp enf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_enfboreal, &
+ a_gpp_enfboreal, file_hist, 'f_gpp_enfboreal', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for needleleaf evergreen boreal tree','gC/m2/s')
+
+ ! 2: leaf carbon display pool enf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_enfboreal, &
+ a_leafc_enfboreal, file_hist, 'f_leafc_enfboreal', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for needleleaf evergreen boreal tree','gC/m2')
+
+ ! 2: leaf area index enf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_enfboreal, &
+ a_lai_enfboreal, file_hist, 'f_lai_enfboreal', itime_in_file, sumarea, filter, &
+ 'leaf area index for needleleaf evergreen boreal tree','m2/m2')
+
+ ! 2: npp enf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_enfboreal, &
+ a_npp_enfboreal, file_hist, 'f_npp_enfboreal', itime_in_file, sumarea, filter, &
+ 'npp for needleleaf evergreen boreal tree','m2/m2')
+
+ ! 2: npp to leafc enf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_enfboreal, &
+ a_npptoleafc_enfboreal, file_hist, 'f_npptoleafc_enfboreal', itime_in_file, sumarea, filter, &
+ 'npp to leafc for needleleaf evergreen boreal tree','m2/m2')
+
+ ! 3: gpp dnf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_dnfboreal, &
+ a_gpp_dnfboreal, file_hist, 'f_gpp_dnfboreal', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for needleleaf deciduous boreal tree','gC/m2/s')
+
+ ! 3: leaf carbon display pool dnf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_dnfboreal, &
+ a_leafc_dnfboreal, file_hist, 'f_leafc_dnfboreal', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for needleleaf deciduous boreal tree','gC/m2')
+
+ ! 3: leaf area index dnf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_dnfboreal, &
+ a_lai_dnfboreal, file_hist, 'f_lai_dnfboreal', itime_in_file, sumarea, filter, &
+ 'leaf area index for needleleaf deciduous boreal tree','m2/m2')
+
+ ! 3: npp dnf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_dnfboreal, &
+ a_npp_dnfboreal, file_hist, 'f_npp_dnfboreal', itime_in_file, sumarea, filter, &
+ 'npp for needleleaf deciduous boreal tree','m2/m2')
+
+ ! 3: npp to leafc dnf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dnfboreal, &
+ a_npptoleafc_dnfboreal, file_hist, 'f_npptoleafc_dnfboreal', itime_in_file, sumarea, filter, &
+ 'npp to leafc for needleleaf deciduous boreal tree','m2/m2')
+
+ ! 4: gpp ebf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebftrop, &
+ a_gpp_ebftrop, file_hist, 'f_gpp_ebftrop', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for broadleaf evergreen tropical tree','gC/m2/s')
+
+ ! 4: leaf carbon display pool ebf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebftrop, &
+ a_leafc_ebftrop, file_hist, 'f_leafc_ebftrop', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for broadleaf evergreen tropical tree','gC/m2')
+
+ ! 4: leaf area index ebf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_ebftrop, &
+ a_lai_ebftrop, file_hist, 'f_lai_ebftrop', itime_in_file, sumarea, filter, &
+ 'leaf area index for broadleaf evergreen tropical tree','m2/m2')
+
+ ! 4: npp ebf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_ebftrop, &
+ a_npp_ebftrop, file_hist, 'f_npp_ebftrop', itime_in_file, sumarea, filter, &
+ 'npp for broadleaf evergreen tropical tree','m2/m2')
+
+ ! 4: npp to leafc ebf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_ebftrop, &
+ a_npptoleafc_ebftrop, file_hist, 'f_npptoleafc_ebftrop', itime_in_file, sumarea, filter, &
+ 'npp to leafc for broadleaf evergreen tropical tree','m2/m2')
+
+ ! 5: gpp ebf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebftemp, &
+ a_gpp_ebftemp, file_hist, 'f_gpp_ebftemp', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for broadleaf evergreen temperate tree','gC/m2/s')
+
+ ! 5: leaf carbon display pool ebf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebftemp, &
+ a_leafc_ebftemp, file_hist, 'f_leafc_ebftemp', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for broadleaf evergreen temperate tree','gC/m2')
+
+ ! 5: leaf area index ebf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_ebftemp, &
+ a_lai_ebftemp, file_hist, 'f_lai_ebftemp', itime_in_file, sumarea, filter, &
+ 'leaf area index for broadleaf evergreen temperate tree','m2/m2')
+
+ ! 5: npp ebf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_ebftemp, &
+ a_npp_ebftemp, file_hist, 'f_npp_ebftemp', itime_in_file, sumarea, filter, &
+ 'npp for broadleaf evergreen temperate tree','m2/m2')
+
+ ! 5: npp to leafc ebf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_ebftemp, &
+ a_npptoleafc_ebftemp, file_hist, 'f_npptoleafc_ebftemp', itime_in_file, sumarea, filter, &
+ 'npp to leafc for broadleaf evergreen temperate tree','m2/m2')
+
+ ! 6: gpp dbf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbftrop, &
+ a_gpp_dbftrop, file_hist, 'f_gpp_dbftrop', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for broadleaf deciduous tropical tree','gC/m2/s')
+
+ ! 6: leaf carbon display pool dbf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbftrop, &
+ a_leafc_dbftrop, file_hist, 'f_leafc_dbftrop', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for broadleaf deciduous tropical tree','gC/m2')
+
+ ! 6: leaf area index dbf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_dbftrop, &
+ a_lai_dbftrop, file_hist, 'f_lai_dbftrop', itime_in_file, sumarea, filter, &
+ 'leaf area index for broadleaf evergreen temperate tree','m2/m2')
+
+ ! 6: npp dbf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_dbftrop, &
+ a_npp_dbftrop, file_hist, 'f_npp_dbftrop', itime_in_file, sumarea, filter, &
+ 'npp for broadleaf evergreen temperate tree','m2/m2')
+
+ ! 6: npp to leafc dbf trop
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbftrop, &
+ a_npptoleafc_dbftrop, file_hist, 'f_npptoleafc_dbftrop', itime_in_file, sumarea, filter, &
+ 'npp to leafc for broadleaf evergreen temperate tree','m2/m2')
+
+ ! 7: gpp dbf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbftemp, &
+ a_gpp_dbftemp, file_hist, 'f_gpp_dbftemp', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for broadleaf deciduous temperate tree','gC/m2/s')
+
+ ! 7: leaf carbon display pool dbf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbftemp, &
+ a_leafc_dbftemp, file_hist, 'f_leafc_dbftemp', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for broadleaf deciduous temperate tree','gC/m2')
+
+ ! 7: leaf area index dbf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_dbftemp, &
+ a_lai_dbftemp, file_hist, 'f_lai_dbftemp', itime_in_file, sumarea, filter, &
+ 'leaf area index for broadleaf decidous temperate tree','m2/m2')
+
+ ! 7: npp dbf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_dbftemp, &
+ a_npp_dbftemp, file_hist, 'f_npp_dbftemp', itime_in_file, sumarea, filter, &
+ 'npp for broadleaf decidous temperate tree','m2/m2')
+
+ ! 7: npp to leafc dbf temp
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbftemp, &
+ a_npptoleafc_dbftemp, file_hist, 'f_npptoleafc_dbftemp', itime_in_file, sumarea, filter, &
+ 'npp to leafc for broadleaf decidous temperate tree','m2/m2')
+
+ ! 8: gpp dbf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbfboreal, &
+ a_gpp_dbfboreal, file_hist, 'f_gpp_dbfboreal', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for broadleaf deciduous boreal tree','gC/m2/s')
+
+ ! 8: leaf carbon display pool dbf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbfboreal, &
+ a_leafc_dbfboreal, file_hist, 'f_leafc_dbfboreal', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for broadleaf deciduous boreal tree','gC/m2')
+
+ ! 8: leaf area index dbf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_dbfboreal, &
+ a_lai_dbfboreal, file_hist, 'f_lai_dbfboreal', itime_in_file, sumarea, filter, &
+ 'leaf area index for broadleaf decidous boreal tree','m2/m2')
+
+ ! 8: npp dbf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_dbfboreal, &
+ a_npp_dbfboreal, file_hist, 'f_npp_dbfboreal', itime_in_file, sumarea, filter, &
+ 'npp for broadleaf decidous boreal tree','m2/m2')
+
+ ! 8: npp to leafc dbf boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbfboreal, &
+ a_npptoleafc_dbfboreal, file_hist, 'f_npptoleafc_dbfboreal', itime_in_file, sumarea, filter, &
+ 'npp to leafc for broadleaf decidous boreal tree','m2/m2')
+
+ ! 9: gpp ebs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_ebstemp, &
+ a_gpp_ebstemp, file_hist, 'f_gpp_ebstemp', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for broadleaf evergreen temperate shrub','gC/m2/s')
+
+ ! 9: leaf carbon display pool ebs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_ebstemp, &
+ a_leafc_ebstemp, file_hist, 'f_leafc_ebstemp', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for broadleaf evergreen temperate shrub','gC/m2')
+
+ ! 9: leaf area index ebs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_ebstemp, &
+ a_lai_ebstemp, file_hist, 'f_lai_ebstemp', itime_in_file, sumarea, filter, &
+ 'leaf area index for broadleaf evergreen temperate shrub','m2/m2')
+
+ ! 9: npp ebs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_ebstemp, &
+ a_npp_ebstemp, file_hist, 'f_npp_ebstemp', itime_in_file, sumarea, filter, &
+ 'npp for broadleaf evergreen temperate shrub','m2/m2')
+
+ ! 9: npp to leafc ebs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_ebstemp, &
+ a_npptoleafc_ebstemp, file_hist, 'f_npptoleafc_ebstemp', itime_in_file, sumarea, filter, &
+ 'npp to leafc for broadleaf evergreen temperate shrub','m2/m2')
+
+ ! 10: gpp dbs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbstemp, &
+ a_gpp_dbstemp, file_hist, 'f_gpp_dbstemp', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for broadleaf deciduous temperate shrub','gC/m2/s')
+
+ ! 10: leaf carbon display pool dbs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbstemp, &
+ a_leafc_dbstemp, file_hist, 'f_leafc_dbstemp', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for broadleaf deciduous temperate shrub','gC/m2')
+
+ ! 10: leaf area index dbs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_dbstemp, &
+ a_lai_dbstemp, file_hist, 'f_lai_dbstemp', itime_in_file, sumarea, filter, &
+ 'leaf area index for broadleaf deciduous temperate shrub','m2/m2')
+
+ ! 10: npp dbs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_dbstemp, &
+ a_npp_dbstemp, file_hist, 'f_npp_dbstemp', itime_in_file, sumarea, filter, &
+ 'npp for broadleaf deciduous temperate shrub','m2/m2')
+
+ ! 10: npp to leafc dbs temp
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbstemp, &
+ a_npptoleafc_dbstemp, file_hist, 'f_npptoleafc_dbstemp', itime_in_file, sumarea, filter, &
+ 'npp to leafc for broadleaf deciduous temperate shrub','m2/m2')
+
+ ! 11: gpp dbs boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_dbsboreal, &
+ a_gpp_dbsboreal, file_hist, 'f_gpp_dbsboreal', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for broadleaf deciduous boreal shrub','gC/m2/s')
+
+ ! 11: leaf carbon display pool dbs boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_dbsboreal, &
+ a_leafc_dbsboreal, file_hist, 'f_leafc_dbsboreal', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for broadleaf deciduous boreal shrub','gC/m2')
+
+ ! 11: leaf area index dbs boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_dbsboreal, &
+ a_lai_dbsboreal, file_hist, 'f_lai_dbsboreal', itime_in_file, sumarea, filter, &
+ 'leaf area index for broadleaf deciduous boreal shrub','m2/m2')
+
+ ! 11: npp dbs boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_dbsboreal, &
+ a_npp_dbsboreal, file_hist, 'f_npp_dbsboreal', itime_in_file, sumarea, filter, &
+ 'npp for broadleaf deciduous boreal shrub','m2/m2')
+
+ ! 11: npp to leafc dbs boreal
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_dbsboreal, &
+ a_npptoleafc_dbsboreal, file_hist, 'f_npptoleafc_dbsboreal', itime_in_file, sumarea, filter, &
+ 'npp to leafc for broadleaf deciduous boreal shrub','m2/m2')
+
+ ! 12: gpp arctic c3 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_c3arcgrass, &
+ a_gpp_c3arcgrass, file_hist, 'f_gpp_c3arcgrass', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for c3 arctic grass','gC/m2/s')
+
+ ! 12: leaf carbon display pool c3 arctic grass
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_c3arcgrass, &
+ a_leafc_c3arcgrass, file_hist, 'f_leafc_c3arcgrass', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for c3 arctic grass','gC/m2')
+
+ ! 12: leaf area index c3 arctic grass
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_c3arcgrass, &
+ a_lai_c3arcgrass, file_hist, 'f_lai_c3arcgrass', itime_in_file, sumarea, filter, &
+ 'leaf area index for c3 arctic grass','gC/m2')
+
+ ! 12: npp c3 arctic grass
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_c3arcgrass, &
+ a_npp_c3arcgrass, file_hist, 'f_npp_c3arcgrass', itime_in_file, sumarea, filter, &
+ 'npp for c3 arctic grass','gC/m2')
+
+ ! 12: npp to leafc c3 arctic grass
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_c3arcgrass, &
+ a_npptoleafc_c3arcgrass, file_hist, 'f_npptoleafc_c3arcgrass', itime_in_file, sumarea, filter, &
+ 'npp to leafc for c3 arctic grass','gC/m2')
+
+ ! 13: gpp c3 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_c3grass, &
+ a_gpp_c3grass, file_hist, 'f_gpp_c3grass', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for c3 grass','gC/m2/s')
+
+ ! 13: leaf carbon display pool arctic c3 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_c3grass, &
+ a_leafc_c3grass, file_hist, 'f_leafc_c3grass', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for c3 arctic grass','gC/m2')
+
+ ! 13: leaf area index arctic c3 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_c3grass, &
+ a_lai_c3grass, file_hist, 'f_lai_c3grass', itime_in_file, sumarea, filter, &
+ 'leaf area index for c3 arctic grass','gC/m2')
+
+ ! 13: npp arctic c3 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_c3grass, &
+ a_npp_c3grass, file_hist, 'f_npp_c3grass', itime_in_file, sumarea, filter, &
+ 'npp for c3 arctic grass','gC/m2')
+
+ ! 13: npp to leafc arctic c3 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_c3grass, &
+ a_npptoleafc_c3grass, file_hist, 'f_npptoleafc_c3grass', itime_in_file, sumarea, filter, &
+ 'npp to leafc for c3 arctic grass','gC/m2')
+
+ ! 14: gpp c4 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%gpp_c4grass, &
+ a_gpp_c4grass, file_hist, 'f_gpp_c4grass', itime_in_file, sumarea, filter, &
+ 'gross primary productivity for c4 grass','gC/m2/s')
+
+ ! 14: leaf carbon display pool arctic c4 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%leafc_c4grass, &
+ a_leafc_c4grass, file_hist, 'f_leafc_c4grass', itime_in_file, sumarea, filter, &
+ 'leaf carbon display pool for c4 arctic grass','gC/m2')
+
+ ! 14: leaf area index arctic c4 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%lai_c4grass, &
+ a_lai_c4grass, file_hist, 'f_lai_c4grass', itime_in_file, sumarea, filter, &
+ 'leaf area index for c4 arctic grass','gC/m2')
+
+ ! 14: npp arctic c4 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%npp_c4grass, &
+ a_npp_c4grass, file_hist, 'f_npp_c4grass', itime_in_file, sumarea, filter, &
+ 'npp for c4 arctic grass','gC/m2')
+
+ ! 14: npp to leafc arctic c4 grass
+ CALL write_history_variable_2d ( DEF_hist_vars%npptoleafc_c4grass, &
+ a_npptoleafc_c4grass, file_hist, 'f_npptoleafc_c4grass', itime_in_file, sumarea, filter, &
+ 'npp to leafc for c4 arctic grass','gC/m2')
+
+#ifdef CROP
+!*****************************************
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_manunitro (:)
+ ENDIF
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%manunitro, &
+ vecacc, file_hist, 'f_manunitro', itime_in_file, sumarea, filter, &
+ 'nitrogen in manure','gN/m2/yr')
+
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_hui (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%huiswheat, &
+ vecacc, file_hist, 'f_huiswheat', itime_in_file, sumarea, filter, &
+ 'heat unit index (rainfed spring wheat)','unitless')
+
+!************************************************************
+! IF (p_is_compute) THEN
+! IF (numpatch > 0) THEN
+! DO i=1,numpatch
+! IF(patchclass(i) == 12)THEN
+! IF(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 &
+! .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)THEN
+! filter(i) = .true.
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ENDDO
+! ENDIF
+! ENDIF
+!
+! IF (HistForm == 'Gridded') THEN
+! CALL mp2g_hist%get_sumarea (sumarea, filter)
+! ENDIF
+!
+! CALL write_history_variable_2d ( DEF_hist_vars%pdcorn, &
+! a_pdcorn, file_hist, 'f_pdcorn', &
+! itime_in_file, sumarea, filter, 'planting date of corn', 'day')
+!
+! IF (p_is_compute) THEN
+! IF (numpatch > 0) THEN
+! DO i=1,numpatch
+! IF(patchclass(i) == 12)THEN
+! IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN
+! filter(i) = .true.
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ENDDO
+! ENDIF
+! ENDIF
+!
+! IF (HistForm == 'Gridded') THEN
+! CALL mp2g_hist%get_sumarea (sumarea, filter)
+! ENDIF
+!
+! CALL write_history_variable_2d ( DEF_hist_vars%pdswheat, &
+! a_pdswheat, file_hist, 'f_pdswheat', &
+! itime_in_file, sumarea, filter,'planting date of spring wheat','day')
+!
+! IF (p_is_compute) THEN
+! IF (numpatch > 0) THEN
+! DO i=1,numpatch
+! IF(patchclass(i) == 12)THEN
+! IF(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)THEN
+! filter(i) = .true.
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ENDDO
+! ENDIF
+! ENDIF
+!
+! IF (HistForm == 'Gridded') THEN
+! CALL mp2g_hist%get_sumarea (sumarea, filter)
+! ENDIF
+!
+! CALL write_history_variable_2d ( DEF_hist_vars%pdwwheat, &
+! a_pdwwheat, file_hist, 'f_pdwwheat', &
+! itime_in_file, sumarea, filter,'planting date of winter wheat','day')
+!
+! IF (p_is_compute) THEN
+! IF (numpatch > 0) THEN
+! DO i=1,numpatch
+! IF(patchclass(i) == 12)THEN
+! IF(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 &
+! .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)THEN
+! filter(i) = .true.
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ENDDO
+! ENDIF
+! ENDIF
+!
+! IF (HistForm == 'Gridded') THEN
+! CALL mp2g_hist%get_sumarea (sumarea, filter)
+! ENDIF
+!
+! CALL write_history_variable_2d ( DEF_hist_vars%pdsoybean, &
+! a_pdsoybean, file_hist, 'f_pdsoybean', &
+! itime_in_file, sumarea, filter,'planting date of soybean','day')
+!
+! IF (p_is_compute) THEN
+! IF (numpatch > 0) THEN
+! DO i=1,numpatch
+! IF(patchclass(i) == 12)THEN
+! IF(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)THEN
+! filter(i) = .true.
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ENDDO
+! ENDIF
+! ENDIF
+!
+! IF (HistForm == 'Gridded') THEN
+! CALL mp2g_hist%get_sumarea (sumarea, filter)
+! ENDIF
+!
+! CALL write_history_variable_2d ( DEF_hist_vars%pdcotton, &
+! a_pdcotton, file_hist, 'f_pdcotton', &
+! itime_in_file, sumarea, filter,'planting date of cotton','day')
+!
+! IF (p_is_compute) THEN
+! IF (numpatch > 0) THEN
+! DO i=1,numpatch
+! IF(patchclass(i) == 12)THEN
+! IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN
+! filter(i) = .true.
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ENDDO
+! ENDIF
+! ENDIF
+!
+! IF (HistForm == 'Gridded') THEN
+! CALL mp2g_hist%get_sumarea (sumarea, filter)
+! ENDIF
+!
+! CALL write_history_variable_2d ( DEF_hist_vars%pdrice1, &
+! a_pdrice1, file_hist, 'f_pdrice1', &
+! itime_in_file, sumarea, filter,'planting date of rice1','day')
+!
+! IF (p_is_compute) THEN
+! IF (numpatch > 0) THEN
+! DO i=1,numpatch
+! IF(patchclass(i) == 12)THEN
+! IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN
+! filter(i) = .true.
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ENDDO
+! ENDIF
+! ENDIF
+!
+! IF (HistForm == 'Gridded') THEN
+! CALL mp2g_hist%get_sumarea (sumarea, filter)
+! ENDIF
+!
+! CALL write_history_variable_2d ( DEF_hist_vars%pdrice2, &
+! a_pdrice2, file_hist, 'f_pdrice2', &
+! itime_in_file, sumarea, filter,'planting date of rice2','day')
+!
+! IF (p_is_compute) THEN
+! IF (numpatch > 0) THEN
+! DO i=1,numpatch
+! IF(patchclass(i) == 12)THEN
+! IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN
+! filter(i) = .true.
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ELSE
+! filter(i) = .false.
+! ENDIF
+! ENDDO
+! ENDIF
+! ENDIF
+!
+! IF (HistForm == 'Gridded') THEN
+! CALL mp2g_hist%get_sumarea (sumarea, filter)
+! ENDIF
+!
+! CALL write_history_variable_2d ( DEF_hist_vars%pdsugarcane, &
+! a_pdsugarcane, file_hist, 'f_pdsugarcane', &
+! itime_in_file, sumarea, filter,'planting date of sugarcane','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 17 .or. pftclass(patch_pft_s(i)) .eq. 18 &
+ .or. pftclass(patch_pft_s(i)) .eq. 75 .or. pftclass(patch_pft_s(i)) .eq. 76)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_corn, &
+ a_fertnitro_corn, file_hist, 'f_fertnitro_corn', &
+ itime_in_file, sumarea, filter,'nitrogen fertilizer for corn','gN/m2/yr')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 19 .or. pftclass(patch_pft_s(i)) .eq. 20)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_swheat, &
+ a_fertnitro_swheat, file_hist, 'f_fertnitro_swheat', &
+ itime_in_file, sumarea, filter,'nitrogen fertilizer for spring wheat','gN/m2/yr')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 21 .or. pftclass(patch_pft_s(i)) .eq. 22)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_wwheat, &
+ a_fertnitro_wwheat, file_hist, 'f_fertnitro_wwheat', &
+ itime_in_file, sumarea, filter,'nitrogen fertilizer for winter wheat','gN/m2/yr')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 23 .or. pftclass(patch_pft_s(i)) .eq. 24 &
+ .or. pftclass(patch_pft_s(i)) .eq. 77 .or. pftclass(patch_pft_s(i)) .eq. 78)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_soybean, &
+ a_fertnitro_soybean, file_hist, 'f_fertnitro_soybean', &
+ itime_in_file, sumarea, filter,'nitrogen fertilizer for soybean','gN/m2/yr')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 41 .or. pftclass(patch_pft_s(i)) .eq. 42)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_cotton, &
+ a_fertnitro_cotton, file_hist, 'f_fertnitro_cotton', &
+ itime_in_file, sumarea, filter,'nitrogen fertilizer for cotton','gN/m2/yr')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice1, &
+ a_fertnitro_rice1, file_hist, 'f_fertnitro_rice1', &
+ itime_in_file, sumarea, filter,'nitrogen fertilizer for rice1','gN/m2/yr')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 61 .or. pftclass(patch_pft_s(i)) .eq. 62)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_rice2, &
+ a_fertnitro_rice2, file_hist, 'f_fertnitro_rice2', &
+ itime_in_file, sumarea, filter,'nitrogen fertilizer for rice2','gN/m2/yr')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 67 .or. pftclass(patch_pft_s(i)) .eq. 68)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%fertnitro_sugarcane, &
+ a_fertnitro_sugarcane, file_hist, 'f_fertnitro_sugarcane', &
+ itime_in_file, sumarea, filter,'nitrogen fertilizer for sugarcane','gN/m2/yr')
+
+ IF(DEF_USE_IRRIGATION)THEN
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 17)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_corn, &
+ a_irrig_method_corn, file_hist, 'f_irrig_method_corn', &
+ itime_in_file, sumarea, filter,'irrigation method for corn','-')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)).eq.19 .or. pftclass(patch_pft_s(i)).eq.20)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_swheat, &
+ a_irrig_method_swheat, file_hist, 'f_irrig_method_swheat', &
+ itime_in_file, sumarea, filter,'irrigation method for spring wheat','-')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)).eq.21 .or. pftclass(patch_pft_s(i)).eq.22)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_wwheat, &
+ a_irrig_method_wwheat, file_hist, 'f_irrig_method_wwheat', &
+ itime_in_file, sumarea, filter,'irrigation method for winter wheat','-')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)).eq.23 .or. pftclass(patch_pft_s(i)).eq.24 &
+ .or. pftclass(patch_pft_s(i)).eq.77 .or. pftclass(patch_pft_s(i)).eq.78)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_soybean, &
+ a_irrig_method_soybean, file_hist, 'f_irrig_method_soybean', &
+ itime_in_file, sumarea, filter,'irrigation method for soybean','-')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)).eq.41 .or. pftclass(patch_pft_s(i)).eq.42)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_cotton, &
+ a_irrig_method_cotton, file_hist, 'f_irrig_method_cotton', &
+ itime_in_file, sumarea, filter,'irrigation method for cotton','-')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)).eq.61 .or. pftclass(patch_pft_s(i)).eq.62)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice1, &
+ a_irrig_method_rice1, file_hist, 'f_irrig_method_rice1', &
+ itime_in_file, sumarea, filter,'irrigation method for rice1','-')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)).eq.61 .or. pftclass(patch_pft_s(i)).eq.62)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_rice2, &
+ a_irrig_method_rice2, file_hist, 'f_irrig_method_rice2', &
+ itime_in_file, sumarea, filter,'irrigation method for rice2','-')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)).eq.67 .or. pftclass(patch_pft_s(i)).eq.68)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%irrig_method_sugarcane, &
+ a_irrig_method_sugarcane, file_hist, 'f_irrig_method_sugarcane', &
+ itime_in_file, sumarea, filter,'irrigation method for sugarcane','-')
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 17)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of rainfed temperate corn
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_corn, &
+ vecacc, file_hist, 'f_plantdate_rainfed_temp_corn', itime_in_file, sumarea, filter, &
+ 'Crop planting date (rainfed temperate corn)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 18)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of irrigated temperate corn
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_corn, &
+ vecacc, file_hist, 'f_plantdate_irrigated_temp_corn', itime_in_file, sumarea, filter, &
+ 'Crop planting date (irrigated temperate corn)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 19)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of rainfed spring wheat
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_spwheat, &
+ vecacc, file_hist, 'f_plantdate_rainfed_spwheat', itime_in_file, sumarea, filter, &
+ 'Crop planting date (rainfed spring wheat)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 20)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of irrigated spring wheat
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_spwheat, &
+ vecacc, file_hist, 'f_plantdate_irrigated_spwheat', itime_in_file, sumarea, filter, &
+ 'Crop planting date (irrigated spring wheat)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 21)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of rainfed winter wheat
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_wtwheat, &
+ vecacc, file_hist, 'f_plantdate_rainfed_wtwheat', itime_in_file, sumarea, filter, &
+ 'Crop planting date (rainfed winter wheat)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 22)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of irrigated winter wheat
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_wtwheat, &
+ vecacc, file_hist, 'f_plantdate_irrigated_wtwheat', itime_in_file, sumarea, filter, &
+ 'Crop planting date (irrigated winter wheat)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 23)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of rainfed temperate soybean
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_temp_soybean, &
+ vecacc, file_hist, 'f_plantdate_rainfed_temp_soybean', &
+ itime_in_file, sumarea, filter, &
+ 'Crop planting date (rainfed temperate soybean)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 24)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of irrigated temperate soybean
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_temp_soybean, &
+ vecacc, file_hist, 'f_plantdate_irrigated_temp_soybean', &
+ itime_in_file, sumarea, filter, &
+ 'Crop planting date (irrigated temperate soybean)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 41)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of rainfed cotton
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_cotton, &
+ vecacc, file_hist, 'f_plantdate_rainfed_cotton', itime_in_file, sumarea, filter, &
+ 'Crop planting date (rainfed cotton)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 42)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of irrigated cotton
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_cotton, &
+ vecacc, file_hist, 'f_plantdate_irrigated_cotton', itime_in_file, sumarea, filter, &
+ 'Crop planting date (irrigated cotton)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 61)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of rainfed rice
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_rice, &
+ vecacc, file_hist, 'f_plantdate_rainfed_rice', itime_in_file, sumarea, filter, &
+ 'Crop planting date (rainfed rice)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 62)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of irrigated rice
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_rice, &
+ vecacc, file_hist, 'f_plantdate_irrigated_rice', itime_in_file, sumarea, filter, &
+ 'Crop planting date (irrigated rice)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 67)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of rainfed sugarcane
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_sugarcane, &
+ vecacc, file_hist, 'f_plantdate_rainfed_sugarcane', itime_in_file, sumarea, filter, &
+ 'Crop planting date (rainfed sugarcane)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 68)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of irrigated sugarcane
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_sugarcane, &
+ vecacc, file_hist, 'f_plantdate_irrigated_sugarcane', itime_in_file, sumarea, filter, &
+ 'Crop planting date (irrigated sugarcane)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 75)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of rainfed trop corn
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_corn, &
+ vecacc, file_hist, 'f_plantdate_rainfed_trop_corn', itime_in_file, sumarea, filter, &
+ 'Crop planting date (rainfed trop corn)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 76)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of irrigated trop corn
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_corn, &
+ vecacc, file_hist, 'f_plantdate_irrigated_trop_corn', itime_in_file, sumarea, filter, &
+ 'Crop planting date (irrigated trop corn)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 77)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of rainfed trop soybean
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_rainfed_trop_soybean, &
+ vecacc, file_hist, 'f_plantdate_rainfed_trop_soybean', &
+ itime_in_file, sumarea, filter, &
+ 'Crop planting date (rainfed trop soybean)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 78)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of irrigated trop soybean
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_irrigated_trop_soybean, &
+ vecacc, file_hist, 'f_plantdate_irrigated_trop_soybean', &
+ itime_in_file, sumarea, filter, &
+ 'Crop planting date (irrigated trop soybean)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 15)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! planting date of unmanaged crop production
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_plantdate (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%plantdate_unmanagedcrop, &
+ vecacc, file_hist, 'f_plantdate_unmanagedcrop', itime_in_file, sumarea, filter, &
+ 'Crop planting date (unmanaged crop production)','day')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 17)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to corn production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_corn, &
+ vecacc, file_hist, 'f_cropprodc_rainfed_temp_corn', itime_in_file, sumarea, filter, &
+ 'Crop production (rainfed temperate corn)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 18)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to corn production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_corn, &
+ vecacc, file_hist, 'f_cropprodc_irrigated_temp_corn', itime_in_file, sumarea, filter, &
+ 'Crop production (irrigated temperate corn)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 19)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to spring wheat production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_spwheat, &
+ vecacc, file_hist, 'f_cropprodc_rainfed_spwheat', itime_in_file, sumarea, filter, &
+ 'Crop production (rainfed spring wheat)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 20)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to spring wheat production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_spwheat, &
+ vecacc, file_hist, 'f_cropprodc_irrigated_spwheat', itime_in_file, sumarea, filter, &
+ 'Crop production (irrigated spring wheat)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 21)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to winter wheat production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_wtwheat, &
+ vecacc, file_hist, 'f_cropprodc_rainfed_wtwheat', itime_in_file, sumarea, filter, &
+ 'Crop production (rainfed winter wheat)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 22)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to winter wheat production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_wtwheat, &
+ vecacc, file_hist, 'f_cropprodc_irrigated_wtwheat', itime_in_file, sumarea, filter, &
+ 'Crop production (irrigated winter wheat)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 23)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to soybean production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_temp_soybean, &
+ vecacc, file_hist, 'f_cropprodc_rainfed_temp_soybean', &
+ itime_in_file, sumarea, filter, &
+ 'Crop production (rainfed temperate soybean)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 24)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to soybean production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_temp_soybean, &
+ vecacc, file_hist, 'f_cropprodc_irrigated_temp_soybean', &
+ itime_in_file, sumarea, filter, &
+ 'Crop production (irrigated temperate soybean)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 41)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to cotton production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_cotton, &
+ vecacc, file_hist, 'f_cropprodc_rainfed_cotton', itime_in_file, sumarea, filter, &
+ 'Crop production (rainfed cotton)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 42)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to cotton production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_cotton, &
+ vecacc, file_hist, 'f_cropprodc_irrigated_cotton', itime_in_file, sumarea, filter, &
+ 'Crop production (irrigated cotton)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 61)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to rice production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_rice, &
+ vecacc, file_hist, 'f_cropprodc_rainfed_rice', itime_in_file, sumarea, filter, &
+ 'Crop production (rainfed rice)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 62)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to rice production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_rice, &
+ vecacc, file_hist, 'f_cropprodc_irrigated_rice', itime_in_file, sumarea, filter, &
+ 'Crop production (irrigated rice)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 67)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to sugarcane production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_sugarcane, &
+ vecacc, file_hist, 'f_cropprodc_rainfed_sugarcane', itime_in_file, sumarea, filter, &
+ 'Crop production (rainfed sugarcane)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 68)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to sugarcane production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_sugarcane, &
+ vecacc, file_hist, 'f_cropprodc_irrigated_sugarcane', itime_in_file, sumarea, filter, &
+ 'Crop production (irrigated sugarcane)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 75)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to sugarcane production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_corn, &
+ vecacc, file_hist, 'f_cropprodc_rainfed_trop_corn', itime_in_file, sumarea, filter, &
+ 'Crop production (rainfed_trop_corn)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 76)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to sugarcane production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_corn, &
+ vecacc, file_hist, 'f_cropprodc_irrigated_trop_corn', itime_in_file, sumarea, filter, &
+ 'Crop production (irrigated_trop_corn)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 77)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to sugarcane production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_rainfed_trop_soybean, &
+ vecacc, file_hist, 'f_cropprodc_rainfed_trop_soybean', &
+ itime_in_file, sumarea, filter, &
+ 'Crop production (rainfed trop soybean)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 78)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to sugarcane production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_irrigated_trop_soybean, &
+ vecacc, file_hist, 'f_cropprodc_irrigated_trop_soybean', &
+ itime_in_file, sumarea, filter, &
+ 'Crop production (irrigated trop soybean)','gC/m2/s')
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ DO i=1,numpatch
+ IF(patchclass(i) == 12)THEN
+ IF(pftclass(patch_pft_s(i)) .eq. 15)THEN
+ filter(i) = .true.
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ELSE
+ filter(i) = .false.
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! grain to unmanaged crop production carbon
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ vecacc (:) = a_grainc_to_cropprodc (:)
+ ENDIF
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%cropprodc_unmanagedcrop, &
+ vecacc, file_hist, 'f_cropprodc_unmanagedcrop', itime_in_file, sumarea, filter, &
+ 'Crop production (unmanaged crop production)','gC/m2/s')
+#endif
+#endif
+ ! --------------------------------------------------------------------
+ ! Temperature and water (excluding land water bodies and ocean patches)
+ ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3;
+ ! land water bodies => 4; ocean => 99]
+ ! --------------------------------------------------------------------
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ filter(:) = patchtype <= 3
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+
+ filter = filter .and. patchmask
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! soil temperature [K]
+ CALL write_history_variable_3d ( DEF_hist_vars%t_soisno, &
+ a_t_soisno, file_hist, 'f_t_soisno', &
+ itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, &
+ sumarea, filter, 'soil temperature','K')
+
+ ! liquid water in soil layers [kg/m2]
+ CALL write_history_variable_3d ( DEF_hist_vars%wliq_soisno, &
+ a_wliq_soisno, file_hist, 'f_wliq_soisno', &
+ itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, &
+ sumarea, filter,'liquid water in soil layers','kg/m2')
+
+ ! ice lens in soil layers [kg/m2]
+ CALL write_history_variable_3d ( DEF_hist_vars%wice_soisno, &
+ a_wice_soisno, file_hist, 'f_wice_soisno', &
+ itime_in_file, 'soilsnow', maxsnl+1, nl_soil-maxsnl, &
+ sumarea, filter, 'ice lens in soil layers', 'kg/m2')
+
+
+#ifdef DataAssimilation
+ IF (p_is_compute) THEN
+ allocate (a_wliq_h2osoi_5cm (numpatch )); a_wliq_h2osoi_5cm = spval
+ allocate (a_t_soisno_5cm (numpatch )); a_t_soisno_5cm = spval
+
+ allocate (a_wliq_soisno_ens_mean(maxsnl+1:nl_soil,numpatch)); a_wliq_soisno_ens_mean = spval
+ allocate (a_wliq_soisno_5cm_ens (DEF_DA_ENS_NUM,numpatch )); a_wliq_soisno_5cm_ens = spval
+ allocate (a_wliq_h2osoi_5cm_a (numpatch )); a_wliq_h2osoi_5cm_a = spval
+
+ allocate (a_t_soisno_ens_mean (maxsnl+1:nl_soil,numpatch)); a_t_soisno_ens_mean = spval
+ allocate (a_t_soisno_5cm_ens (DEF_DA_ENS_NUM,numpatch )); a_t_soisno_5cm_ens = spval
+ allocate (a_t_soisno_5cm_a (numpatch )); a_t_soisno_5cm_a = spval
+
+ allocate (a_t_brt_smap_a (2,numpatch )); a_t_brt_smap_a = spval
+ allocate (a_t_brt_fy3d_a (2,numpatch )); a_t_brt_fy3d_a = spval
+
+ allocate (a_wliq_soisno_5cm_ens_std(numpatch )); a_wliq_soisno_5cm_ens_std = spval
+ allocate (a_t_soisno_5cm_ens_std (numpatch )); a_t_soisno_5cm_ens_std = spval
+ allocate (a_t_brt_smap_ens_std (2,numpatch )); a_t_brt_smap_ens_std = spval
+ allocate (a_t_brt_fy3d_ens_std (2,numpatch )); a_t_brt_fy3d_ens_std = spval
+ END IF
+
+ IF (p_is_compute) THEN
+!#############################################################################
+! States before DA
+!#############################################################################
+ ! calculate surface liquid soil moisture (0-5cm) before DA
+ a_wliq_h2osoi_5cm = (a_wliq_soisno(1,:) + a_wliq_soisno(2,:) + &
+ a_wliq_soisno(3, :)*(0.05 - 0.0451)/(0.0906 - 0.0451))/(0.05*denh2o)
+
+ ! calculate surface liquid soil moisture (0-5cm) before DA
+ a_t_soisno_5cm = (a_t_soisno(1,:)*0.0175 + a_t_soisno(2,:)*(0.0451 - 0.0175))/(0.0451)
+
+!#############################################################################
+! States after DA
+!#############################################################################
+ ! calculate surface liquid soil moisture (0-5cm) after DA
+ a_wliq_soisno_ens_mean = sum(a_wliq_soisno_ens, dim=2) / DEF_DA_ENS_NUM
+ a_wliq_soisno_5cm_ens = (a_wliq_soisno_ens(1,:,:) + a_wliq_soisno_ens(2,:,:) + &
+ a_wliq_soisno_ens(3,:,:)*(0.05-0.0451)/(0.0906-0.0451))/(0.05*denh2o)
+ a_wliq_h2osoi_5cm_a = (a_wliq_soisno_ens_mean(1,:) + a_wliq_soisno_ens_mean(2,:) + &
+ a_wliq_soisno_ens_mean(3,:)*(0.05 - 0.0451)/(0.0906 - 0.0451))/(0.05*denh2o)
+
+ ! calculate surface soil temperature (0-5cm) before DA & after DA
+ a_t_soisno_ens_mean = sum(a_t_soisno_ens, dim=2) / DEF_DA_ENS_NUM
+ a_t_soisno_5cm_ens = (a_t_soisno_ens(1,:,:)*0.0175 + a_t_soisno_ens(2,:,:)*(0.0451 - 0.0175))/(0.0451)
+ a_t_soisno_5cm_a = (a_t_soisno_ens_mean(1,:)*0.0175 + a_t_soisno_ens_mean(2,:)*(0.0451 - 0.0175))/(0.0451)
+
+!#############################################################################
+! brightness temperature after DA
+!#############################################################################
+ a_t_brt_smap_a = sum(a_t_brt_smap_ens, dim=2) / DEF_DA_ENS_NUM
+ a_t_brt_fy3d_a = sum(a_t_brt_fy3d_ens, dim=2) / DEF_DA_ENS_NUM
+
+!#############################################################################
+! Standard deviation of states and brightness temperature
+!#############################################################################
+ ! calculate standard deviation of surface soil moisture, temperature and brightness temperature
+ DO np = 1, numpatch
+ a_wliq_soisno_5cm_ens_std(np) = &
+ sqrt(sum((a_wliq_soisno_5cm_ens(:,np)-a_wliq_h2osoi_5cm_a(np))**2)/real(DEF_DA_ENS_NUM-1))
+ a_t_soisno_5cm_ens_std(np) = &
+ sqrt(sum((a_t_soisno_5cm_ens(:,np)-a_t_soisno_5cm_a(np))**2)/real(DEF_DA_ENS_NUM-1))
+ IF (DEF_DA_SM_SMAP) THEN
+ IF (patchtype(np) >= 3) cycle
+ a_t_brt_smap_ens_std(1,np) = &
+ sqrt(sum((a_t_brt_smap_ens(1,:,np)-a_t_brt_smap_a(1,np))**2)/real(DEF_DA_ENS_NUM-1))
+ a_t_brt_smap_ens_std(2,np) = &
+ sqrt(sum((a_t_brt_smap_ens(2,:,np)-a_t_brt_smap_a(2,np))**2)/real(DEF_DA_ENS_NUM-1))
+ ENDIF
+ IF (DEF_DA_SM_FY) THEN
+ IF (patchtype(np) >= 3) cycle
+ a_t_brt_fy3d_ens_std(1,np) = &
+ sqrt(sum((a_t_brt_fy3d_ens(1,:,np)-a_t_brt_fy3d_a(1,np))**2)/real(DEF_DA_ENS_NUM-1))
+ a_t_brt_fy3d_ens_std(2,np) = &
+ sqrt(sum((a_t_brt_fy3d_ens(2,:,np)-a_t_brt_fy3d_a(2,np))**2)/real(DEF_DA_ENS_NUM-1))
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ! surface soil moisture (0-5cm) before and after DA
+ CALL write_history_variable_2d(DEF_hist_vars%DA_wliq_h2osoi_5cm, &
+ a_wliq_h2osoi_5cm, file_hist, 'f_wliq_h2osoi_5cm', itime_in_file, &
+ sumarea, filter, 'Volumetric liquid water content in 0-5cm', 'm3/m3')
+ CALL write_history_variable_2d(DEF_hist_vars%DA_wliq_h2osoi_5cm_a, &
+ a_wliq_h2osoi_5cm_a, file_hist, 'f_wliq_h2osoi_5cm_a', itime_in_file, &
+ sumarea, filter, 'Analysis volumetric liquid water content in 0-5cm', 'm3/m3')
+
+ ! surface soil temperature (0-5cm) before and after DA
+ CALL write_history_variable_2d(DEF_hist_vars%DA_t_soisno_5cm, &
+ a_t_soisno_5cm, file_hist, 'f_t_soisno_5cm', itime_in_file, &
+ sumarea, filter, 'Soil temperature in 0-5cm', 'K')
+ CALL write_history_variable_2d(DEF_hist_vars%DA_t_soisno_5cm_a, &
+ a_t_soisno_5cm_a, file_hist, 'f_t_soisno_5cm_a', itime_in_file, &
+ sumarea, filter, 'Analysis soil temperature in 0-5cm', 'K')
+
+ ! ensemble soil moisture & temperature in soil layers [kg/m2]
+ IF (DEF_DA_ENS_NUM > 1) THEN
+ CALL write_history_variable_4d(DEF_hist_vars%DA_wliq_soisno_ens, &
+ a_wliq_soisno_ens, file_hist, 'f_wliq_soisno_ens', itime_in_file, 'soilsnow', maxsnl + 1, nl_soil - maxsnl, &
+ 'ens', 1, DEF_DA_ENS_NUM, sumarea, filter, 'ensemble liquid water in soil layers', 'kg/m2')
+ CALL write_history_variable_4d(DEF_hist_vars%DA_t_soisno_ens, &
+ a_t_soisno_ens, file_hist, 'f_t_soisno_ens', itime_in_file, 'soilsnow', maxsnl + 1, nl_soil - maxsnl, &
+ 'ens', 1, DEF_DA_ENS_NUM, sumarea, filter, 'ensemble soil temperature', 'K')
+ ENDIF
+
+ ! standard deviation of ensemble surface soil moisture and temperature (0-5cm)
+ CALL write_history_variable_2d(DEF_hist_vars%DA_wliq_soisno_5cm_ens_std, &
+ a_wliq_soisno_5cm_ens_std, file_hist, 'f_wliq_soisno_ens_5cm_ens_std', itime_in_file, &
+ sumarea, filter, 'Standard deviation of ensemble volumetric liquid water content in 0-5cm', 'm3/m3')
+ CALL write_history_variable_2d(DEF_hist_vars%DA_t_soisno_5cm_ens_std, &
+ a_t_soisno_5cm_ens_std, file_hist, 'f_t_soisno_ens_5cm_ens_std', itime_in_file, &
+ sumarea, filter, 'Standard deviation of ensemble soil temperature in 0-5cm', 'K')
+
+ ! --------------------------------------------------------------------
+ ! brightness temperature (excluding land ice, land water bodies and ocean patches)
+ ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3;
+ ! land water bodies => 4; ocean => 99]
+ ! --------------------------------------------------------------------
+
+ IF (HistForm == 'Gridded') THEN
+ IF (p_is_active) THEN
+ CALL allocate_block_data(ghist, sumarea)
+ END IF
+ END IF
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ filter(:) = patchtype <= 2
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ END IF
+
+ filter = filter .and. patchmask
+ END IF
+ END IF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea(sumarea, filter)
+ END IF
+
+ ! brightness temperature for SMAP and FY satellites
+ IF (DEF_DA_SM_SMAP) THEN
+ CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_smap, &
+ a_t_brt_smap, file_hist, 'f_t_brt_smap', itime_in_file, 'band', 1, 2, sumarea, filter, &
+ 'H- & V- polarized brightness temperature for SMAP satellite (L-band, 1.4GHz)', 'K')
+ CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_smap_a, &
+ a_t_brt_smap_a, file_hist, 'f_t_brt_smap_a', itime_in_file, 'band', 1, 2, sumarea, filter, &
+ 'Analysis H- & V- polarized brightness temperature for SMAP satellite (L-band,1.4GHz)', 'K')
+ IF (DEF_DA_ENS_NUM > 1) THEN
+ CALL write_history_variable_4d(DEF_hist_vars%DA_t_brt_smap_ens, &
+ a_t_brt_smap_ens, file_hist, 'f_t_brt_smap_ens', itime_in_file, 'band', 1, 2, 'ens', 1, DEF_DA_ENS_NUM, &
+ sumarea, filter, 'ensemble H- & V- polarized brightness temperature for SMAP satellite (L-band,1.4GHz)', 'K')
+ END IF
+ CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_smap_ens_std, &
+ a_t_brt_smap_ens_std, file_hist, 'f_t_brt_smap_ens_std', itime_in_file, 'band', 1, 2, &
+ sumarea, filter, 'Standard deviation of H- & V- polarized brightness temperature for SMAP satellite (L-band,1.4GHz)', 'K')
+ ENDIF
+
+ IF (DEF_DA_SM_FY) THEN
+ CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_fy3d, &
+ a_t_brt_fy3d, file_hist, 'f_t_brt_fy3d', itime_in_file, 'band', 1, 2, sumarea, filter, &
+ 'H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K')
+ CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_fy3d_a, &
+ a_t_brt_fy3d_a, file_hist, 'f_t_brt_fy3d_a', itime_in_file, 'band', 1, 2, sumarea, filter, &
+ 'Analysis H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K')
+ IF (DEF_DA_ENS_NUM > 1) THEN
+ CALL write_history_variable_4d(DEF_hist_vars%DA_t_brt_fy3d_ens, &
+ a_t_brt_fy3d_ens, file_hist, 'f_t_brt_fy3d_ens', itime_in_file, 'band', 1, 2, 'ens', 1, DEF_DA_ENS_NUM, &
+ sumarea, filter, 'ensemble H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K')
+ END IF
+ CALL write_history_variable_3d(DEF_hist_vars%DA_t_brt_fy3d_ens_std, &
+ a_t_brt_fy3d_ens_std, file_hist, 'f_t_brt_fy3d_ens_std', itime_in_file, 'band', 1, 2, &
+ sumarea, filter, 'Standard deviation of H- & V- polarized brightness temperature for FY satellite (X-band, 10.65GHz)', 'K')
+ ENDIF
+
+ IF (p_is_compute) THEN
+ deallocate (a_wliq_h2osoi_5cm)
+ deallocate (a_t_soisno_5cm)
+ deallocate (a_wliq_soisno_ens_mean)
+ deallocate (a_wliq_soisno_5cm_ens)
+ deallocate (a_wliq_h2osoi_5cm_a)
+ deallocate (a_t_soisno_ens_mean)
+ deallocate (a_t_soisno_5cm_ens)
+ deallocate (a_t_soisno_5cm_a)
+ deallocate (a_t_brt_smap_a)
+ deallocate (a_t_brt_fy3d_a)
+ deallocate (a_wliq_soisno_5cm_ens_std)
+ deallocate (a_t_soisno_5cm_ens_std)
+ deallocate (a_t_brt_smap_ens_std)
+ deallocate (a_t_brt_fy3d_ens_std)
+ END IF
+
+#endif
+
+ ! --------------------------------------------------------------------
+ ! additional diagnostic variables for output (vegetated land only <=2)
+ ! [soil => 0; urban and built-up => 1; wetland => 2; land ice => 3;
+ ! land water bodies => 4; ocean => 99]
+ ! --------------------------------------------------------------------
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ filter(:) = patchtype <= 2
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+
+ filter = filter .and. patchmask
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! volumetric soil water in layers [m3/m3]
+ CALL write_history_variable_3d ( DEF_hist_vars%h2osoi, &
+ a_h2osoi, file_hist, 'f_h2osoi', itime_in_file, 'soil', 1, nl_soil, sumarea, filter, &
+ 'volumetric water in soil layers','m3/m3')
+
+ IF (DEF_USE_VariablySaturatedFlow) THEN
+ ! water flux between water layers [mm h2o/s]
+ CALL write_history_variable_3d ( DEF_hist_vars%qlayer, &
+ a_qlayer, file_hist, 'f_qlayer', itime_in_file, 'soilinterface', 0, nl_soil+1, &
+ sumarea, filter, 'water flux between soil layers','mm/s')
+ ENDIF
+
+ ! fraction of root water uptake from each soil layer, all layers add to 1,
+ ! when PHS is not defined water exchange between soil layers and root.
+ ! Positive: soil->root [mm h2o/s], when PHS is defined
+ CALL write_history_variable_3d ( DEF_hist_vars%rootr, &
+ a_rootr, file_hist, 'f_rootr', itime_in_file, 'soil', 1, nl_soil, sumarea, filter, &
+ 'root water uptake', 'mm h2o/s')
+
+ IF (DEF_USE_PLANTHYDRAULICS) THEN
+ ! vegetation water potential [mm]
+ CALL write_history_variable_3d ( DEF_hist_vars%vegwp, &
+ a_vegwp, file_hist, 'f_vegwp', &
+ itime_in_file, 'vegnodes', 1, nvegwcs, sumarea, filter, &
+ 'vegetation water potential', 'mm')
+ ENDIF
+
+ ! water table depth [m]
+ CALL write_history_variable_2d ( DEF_hist_vars%zwt, &
+ a_zwt, file_hist, 'f_zwt', itime_in_file, sumarea, filter, &
+ 'the depth to water table','m')
+
+ ! --------------------------------------------------------------------
+ ! depth of surface water (including land ice and ocean patches)
+ ! --------------------------------------------------------------------
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ filter(:) = (patchtype <= 4)
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+
+ filter = filter .and. patchmask
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! water storage in aquifer [mm]
+ CALL write_history_variable_2d ( DEF_hist_vars%wa, &
+ a_wa, file_hist, 'f_wa', itime_in_file, sumarea, filter, &
+ 'water storage in aquifer','mm')
+
+ ! instantaneous water storage in aquifer [mm]
+ IF (p_is_compute) THEN
+ vecacc = wa
+ WHERE(vecacc /= spval) vecacc = vecacc * nac
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%wa_inst, &
+ vecacc, file_hist, 'f_wa_inst', itime_in_file, sumarea, filter, &
+ 'instantaneous water storage in aquifer','mm')
+
+ ! depth of surface water [mm]
+ CALL write_history_variable_2d ( DEF_hist_vars%wdsrf, &
+ a_wdsrf, file_hist, 'f_wdsrf', itime_in_file, sumarea, filter, &
+ 'depth of surface water','mm')
+
+ ! instantaneous depth of surface water [mm]
+ IF (p_is_compute) THEN
+ vecacc = wdsrf
+ WHERE(vecacc /= spval) vecacc = vecacc * nac
+ ENDIF
+ CALL write_history_variable_2d ( DEF_hist_vars%wdsrf_inst, &
+ vecacc, file_hist, 'f_wdsrf_inst', itime_in_file, sumarea, filter, &
+ 'instantaneous depth of surface water','mm')
+
+ ! -----------------------------------------------
+ ! Land water bodies' ice fraction and temperature
+ ! -----------------------------------------------
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ filter(:) = patchtype == 4
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ IF (trim(file_hist) /= trim(file_last)) THEN
+ CALL hist_write_var_real8_2d (file_hist, 'area_lake', ghist, -1, sumarea, &
+ compress = 1, longname = 'area of lake', units = 'km2')
+ ENDIF
+ ENDIF
+
+ ! lake layer depth [m]
+ CALL write_history_variable_3d ( DEF_hist_vars%dz_lake .and. DEF_USE_Dynamic_Lake, &
+ a_dz_lake, file_hist, 'f_dz_lake', itime_in_file, 'lake', 1, nl_lake, sumarea, filter, &
+ 'lake layer thickness','m')
+
+ ! lake temperature [K]
+ CALL write_history_variable_3d ( DEF_hist_vars%t_lake, &
+ a_t_lake, file_hist, 'f_t_lake', itime_in_file, 'lake', 1, nl_lake, sumarea, filter, &
+ 'lake temperature','K')
+
+ ! lake ice fraction cover [0-1]
+ CALL write_history_variable_3d ( DEF_hist_vars%lake_icefrac, &
+ a_lake_icefrac, file_hist, 'f_lake_icefrac', itime_in_file, 'lake', 1, nl_lake, &
+ sumarea, filter, 'lake ice fraction cover','0-1')
+
+ ! lake water deficit due to evaporation [mm/s]
+ IF (.not. DEF_USE_Dynamic_Lake) THEN
+ CALL write_history_variable_2d ( DEF_hist_vars%lake_deficit, &
+ a_lake_deficit, file_hist, 'f_lake_deficit', itime_in_file, sumarea, filter, &
+ 'lake water deficit due to evaporation','mm/s')
+ ENDIF
+
+#ifdef EXTERNAL_LAKE
+ CALL LakeVarsSaveHist (nl_lake, file_hist, HistForm, itime_in_file, sumarea, filter)
+#endif
+
+ ! --------------------------------
+ ! Retrieve through averaged fluxes
+ ! --------------------------------
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ filter(:) = patchtype < 99
+
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+
+ filter = filter .and. patchmask
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! u* in similarity theory [m/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%ustar, &
+ a_ustar, file_hist, 'f_ustar', itime_in_file, sumarea, filter, &
+ 'u* in similarity theory based on patch','m/s')
+
+ ! u* in similarity theory [m/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%ustar2, &
+ a_ustar2, file_hist, 'f_ustar2', itime_in_file, sumarea, filter, &
+ 'u* in similarity theory based on grid','m/s')
+
+ ! t* in similarity theory [K]
+ CALL write_history_variable_2d ( DEF_hist_vars%tstar, &
+ a_tstar, file_hist, 'f_tstar', itime_in_file, sumarea, filter, &
+ 't* in similarity theory','K')
+
+ ! q* in similarity theory [kg/kg]
+ CALL write_history_variable_2d ( DEF_hist_vars%qstar, &
+ a_qstar, file_hist, 'f_qstar', itime_in_file, sumarea, filter, &
+ 'q* in similarity theory', 'kg/kg')
+
+ ! dimensionless height (z/L) used in Monin-Obukhov theory
+ CALL write_history_variable_2d ( DEF_hist_vars%zol, &
+ a_zol, file_hist, 'f_zol', itime_in_file, sumarea, filter, &
+ 'dimensionless height (z/L) used in Monin-Obukhov theory','-')
+
+ ! bulk Richardson number in surface layer
+ CALL write_history_variable_2d ( DEF_hist_vars%rib, &
+ a_rib, file_hist, 'f_rib', itime_in_file, sumarea, filter, &
+ 'bulk Richardson number in surface layer','-')
+
+ ! integral of profile FUNCTION for momentum
+ CALL write_history_variable_2d ( DEF_hist_vars%fm, &
+ a_fm, file_hist, 'f_fm', itime_in_file, sumarea, filter, &
+ 'integral of profile FUNCTION for momentum','-')
+
+ ! integral of profile FUNCTION for heat
+ CALL write_history_variable_2d ( DEF_hist_vars%fh, &
+ a_fh, file_hist, 'f_fh', itime_in_file, sumarea, filter, &
+ 'integral of profile FUNCTION for heat','-')
+
+ ! integral of profile FUNCTION for moisture
+ CALL write_history_variable_2d ( DEF_hist_vars%fq, &
+ a_fq, file_hist, 'f_fq', itime_in_file, sumarea, filter, &
+ 'integral of profile FUNCTION for moisture','-')
+
+ ! 10m u-velocity [m/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%us10m, &
+ a_us10m, file_hist, 'f_us10m', itime_in_file, sumarea, filter, &
+ '10m u-velocity','m/s')
+
+ ! 10m v-velocity [m/s]
+ CALL write_history_variable_2d ( DEF_hist_vars%vs10m, &
+ a_vs10m, file_hist, 'f_vs10m', itime_in_file, sumarea, filter, &
+ '10m v-velocity','m/s')
+
+ ! integral of profile FUNCTION for momentum at 10m [-]
+ CALL write_history_variable_2d ( DEF_hist_vars%fm10m, &
+ a_fm10m, file_hist, 'f_fm10m', itime_in_file, sumarea, filter, &
+ 'integral of profile FUNCTION for momentum at 10m','-')
+
+ ! total reflected solar radiation (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%sr, &
+ a_sr, file_hist, 'f_sr', itime_in_file, sumarea, filter, &
+ 'reflected solar radiation at surface [W/m2]','W/m2')
+
+ ! incident direct beam vis solar radiation (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%solvd, &
+ a_solvd, file_hist, 'f_solvd', itime_in_file, sumarea, filter, &
+ 'incident direct beam vis solar radiation (W/m2)','W/m2')
+
+ ! incident diffuse beam vis solar radiation (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%solvi, &
+ a_solvi, file_hist, 'f_solvi', itime_in_file, sumarea, filter, &
+ 'incident diffuse beam vis solar radiation (W/m2)','W/m2')
+
+ ! incident direct beam nir solar radiation (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%solnd, &
+ a_solnd, file_hist, 'f_solnd', itime_in_file, sumarea, filter, &
+ 'incident direct beam nir solar radiation (W/m2)','W/m2')
+
+ ! incident diffuse beam nir solar radiation (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%solni, &
+ a_solni, file_hist, 'f_solni', itime_in_file, sumarea, filter, &
+ 'incident diffuse beam nir solar radiation (W/m2)','W/m2')
+
+ ! reflected direct beam vis solar radiation (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%srvd, &
+ a_srvd, file_hist, 'f_srvd', itime_in_file, sumarea, filter, &
+ 'reflected direct beam vis solar radiation (W/m2)','W/m2')
+
+ ! reflected diffuse beam vis solar radiation (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%srvi, &
+ a_srvi, file_hist, 'f_srvi', itime_in_file, sumarea, filter, &
+ 'reflected diffuse beam vis solar radiation (W/m2)','W/m2')
+
+ ! reflected direct beam nir solar radiation (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%srnd, &
+ a_srnd, file_hist, 'f_srnd', itime_in_file, sumarea, filter, &
+ 'reflected direct beam nir solar radiation (W/m2)','W/m2')
+
+ ! reflected diffuse beam nir solar radiation (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%srni, &
+ a_srni, file_hist, 'f_srni', itime_in_file, sumarea, filter, &
+ 'reflected diffuse beam nir solar radiation (W/m2)','W/m2')
+
+ ! local noon fluxes
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ filter(:) = nac_ln > 0
+ IF (DEF_forcing%has_missing_value) THEN
+ filter = filter .and. forcmask_pch
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ ! incident direct beam vis solar radiation at local noon (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%solvdln, &
+ a_solvdln, file_hist, 'f_solvdln', itime_in_file, sumarea, filter, &
+ 'incident direct beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln)
+
+ ! incident diffuse beam vis solar radiation at local noon (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%solviln, &
+ a_solviln, file_hist, 'f_solviln', itime_in_file, sumarea, filter, &
+ 'incident diffuse beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln)
+
+ ! incident direct beam nir solar radiation at local noon (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%solndln, &
+ a_solndln, file_hist, 'f_solndln', itime_in_file, sumarea, filter, &
+ 'incident direct beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln)
+
+ ! incident diffuse beam nir solar radiation at local noon (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%solniln, &
+ a_solniln, file_hist, 'f_solniln', itime_in_file, sumarea, filter, &
+ 'incident diffuse beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln)
+
+ ! reflected direct beam vis solar radiation at local noon (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%srvdln, &
+ a_srvdln, file_hist, 'f_srvdln', itime_in_file, sumarea, filter, &
+ 'reflected direct beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln)
+
+ ! reflected diffuse beam vis solar radiation at local noon (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%srviln, &
+ a_srviln, file_hist, 'f_srviln', itime_in_file, sumarea, filter, &
+ 'reflected diffuse beam vis solar radiation at local noon(W/m2)','W/m2',nac_ln)
+
+ ! reflected direct beam nir solar radiation at local noon (W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%srndln, &
+ a_srndln, file_hist, 'f_srndln', itime_in_file, sumarea, filter, &
+ 'reflected direct beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln)
+
+ ! reflected diffuse beam nir solar radiation at local noon(W/m2)
+ CALL write_history_variable_2d ( DEF_hist_vars%srniln, &
+ a_srniln, file_hist, 'f_srniln', itime_in_file, sumarea, filter, &
+ 'reflected diffuse beam nir solar radiation at local noon(W/m2)','W/m2',nac_ln)
+
+
+ IF ((p_is_compute) .and. (numpatch > 0)) THEN
+ filter = (patchtype == 0) .and. patchmask
+ IF (DEF_forcing%has_missing_value) filter = filter .and. forcmask_pch
+ ENDIF
+ IF (HistForm == 'Gridded') THEN
+ CALL mp2g_hist%get_sumarea (sumarea, filter)
+ ENDIF
+
+ CALL write_history_variable_3d ( DEF_hist_vars%sensors, &
+ a_sensors, file_hist, 'f_sensors', itime_in_file, 'sensor', 1, nsensor, &
+ sumarea, filter, 'variable sensors','user defined')
+
+#ifdef CatchLateralFlow
+ CALL hist_basin_out (file_hist, idate)
+#endif
+
+#ifdef GridRiverLakeFlow
+ CALL hist_grid_riverlake_out (file_hist, HistForm, idate, &
+ itime_in_file, trim(file_hist)/=trim(file_last))
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ allocate (nac_one (numpatch))
+ nac_one = 1.
+ ENDIF
+ ENDIF
+
+ IF (HistForm == 'Gridded') THEN
+ IF (p_is_active) CALL allocate_block_data (ghist, sumarea_one)
+ IF (p_is_active) CALL flush_block_data (sumarea_one, 1.)
+ ENDIF
+
+ CALL write_history_variable_2d ( DEF_hist_vars%riv_height, a_wdsrf_ucat_pch, &
+ file_hist, 'f_wdpth_ucat_regrid', itime_in_file, sumarea_ucat, filter_ucat, &
+ 'regridded deepest water depth in river and flood plain', 'm', nac_one)
+
+ CALL write_history_variable_2d ( DEF_hist_vars%riv_veloct, a_veloc_riv_pch, &
+ file_hist, 'f_veloc_riv_regrid', itime_in_file, sumarea_ucat, filter_ucat, &
+ 'regridded water velocity in river', 'm/s', nac_one)
+
+ CALL write_history_variable_2d ( DEF_hist_vars%discharge, a_discharge_pch, &
+ file_hist, 'f_discharge', itime_in_file, sumarea_one, filter_ucat, &
+ 'regridded discharge in river and flood plain', 'm^3/s', &
+ nac_one, input_mode = 'total')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%discharge, a_dis_rmth_pch, &
+ file_hist, 'f_discharge_rivermouth_regrid', itime_in_file, sumarea_one, &
+ filter_ucat, 'regridded river mouth discharge into ocean', 'm^3/s', &
+ nac_one, input_mode = 'total')
+
+ CALL write_history_variable_2d ( DEF_hist_vars%floodfrc, a_floodfrc_pch, &
+ file_hist, 'f_floodfrc', itime_in_file, sumarea_inpm, filter_inpm, &
+ 'flooded area fraction', '100%', nac_one)
+
+ IF (trim(HistForm) == 'Gridded') THEN
+ CALL write_history_variable_2d ( DEF_hist_vars%floodarea, a_floodfrc_pch, &
+ file_hist, 'f_floodarea', itime_in_file, sumarea_one, filter_inpm, &
+ 'flooded area', 'km^2', nac_one)
+ ENDIF
+
+ IF (allocated(nac_one )) deallocate (nac_one )
+#endif
+
+ IF (allocated(filter )) deallocate (filter )
+ IF (allocated(filter_dt )) deallocate (filter_dt )
+#ifdef URBAN_MODEL
+ IF (allocated(filter_urb)) deallocate (filter_urb)
+#endif
+
+ CALL FLUSH_acc_fluxes ()
+
+#ifdef SinglePoint
+ IF (USE_SITE_HistWriteBack .and. memory_to_disk) THEN
+ itime_mem = 0
+ ENDIF
+#endif
+
+ file_last = file_hist
+
+ ENDIF
+
+ END SUBROUTINE hist_out
+
+
+ SUBROUTINE write_history_variable_2d ( is_hist, &
+ acc_vec, file_hist, varname, itime_in_file, sumarea, filter, &
+ longname, units, acc_num, input_mode)
+
+ USE MOD_Vars_1DAccFluxes, only: nac
+
+ IMPLICIT NONE
+
+ logical, intent(in) :: is_hist
+
+ real(r8), intent(inout) :: acc_vec(:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ type(block_data_real8_2d), intent(in) :: sumarea
+ logical, intent(in) :: filter(:)
+ real(r8), intent(in), optional :: acc_num(:)
+
+ character(len=*), intent(in), optional :: input_mode
+
+ IF (.not. is_hist) RETURN
+
+#ifndef SinglePoint
+ IF ( .not. present(acc_num) ) THEN
+ IF (p_is_compute) &
+ WHERE (acc_vec /= spval) acc_vec = acc_vec / nac
+ ELSE
+ IF (p_is_compute) &
+ WHERE (acc_vec/=spval .and. acc_num>0) acc_vec = acc_vec / acc_num
+ ENDIF
+#else
+ IF ( .not. present(acc_num) ) THEN
+ WHERE (acc_vec /= spval) acc_vec = acc_vec / nac
+ ELSE
+ WHERE (acc_vec/=spval .and. acc_num>0) acc_vec = acc_vec / acc_num
+ ENDIF
+#endif
+
+ select CASE (HistForm)
+ CASE ('Gridded')
+ IF (present(input_mode)) THEN
+ CALL flux_map_and_write_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units, input_mode)
+ ELSE
+ CALL flux_map_and_write_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units)
+ ENDIF
+#if (defined UNSTRUCTURED || defined CATCHMENT)
+ CASE ('Vector')
+ IF (present(input_mode)) THEN
+ CALL aggregate_to_vector_and_write_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, filter, longname, units, input_mode)
+ ELSE
+ CALL aggregate_to_vector_and_write_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, filter, longname, units)
+ ENDIF
+#endif
+#ifdef SinglePoint
+ CASE ('Single')
+ CALL single_write_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, longname, units)
+#endif
+ END select
+
+ END SUBROUTINE write_history_variable_2d
+
+
+#ifdef URBAN_MODEL
+ SUBROUTINE write_history_variable_urb_2d ( is_hist, &
+ acc_vec, file_hist, varname, itime_in_file, sumarea, filter, &
+ longname, units)
+
+ IMPLICIT NONE
+
+ logical, intent(in) :: is_hist
+
+ real(r8), intent(inout) :: acc_vec(:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ type(block_data_real8_2d), intent(in) :: sumarea
+ logical, intent(in) :: filter(:)
+
+ IF (.not. is_hist) RETURN
+
+ select CASE (HistForm)
+ CASE ('Gridded')
+ CALL flux_map_and_write_urb_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, sumarea, filter, longname, units)
+#if (defined UNSTRUCTURED || defined CATCHMENT)
+ CASE ('Vector')
+ !TODO: currently, it is not applicable to urban variables
+ CALL aggregate_to_vector_and_write_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, filter, longname, units)
+#endif
+#ifdef SinglePoint
+ CASE ('Single')
+ CALL single_write_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, longname, units)
+#endif
+ END select
+
+ END SUBROUTINE write_history_variable_urb_2d
+#endif
+
+
+ SUBROUTINE write_history_variable_3d ( is_hist, &
+ acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, &
+ sumarea, filter, longname, units)
+
+ IMPLICIT NONE
+
+ logical, intent(in) :: is_hist
+
+ real(r8), intent(inout) :: acc_vec(:,:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: dim1name
+ integer, intent(in) :: lb1, ndim1
+
+ type(block_data_real8_2d), intent(in) :: sumarea
+ logical, intent(in) :: filter(:)
+ character (len=*), intent(in) :: longname
+ character (len=*), intent(in) :: units
+
+ ! Local variables
+ integer :: iblkme, xblk, yblk, xloc, yloc, i1
+ integer :: compress
+
+ IF (.not. is_hist) RETURN
+
+ select CASE (HistForm)
+ CASE ('Gridded')
+ CALL flux_map_and_write_3d ( &
+ acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, &
+ sumarea, filter, longname, units)
+#if (defined UNSTRUCTURED || defined CATCHMENT)
+ CASE ('Vector')
+ CALL aggregate_to_vector_and_write_3d ( &
+ acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, &
+ filter, longname, units)
+#endif
+#ifdef SinglePoint
+ CASE ('Single')
+ CALL single_write_3d (acc_vec, file_hist, varname, itime_in_file, &
+ dim1name, ndim1, longname, units)
+#endif
+ END select
+
+ END SUBROUTINE write_history_variable_3d
+
+
+ SUBROUTINE write_history_variable_4d ( is_hist, &
+ acc_vec, file_hist, varname, itime_in_file, &
+ dim1name, lb1, ndim1, dim2name, lb2, ndim2, &
+ sumarea, filter, longname, units, acc_num)
+
+ IMPLICIT NONE
+
+ logical, intent(in) :: is_hist
+
+ real(r8), intent(inout) :: acc_vec(:,:,:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: dim1name, dim2name
+ integer, intent(in) :: lb1, ndim1, lb2, ndim2
+
+ type(block_data_real8_2d), intent(in) :: sumarea
+ logical, intent(in) :: filter(:)
+ character (len=*), intent(in) :: longname
+ character (len=*), intent(in) :: units
+ real(r8), intent(in), optional:: acc_num(:)
+
+ ! Local variables
+ integer :: i1, i2
+
+ IF (.not. is_hist) RETURN
+
+#ifndef SinglePoint
+ IF ( .not. present(acc_num) ) THEN
+ IF (p_is_compute) &
+ WHERE (acc_vec /= spval) acc_vec = acc_vec / nac
+ ELSE
+ IF (p_is_compute) THEN
+ DO i1 = lbound(acc_vec,1), ubound(acc_vec,1)
+ DO i2 = lbound(acc_vec,2), ubound(acc_vec,2)
+ WHERE (acc_vec(i1,i2,:)/=spval .and. acc_num>0) &
+ acc_vec(i1,i2,:) = acc_vec(i1,i2,:) / acc_num
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+#else
+ IF ( .not. present(acc_num) ) THEN
+ WHERE (acc_vec /= spval) acc_vec = acc_vec / nac
+ ELSE
+ DO i1 = lbound(acc_vec,1), ubound(acc_vec,1)
+ DO i2 = lbound(acc_vec,2), ubound(acc_vec,2)
+ WHERE (acc_vec(i1,i2,:)/=spval .and. acc_num>0) &
+ acc_vec(i1,i2,:) = acc_vec(i1,i2,:) / acc_num
+ ENDDO
+ ENDDO
+ ENDIF
+#endif
+
+ select CASE (HistForm)
+ CASE ('Gridded')
+ CALL flux_map_and_write_4d ( &
+ acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, &
+ dim2name, lb2, ndim2, sumarea, filter, longname, units)
+#if (defined UNSTRUCTURED || defined CATCHMENT)
+ CASE ('Vector')
+ CALL aggregate_to_vector_and_write_4d ( &
+ acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, &
+ dim2name, lb2, ndim2, filter, longname, units)
+#endif
+#ifdef SinglePoint
+ CASE ('Single')
+ CALL single_write_4d (acc_vec, file_hist, varname, itime_in_file, &
+ dim1name, ndim1, dim2name, ndim2, longname, units)
+#endif
+ END select
+
+ END SUBROUTINE write_history_variable_4d
+
+
+ SUBROUTINE hist_write_time (filename, filelast, dataname, time, itime)
+
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: filename
+ character (len=*), intent(in) :: filelast
+ character (len=*), intent(in) :: dataname
+ integer, intent(in) :: time(3)
+ integer, intent(out) :: itime
+
+ select CASE (HistForm)
+ CASE ('Gridded')
+ CALL hist_gridded_write_time (filename, filelast, dataname, time, itime)
+#if (defined UNSTRUCTURED || defined CATCHMENT)
+ CASE ('Vector')
+ CALL hist_vector_write_time (filename, filelast, dataname, time, itime)
+#endif
+#ifdef SinglePoint
+ CASE ('Single')
+ CALL hist_single_write_time (filename, filelast, dataname, time, itime)
+#endif
+ END select
+
+ END SUBROUTINE hist_write_time
+
+END MODULE MOD_Hist
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90
new file mode 100644
index 0000000000..051f429903
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistGridded.F90
@@ -0,0 +1,1079 @@
+#include
+
+MODULE MOD_HistGridded
+
+!----------------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Write out gridded model results to history files.
+!
+! Original version: Yongjiu Dai, September 15, 1999, 03/2014
+!
+! !REVISIONS:
+! Shupeng Zhang, 05/2023: 1) porting codes to MPI parallel version
+!
+! TODO...(need complement)
+!----------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_SpatialMapping
+ USE MOD_Namelist
+ USE MOD_NetCDFSerial
+ USE MOD_SPMD_Task
+#ifdef USEMPI
+ USE MOD_HistWriteBack
+#endif
+
+ type(grid_type), target :: ghist
+ type(spatial_mapping_type) :: mp2g_hist
+ type(spatial_mapping_type) :: mp2g_hist_urb
+
+ type(block_data_real8_2d) :: landfraction
+
+ type(grid_concat_type) :: hist_concat
+
+ integer :: hist_data_id
+
+!--------------------------------------------------------------------------
+CONTAINS
+
+ SUBROUTINE hist_gridded_init (dir_hist, lulcc_call)
+
+ USE MOD_SPMD_Task
+ USE MOD_Vars_Global
+ USE MOD_Block
+ USE MOD_LandPatch
+#ifdef URBAN_MODEL
+ USE MOD_LandUrban
+#endif
+ USE MOD_Vars_1DAccFluxes
+ USE MOD_Forcing, only: gforc
+#ifdef SinglePoint
+ USE MOD_SingleSrfData
+#endif
+ USE MOD_Utils
+ IMPLICIT NONE
+
+ character(len=*) , intent(in) :: dir_hist
+ logical, optional, intent(in) :: lulcc_call
+
+ ! Local Variables
+ type(block_data_real8_2d) :: gridarea
+ integer :: iblkme, xblk, yblk, xloc, yloc, xglb, yglb
+
+ IF (DEF_hist_grid_as_forcing) THEN
+ CALL ghist%define_by_copy (gforc)
+ ELSE
+ CALL ghist%define_by_res (DEF_hist_lon_res, DEF_hist_lat_res)
+ ENDIF
+
+ IF (present(lulcc_call)) CALL mp2g_hist%forc_free_mem
+ CALL mp2g_hist%build_arealweighted (ghist, landpatch)
+
+#ifdef URBAN_MODEL
+ IF (present(lulcc_call)) CALL mp2g_hist_urb%forc_free_mem
+ CALL mp2g_hist_urb%build_arealweighted (ghist, landurban)
+#endif
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (ghist, landfraction)
+ CALL allocate_block_data (ghist, gridarea)
+
+ DO iblkme = 1, gblock%nblkme
+ xblk = gblock%xblkme(iblkme)
+ yblk = gblock%yblkme(iblkme)
+ DO yloc = 1, ghist%ycnt(yblk)
+ DO xloc = 1, ghist%xcnt(xblk)
+ xglb = ghist%xdsp(xblk) + xloc
+ yglb = ghist%ydsp(yblk) + yloc
+ gridarea%blk(xblk,yblk)%val(xloc,yloc) = areaquad ( &
+ ghist%lat_s(yglb), ghist%lat_n(yglb), ghist%lon_w(xglb), ghist%lon_e(xglb))
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+
+ CALL mp2g_hist%get_sumarea (landfraction)
+ CALL block_data_division (landfraction, gridarea)
+
+ CALL hist_concat%set (ghist)
+#ifdef SinglePoint
+ hist_concat%ginfo%lat_c(:) = SITE_lat_location
+ hist_concat%ginfo%lon_c(:) = SITE_lon_location
+#endif
+
+ IF (trim(DEF_HIST_mode) == 'one') THEN
+ hist_data_id = 10001
+ ENDIF
+
+ END SUBROUTINE hist_gridded_init
+
+
+ SUBROUTINE flux_map_and_write_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, sumarea, filter, &
+ longname, units, input_mode)
+
+ USE MOD_Block
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(inout) :: acc_vec(:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ type(block_data_real8_2d), intent(in) :: sumarea
+ logical, intent(in) :: filter(:)
+ character(len=*), intent(in), optional :: input_mode
+
+ ! Local variables
+ type(block_data_real8_2d) :: flux_xy_2d
+ integer :: iblkme, xblk, yblk, xloc, yloc
+ integer :: compress
+
+ IF (p_is_active) CALL allocate_block_data (ghist, flux_xy_2d)
+
+ IF (present(input_mode)) THEN
+ CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter, input_mode = input_mode)
+ ELSE
+ CALL mp2g_hist%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter)
+ ENDIF
+
+ IF (p_is_active) THEN
+ DO iblkme = 1, gblock%nblkme
+ xblk = gblock%xblkme(iblkme)
+ yblk = gblock%yblkme(iblkme)
+
+ DO yloc = 1, ghist%ycnt(yblk)
+ DO xloc = 1, ghist%xcnt(xblk)
+
+ IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN
+ IF (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN
+ flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) &
+ = flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) &
+ / sumarea%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+ ELSE
+ flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDDO
+ ENDIF
+
+ compress = DEF_HIST_CompressLevel
+ CALL hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, &
+ flux_xy_2d, compress, longname, units)
+
+ END SUBROUTINE flux_map_and_write_2d
+
+
+ SUBROUTINE flux_map_and_write_urb_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, sumarea, filter, &
+ longname, units)
+
+ USE MOD_Block
+ USE MOD_Vars_1DAccFluxes, only: nac
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(inout) :: acc_vec(:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ type(block_data_real8_2d), intent(in) :: sumarea
+ logical, intent(in) :: filter(:)
+
+ ! Local variables
+ type(block_data_real8_2d) :: flux_xy_2d
+ integer :: iblkme, xblk, yblk, xloc, yloc
+ integer :: compress
+
+ IF (p_is_compute) WHERE (acc_vec /= spval) acc_vec = acc_vec / nac
+ IF (p_is_active) CALL allocate_block_data (ghist, flux_xy_2d)
+
+ CALL mp2g_hist_urb%pset2grid (acc_vec, flux_xy_2d, spv = spval, msk = filter)
+
+ IF (p_is_active) THEN
+ DO iblkme = 1, gblock%nblkme
+ xblk = gblock%xblkme(iblkme)
+ yblk = gblock%yblkme(iblkme)
+
+ DO yloc = 1, ghist%ycnt(yblk)
+ DO xloc = 1, ghist%xcnt(xblk)
+
+ IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN
+ IF (flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) /= spval) THEN
+ flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) &
+ = flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) &
+ / sumarea%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+ ELSE
+ flux_xy_2d%blk(xblk,yblk)%val(xloc,yloc) = spval
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDDO
+ ENDIF
+
+ compress = DEF_HIST_CompressLevel
+ CALL hist_write_var_real8_2d (file_hist, varname, ghist, itime_in_file, flux_xy_2d, &
+ compress, longname, units)
+
+ END SUBROUTINE flux_map_and_write_urb_2d
+
+
+ SUBROUTINE flux_map_and_write_3d ( &
+ acc_vec, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, sumarea, filter, &
+ longname, units)
+
+ USE MOD_Block
+ USE MOD_Vars_1DAccFluxes, only: nac
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(inout) :: acc_vec(:,:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: dim1name
+ integer, intent(in) :: lb1, ndim1
+
+ type(block_data_real8_2d), intent(in) :: sumarea
+ logical, intent(in) :: filter(:)
+ character (len=*), intent(in) :: longname
+ character (len=*), intent(in) :: units
+
+ ! Local variables
+ type(block_data_real8_3d) :: flux_xy_3d
+ integer :: iblkme, xblk, yblk, xloc, yloc, i1
+ integer :: compress
+
+ IF (p_is_compute) THEN
+ WHERE (acc_vec /= spval) acc_vec = acc_vec / nac
+ ENDIF
+ IF (p_is_active) THEN
+ CALL allocate_block_data (ghist, flux_xy_3d, ndim1, lb1)
+ ENDIF
+
+ CALL mp2g_hist%pset2grid (acc_vec, flux_xy_3d, spv = spval, msk = filter)
+
+ IF (p_is_active) THEN
+ DO iblkme = 1, gblock%nblkme
+ xblk = gblock%xblkme(iblkme)
+ yblk = gblock%yblkme(iblkme)
+
+ DO yloc = 1, ghist%ycnt(yblk)
+ DO xloc = 1, ghist%xcnt(xblk)
+
+ IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN
+ DO i1 = flux_xy_3d%lb1, flux_xy_3d%ub1
+ IF (flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) /= spval) THEN
+ flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) &
+ = flux_xy_3d%blk(xblk,yblk)%val(i1,xloc,yloc) &
+ / sumarea%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+ ENDDO
+ ELSE
+ flux_xy_3d%blk(xblk,yblk)%val(:,xloc,yloc) = spval
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDDO
+ ENDIF
+
+ compress = DEF_HIST_CompressLevel
+ CALL hist_write_var_real8_3d (file_hist, varname, dim1name, ghist, &
+ itime_in_file, flux_xy_3d, compress, longname, units)
+
+ END SUBROUTINE flux_map_and_write_3d
+
+
+ SUBROUTINE flux_map_and_write_4d ( &
+ acc_vec, file_hist, varname, itime_in_file, &
+ dim1name, lb1, ndim1, dim2name, lb2, ndim2, &
+ sumarea, filter, longname, units)
+
+ USE MOD_Block
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(inout) :: acc_vec(:,:,:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: dim1name, dim2name
+ integer, intent(in) :: lb1, ndim1, lb2, ndim2
+
+ type(block_data_real8_2d), intent(in) :: sumarea
+ logical, intent(in) :: filter(:)
+ character (len=*), intent(in) :: longname
+ character (len=*), intent(in) :: units
+
+ ! Local variables
+ type(block_data_real8_4d) :: flux_xy_4d
+ integer :: iblkme, xblk, yblk, xloc, yloc, i1, i2
+ integer :: compress
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (ghist, flux_xy_4d, ndim1, ndim2, lb1 = lb1, lb2 = lb2)
+ ENDIF
+
+ CALL mp2g_hist%pset2grid (acc_vec, flux_xy_4d, spv = spval, msk = filter)
+
+ IF (p_is_active) THEN
+ DO iblkme = 1, gblock%nblkme
+ xblk = gblock%xblkme(iblkme)
+ yblk = gblock%yblkme(iblkme)
+
+ DO yloc = 1, ghist%ycnt(yblk)
+ DO xloc = 1, ghist%xcnt(xblk)
+
+ IF (sumarea%blk(xblk,yblk)%val(xloc,yloc) > 0.00001) THEN
+ DO i1 = flux_xy_4d%lb1, flux_xy_4d%ub1
+ DO i2 = flux_xy_4d%lb2, flux_xy_4d%ub2
+ IF (flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) /= spval) THEN
+ flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) &
+ = flux_xy_4d%blk(xblk,yblk)%val(i1,i2,xloc,yloc) &
+ / sumarea%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ flux_xy_4d%blk(xblk,yblk)%val(:,:,xloc,yloc) = spval
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDDO
+ ENDIF
+
+ compress = DEF_HIST_CompressLevel
+ CALL hist_write_var_real8_4d (file_hist, varname, dim1name, dim2name, &
+ ghist, itime_in_file, flux_xy_4d, compress, longname, units)
+
+ END SUBROUTINE flux_map_and_write_4d
+
+
+ SUBROUTINE hist_gridded_write_time ( &
+ filename, filelast, dataname, time, itime)
+
+ USE MOD_Block
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: filename
+ character (len=*), intent(in) :: filelast
+ character (len=*), intent(in) :: dataname
+
+ integer, intent(in) :: time(3)
+ integer, intent(out) :: itime
+
+ ! Local variables
+ character(len=256) :: fileblock
+ integer :: iblkme, iblk, jblk
+ logical :: fexists
+
+ itime = 0
+ IF (trim(DEF_HIST_mode) == 'one') THEN
+ IF (p_is_root) THEN
+#ifdef USEMPI
+ IF (DEF_HIST_WriteBack) THEN
+ CALL hist_writeback_latlon_time (filename, filelast, dataname, time, hist_concat)
+ itime = 1
+ ELSE
+#endif
+ inquire (file=filename, exist=fexists)
+ IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN
+
+ CALL ncio_create_file (trim(filename))
+ CALL ncio_define_dimension(filename, 'time', 0)
+ CALL ncio_define_dimension(filename, 'lat' , hist_concat%ginfo%nlat)
+ CALL ncio_define_dimension(filename, 'lon' , hist_concat%ginfo%nlon)
+
+ CALL ncio_write_serial (filename, 'lat', hist_concat%ginfo%lat_c, 'lat')
+ CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude')
+ CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north')
+
+ CALL ncio_write_serial (filename, 'lon', hist_concat%ginfo%lon_c, 'lon')
+ CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude')
+ CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east')
+
+#ifndef SinglePoint
+ CALL ncio_write_serial (filename, 'lat_s', hist_concat%ginfo%lat_s, 'lat')
+ CALL ncio_write_serial (filename, 'lat_n', hist_concat%ginfo%lat_n, 'lat')
+ CALL ncio_write_serial (filename, 'lon_w', hist_concat%ginfo%lon_w, 'lon')
+ CALL ncio_write_serial (filename, 'lon_e', hist_concat%ginfo%lon_e, 'lon')
+#endif
+
+ CALL ncio_write_colm_dimension (filename)
+
+ ENDIF
+
+ CALL ncio_write_time (filename, dataname, time, itime, DEF_HIST_FREQ)
+
+#ifdef USEMPI
+ ENDIF
+#endif
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_bcast (itime, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+#endif
+
+ ELSEIF (trim(DEF_HIST_mode) == 'block') THEN
+
+ IF (p_is_active) THEN
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+ IF (ghist%ycnt(jblk) <= 0) CYCLE
+ IF (ghist%xcnt(iblk) <= 0) CYCLE
+
+ CALL get_filename_block (filename, iblk, jblk, fileblock)
+
+ inquire (file=fileblock, exist=fexists)
+ IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN
+ CALL ncio_create_file (trim(fileblock))
+ CALL ncio_define_dimension (fileblock, 'time', 0)
+ CALL hist_write_grid_info (fileblock, ghist, iblk, jblk)
+ ENDIF
+
+ CALL ncio_write_time (fileblock, dataname, time, itime, DEF_HIST_FREQ)
+
+ ENDDO
+
+ ENDIF
+#ifdef USEMPI
+#ifdef MPAS_EMBEDDED_COLM
+ CALL mpi_allreduce (MPI_IN_PLACE, itime, 1, MPI_INTEGER, MPI_MAX, p_comm_group, p_err)
+#else
+ IF (.not. p_is_root) CALL mpi_bcast (itime, 1, MPI_INTEGER, p_root, p_comm_group, p_err)
+#endif
+#endif
+
+ ENDIF
+
+ END SUBROUTINE hist_gridded_write_time
+
+
+ SUBROUTINE hist_write_var_real8_2d ( &
+ filename, dataname, grid, itime, wdata, compress, longname, units)
+
+ USE MOD_Block
+ USE MOD_Vars_Global, only: spval
+ 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(in) :: wdata
+
+ integer, intent(in) :: compress
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ ! Local variables
+ integer :: iblkme, iblk, jblk, idata, ixseg, iyseg
+ integer :: xcnt, ycnt, xbdsp, ybdsp, xgdsp, ygdsp
+ integer :: rmesg(3), smesg(3), isrc
+ character(len=256) :: fileblock
+ real(r8), allocatable :: rbuf(:,:), sbuf(:,:), vdata(:,:)
+
+ IF (trim(DEF_HIST_mode) == 'one') THEN
+
+ IF (p_is_root) THEN
+
+#ifdef USEMPI
+ IF (.not. DEF_HIST_WriteBack) THEN
+
+ allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat))
+ vdata(:,:) = spval
+
+ DO idata = 1, hist_concat%ndatablk
+ CALL mpi_recv (rmesg, 3, MPI_INTEGER, MPI_ANY_SOURCE, &
+ hist_data_id, p_comm_glb, p_stat, p_err)
+
+ isrc = rmesg(1)
+ ixseg = rmesg(2)
+ iyseg = rmesg(3)
+
+ xgdsp = hist_concat%xsegs(ixseg)%gdsp
+ ygdsp = hist_concat%ysegs(iyseg)%gdsp
+ xcnt = hist_concat%xsegs(ixseg)%cnt
+ ycnt = hist_concat%ysegs(iyseg)%cnt
+
+ allocate (rbuf(xcnt,ycnt))
+
+ CALL mpi_recv (rbuf, xcnt*ycnt, MPI_REAL8, &
+ isrc, hist_data_id, p_comm_glb, p_stat, p_err)
+
+ vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = rbuf
+ deallocate (rbuf)
+
+ ENDDO
+
+ ELSE
+ IF (itime == -1) THEN
+ CALL hist_writeback_var_header (hist_data_id, filename, dataname, &
+ 2, 'lon', 'lat', '', '', '', compress, longname, units)
+ ELSE
+ CALL hist_writeback_var_header (hist_data_id, filename, dataname, &
+ 3, 'lon', 'lat', 'time', '', '', compress, longname, units)
+ ENDIF
+ ENDIF
+#else
+ allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat))
+ vdata(:,:) = spval
+
+ DO iyseg = 1, hist_concat%nyseg
+ DO ixseg = 1, hist_concat%nxseg
+ iblk = hist_concat%xsegs(ixseg)%blk
+ jblk = hist_concat%ysegs(iyseg)%blk
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+ xbdsp = hist_concat%xsegs(ixseg)%bdsp
+ ybdsp = hist_concat%ysegs(iyseg)%bdsp
+ xgdsp = hist_concat%xsegs(ixseg)%gdsp
+ ygdsp = hist_concat%ysegs(iyseg)%gdsp
+ xcnt = hist_concat%xsegs(ixseg)%cnt
+ ycnt = hist_concat%ysegs(iyseg)%cnt
+
+ vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt) = &
+ wdata%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt)
+ ENDIF
+ ENDDO
+ ENDDO
+#endif
+
+#ifdef USEMPI
+ IF (.not. DEF_HIST_WriteBack) THEN
+#endif
+ IF (itime >= 1) THEN
+
+ CALL ncio_write_serial_time (filename, dataname, itime, vdata, &
+ 'lon', 'lat', 'time', compress)
+
+ ELSEIF (itime == -1) THEN
+ CALL ncio_write_serial (filename, dataname, vdata, 'lon', 'lat', compress)
+ ENDIF
+
+ IF (itime <= 1) THEN
+ CALL ncio_put_attr (filename, dataname, 'long_name', longname)
+ CALL ncio_put_attr (filename, dataname, 'units', units)
+ CALL ncio_put_attr (filename, dataname, 'missing_value', spval)
+ ENDIF
+
+ deallocate (vdata)
+#ifdef USEMPI
+ ENDIF
+#endif
+
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_active) THEN
+ DO iyseg = 1, hist_concat%nyseg
+ DO ixseg = 1, hist_concat%nxseg
+
+ iblk = hist_concat%xsegs(ixseg)%blk
+ jblk = hist_concat%ysegs(iyseg)%blk
+
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+
+ xbdsp = hist_concat%xsegs(ixseg)%bdsp
+ ybdsp = hist_concat%ysegs(iyseg)%bdsp
+ xcnt = hist_concat%xsegs(ixseg)%cnt
+ ycnt = hist_concat%ysegs(iyseg)%cnt
+
+ allocate (sbuf (xcnt,ycnt))
+ sbuf = wdata%blk(iblk,jblk)%val(xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt)
+
+ IF (.not. DEF_HIST_WriteBack) THEN
+ smesg = (/p_iam_glb, ixseg, iyseg/)
+ CALL mpi_send (smesg, 3, MPI_INTEGER, &
+ p_address_root, hist_data_id, p_comm_glb, p_err)
+ CALL mpi_send (sbuf, xcnt*ycnt, MPI_REAL8, &
+ p_address_root, hist_data_id, p_comm_glb, p_err)
+ ELSE
+ CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata2d = sbuf)
+ ENDIF
+
+ deallocate (sbuf)
+
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+#endif
+
+ hist_data_id = mod(hist_data_id-10000,10000) + 100001
+
+ ELSEIF (trim(DEF_HIST_mode) == 'block') THEN
+
+ IF (p_is_active) THEN
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+
+ IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE
+
+ CALL get_filename_block (filename, iblk, jblk, fileblock)
+
+ IF (itime >= 1) THEN
+
+ CALL ncio_write_serial_time (fileblock, dataname, itime, &
+ wdata%blk(iblk,jblk)%val, 'lon', 'lat', 'time', compress)
+
+ ELSEIF (itime == -1) THEN
+ CALL ncio_write_serial (fileblock, dataname, &
+ wdata%blk(iblk,jblk)%val, 'lon', 'lat', compress)
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE hist_write_var_real8_2d
+
+
+ SUBROUTINE hist_write_var_real8_3d ( &
+ filename, dataname, dim1name, grid, itime, wdata, compress, longname, units)
+
+ USE MOD_Block
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: filename
+ character (len=*), intent(in) :: dataname
+ character (len=*), intent(in) :: dim1name
+ type (grid_type), intent(in) :: grid
+ integer, intent(in) :: itime
+
+ type (block_data_real8_3d), intent(in) :: wdata
+
+ integer, intent(in) :: compress
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ ! Local variables
+ integer :: iblkme, iblk, jblk, idata, ixseg, iyseg
+ integer :: xcnt, ycnt, ndim1, xbdsp, ybdsp, xgdsp, ygdsp, idim1
+ integer :: rmesg(4), smesg(4), isrc
+ character(len=256) :: fileblock
+ real(r8), allocatable :: rbuf(:,:,:), sbuf(:,:,:), vdata(:,:,:)
+
+ IF (trim(DEF_HIST_mode) == 'one') THEN
+
+ IF (p_is_root) THEN
+
+#ifdef USEMPI
+ IF (.not. DEF_HIST_WriteBack) THEN
+
+ DO idata = 1, hist_concat%ndatablk
+
+ CALL mpi_recv (rmesg, 4, MPI_INTEGER, MPI_ANY_SOURCE, &
+ hist_data_id, p_comm_glb, p_stat, p_err)
+
+ isrc = rmesg(1)
+ ixseg = rmesg(2)
+ iyseg = rmesg(3)
+ ndim1 = rmesg(4)
+
+ xgdsp = hist_concat%xsegs(ixseg)%gdsp
+ ygdsp = hist_concat%ysegs(iyseg)%gdsp
+ xcnt = hist_concat%xsegs(ixseg)%cnt
+ ycnt = hist_concat%ysegs(iyseg)%cnt
+
+ allocate (rbuf (ndim1,xcnt,ycnt))
+
+ CALL mpi_recv (rbuf, ndim1*xcnt*ycnt, MPI_REAL8, &
+ isrc, hist_data_id, p_comm_glb, p_stat, p_err)
+
+ IF (idata == 1) THEN
+ allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat, ndim1))
+ vdata(:,:,:) = spval
+ ENDIF
+
+ DO idim1 = 1, ndim1
+ vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt, idim1) = rbuf(idim1,:,:)
+ ENDDO
+
+ deallocate (rbuf)
+ ENDDO
+
+ ELSE
+ CALL hist_writeback_var_header (hist_data_id, filename, dataname, &
+ 4, 'lon', 'lat', dim1name, 'time', '', compress, longname, units)
+ ENDIF
+#else
+ ndim1 = wdata%ub1 - wdata%lb1 + 1
+ allocate (vdata (hist_concat%ginfo%nlon, hist_concat%ginfo%nlat, ndim1))
+ vdata(:,:,:) = spval
+
+ DO iyseg = 1, hist_concat%nyseg
+ DO ixseg = 1, hist_concat%nxseg
+ iblk = hist_concat%xsegs(ixseg)%blk
+ jblk = hist_concat%ysegs(iyseg)%blk
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+ xbdsp = hist_concat%xsegs(ixseg)%bdsp
+ ybdsp = hist_concat%ysegs(iyseg)%bdsp
+ xgdsp = hist_concat%xsegs(ixseg)%gdsp
+ ygdsp = hist_concat%ysegs(iyseg)%gdsp
+ xcnt = hist_concat%xsegs(ixseg)%cnt
+ ycnt = hist_concat%ysegs(iyseg)%cnt
+
+ DO idim1 = 1, ndim1
+ vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt,idim1) = &
+ wdata%blk(iblk,jblk)%val(wdata%lb1+idim1-1,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt)
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+#endif
+
+
+#ifdef USEMPI
+ IF (.not. DEF_HIST_WriteBack) THEN
+#endif
+ CALL ncio_define_dimension (filename, dim1name, ndim1)
+
+ CALL ncio_write_serial_time (filename, dataname, itime, &
+ vdata, 'lon', 'lat', dim1name, 'time', compress)
+
+ IF (itime == 1) THEN
+ CALL ncio_put_attr (filename, dataname, 'long_name', longname)
+ CALL ncio_put_attr (filename, dataname, 'units', units)
+ CALL ncio_put_attr (filename, dataname, 'missing_value', spval)
+ ENDIF
+
+ deallocate (vdata)
+#ifdef USEMPI
+ ENDIF
+#endif
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_active) THEN
+
+ DO iyseg = 1, hist_concat%nyseg
+ DO ixseg = 1, hist_concat%nxseg
+
+ iblk = hist_concat%xsegs(ixseg)%blk
+ jblk = hist_concat%ysegs(iyseg)%blk
+
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+
+ xbdsp = hist_concat%xsegs(ixseg)%bdsp
+ ybdsp = hist_concat%ysegs(iyseg)%bdsp
+ xcnt = hist_concat%xsegs(ixseg)%cnt
+ ycnt = hist_concat%ysegs(iyseg)%cnt
+ ndim1 = size(wdata%blk(iblk,jblk)%val,1)
+
+ allocate (sbuf (ndim1,xcnt,ycnt))
+ sbuf = wdata%blk(iblk,jblk)%val(:, xbdsp+1:xbdsp+xcnt, ybdsp+1:ybdsp+ycnt)
+
+ IF (.not. DEF_HIST_WriteBack) THEN
+ smesg = (/p_iam_glb, ixseg, iyseg, ndim1/)
+ CALL mpi_send (smesg, 4, MPI_INTEGER, &
+ p_address_root, hist_data_id, p_comm_glb, p_err)
+ CALL mpi_send (sbuf, ndim1*xcnt*ycnt, MPI_REAL8, &
+ p_address_root, hist_data_id, p_comm_glb, p_err)
+ ELSE
+ CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata3d = sbuf)
+ ENDIF
+
+ deallocate (sbuf)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+#endif
+
+ hist_data_id = mod(hist_data_id-10000,10000) + 100001
+
+ ELSEIF (trim(DEF_HIST_mode) == 'block') THEN
+
+ IF (p_is_active) THEN
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+
+ IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE
+
+ CALL get_filename_block (filename, iblk, jblk, fileblock)
+
+ CALL ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1)
+
+ CALL ncio_write_serial_time (fileblock, dataname, itime, &
+ wdata%blk(iblk,jblk)%val, dim1name, 'lon', 'lat', 'time', compress)
+
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE hist_write_var_real8_3d
+
+
+ SUBROUTINE hist_write_var_real8_4d ( &
+ filename, dataname, dim1name, dim2name, grid, itime, wdata, compress, longname, units)
+
+ USE MOD_Block
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: filename
+ character (len=*), intent(in) :: dataname
+ character (len=*), intent(in) :: dim1name, dim2name
+ type (grid_type), intent(in) :: grid
+ integer, intent(in) :: itime
+
+ type (block_data_real8_4d), intent(in) :: wdata
+
+ integer, intent(in) :: compress
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ ! Local variables
+ integer :: iblkme, iblk, jblk, idata, ixseg, iyseg
+ integer :: xcnt, ycnt, ndim1, ndim2, xbdsp, ybdsp, xgdsp, ygdsp, idim1, idim2
+ integer :: rmesg(5), smesg(5), isrc
+ character(len=256) :: fileblock
+ real(r8), allocatable :: rbuf(:,:,:,:), sbuf(:,:,:,:), vdata(:,:,:,:)
+
+ IF (trim(DEF_HIST_mode) == 'one') THEN
+
+ IF (p_is_root) THEN
+
+#ifdef USEMPI
+ IF (.not. DEF_HIST_WriteBack) THEN
+
+ DO idata = 1, hist_concat%ndatablk
+
+ CALL mpi_recv (rmesg, 5, MPI_INTEGER, MPI_ANY_SOURCE, &
+ hist_data_id, p_comm_glb, p_stat, p_err)
+
+ isrc = rmesg(1)
+ ixseg = rmesg(2)
+ iyseg = rmesg(3)
+ ndim1 = rmesg(4)
+ ndim2 = rmesg(5)
+
+ xgdsp = hist_concat%xsegs(ixseg)%gdsp
+ ygdsp = hist_concat%ysegs(iyseg)%gdsp
+ xcnt = hist_concat%xsegs(ixseg)%cnt
+ ycnt = hist_concat%ysegs(iyseg)%cnt
+
+ allocate (rbuf (ndim1,ndim2,xcnt,ycnt))
+
+ CALL mpi_recv (rbuf, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, &
+ isrc, hist_data_id, p_comm_glb, p_stat, p_err)
+
+ IF (idata == 1) THEN
+ allocate (vdata (hist_concat%ginfo%nlon,hist_concat%ginfo%nlat,ndim1,ndim2))
+ vdata(:,:,:,:) = spval
+ ENDIF
+
+ DO idim1 = 1, ndim1
+ DO idim2 = 1, ndim2
+ vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt, idim1, idim2) = rbuf(idim1,idim2,:,:)
+ ENDDO
+ ENDDO
+
+ deallocate (rbuf)
+ ENDDO
+
+ ELSE
+ CALL hist_writeback_var_header (hist_data_id, filename, dataname, &
+ 5, 'lon', 'lat', dim1name, dim2name, 'time', compress, longname, units)
+ ENDIF
+#else
+ ndim1 = wdata%ub1 - wdata%lb1 + 1
+ ndim2 = wdata%ub2 - wdata%lb2 + 1
+ allocate (vdata (hist_concat%ginfo%nlon,hist_concat%ginfo%nlat,ndim1,ndim2))
+ vdata(:,:,:,:) = spval
+
+ DO iyseg = 1, hist_concat%nyseg
+ DO ixseg = 1, hist_concat%nxseg
+ iblk = hist_concat%xsegs(ixseg)%blk
+ jblk = hist_concat%ysegs(iyseg)%blk
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+ xbdsp = hist_concat%xsegs(ixseg)%bdsp
+ ybdsp = hist_concat%ysegs(iyseg)%bdsp
+ xgdsp = hist_concat%xsegs(ixseg)%gdsp
+ ygdsp = hist_concat%ysegs(iyseg)%gdsp
+ xcnt = hist_concat%xsegs(ixseg)%cnt
+ ycnt = hist_concat%ysegs(iyseg)%cnt
+
+ DO idim1 = 1, ndim1
+ DO idim2 = 1, ndim2
+ vdata (xgdsp+1:xgdsp+xcnt, ygdsp+1:ygdsp+ycnt, idim1, idim2) = &
+ wdata%blk(iblk,jblk)%val(idim1,idim2,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+
+#endif
+
+#ifdef USEMPI
+ IF (.not. DEF_HIST_WriteBack) THEN
+#endif
+ CALL ncio_define_dimension (filename, dim1name, ndim1)
+ CALL ncio_define_dimension (filename, dim2name, ndim2)
+
+ CALL ncio_write_serial_time (filename, dataname, itime, vdata, &
+ 'lon', 'lat', dim1name, dim2name, 'time', compress)
+
+ IF (itime == 1) THEN
+ CALL ncio_put_attr (filename, dataname, 'long_name', longname)
+ CALL ncio_put_attr (filename, dataname, 'units', units)
+ CALL ncio_put_attr (filename, dataname, 'missing_value', spval)
+ ENDIF
+
+ deallocate (vdata)
+#ifdef USEMPI
+ ENDIF
+#endif
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_active) THEN
+
+ DO iyseg = 1, hist_concat%nyseg
+ DO ixseg = 1, hist_concat%nxseg
+
+ iblk = hist_concat%xsegs(ixseg)%blk
+ jblk = hist_concat%ysegs(iyseg)%blk
+
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+
+ xbdsp = hist_concat%xsegs(ixseg)%bdsp
+ ybdsp = hist_concat%ysegs(iyseg)%bdsp
+ xcnt = hist_concat%xsegs(ixseg)%cnt
+ ycnt = hist_concat%ysegs(iyseg)%cnt
+
+ ndim1 = size(wdata%blk(iblk,jblk)%val,1)
+ ndim2 = size(wdata%blk(iblk,jblk)%val,2)
+ allocate (sbuf (ndim1,ndim2,xcnt,ycnt))
+ sbuf = wdata%blk(iblk,jblk)%val(:,:,xbdsp+1:xbdsp+xcnt,ybdsp+1:ybdsp+ycnt)
+
+ IF (.not. DEF_HIST_WriteBack) THEN
+ smesg = (/p_iam_glb, ixseg, iyseg, ndim1, ndim2/)
+ CALL mpi_send (smesg, 5, MPI_INTEGER, &
+ p_address_root, hist_data_id, p_comm_glb, p_err)
+ CALL mpi_send (sbuf, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, &
+ p_address_root, hist_data_id, p_comm_glb, p_err)
+ ELSE
+ CALL hist_writeback_var (hist_data_id, ixseg, iyseg, wdata4d = sbuf)
+ ENDIF
+
+ deallocate (sbuf)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+#endif
+
+ hist_data_id = mod(hist_data_id-10000,10000) + 100001
+
+ ELSEIF (trim(DEF_HIST_mode) == 'block') THEN
+ IF (p_is_active) THEN
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+
+ IF ((grid%xcnt(iblk) == 0) .or. (grid%ycnt(jblk) == 0)) CYCLE
+
+ CALL get_filename_block (filename, iblk, jblk, fileblock)
+
+ CALL ncio_define_dimension (fileblock, dim1name, wdata%ub1-wdata%lb1+1)
+ CALL ncio_define_dimension (fileblock, dim2name, wdata%ub2-wdata%lb2+1)
+
+ CALL ncio_write_serial_time (fileblock, dataname, itime, &
+ wdata%blk(iblk,jblk)%val, dim1name, dim2name, 'lon', 'lat', 'time', compress)
+
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE hist_write_var_real8_4d
+
+
+ SUBROUTINE hist_write_grid_info (fileblock, grid, iblk, jblk)
+
+ USE MOD_Block
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: fileblock
+ type (grid_type), intent(in) :: grid
+ integer, intent(in) :: iblk, jblk
+
+ ! Local variable
+ integer :: yl, yu, xl, xu, nx
+ real(r8), allocatable :: lat_s(:), lat_n(:), lon_w(:), lon_e(:)
+
+ allocate (lon_w (grid%xcnt(iblk)))
+ allocate (lon_e (grid%xcnt(iblk)))
+ allocate (lat_s (grid%ycnt(jblk)))
+ allocate (lat_n (grid%ycnt(jblk)))
+
+ yl = grid%ydsp(jblk) + 1
+ yu = grid%ydsp(jblk) + grid%ycnt(jblk)
+
+ lat_s = grid%lat_s(yl:yu)
+ lat_n = grid%lat_n(yl:yu)
+
+ IF (grid%xdsp(iblk) + grid%xcnt(iblk) > grid%nlon) THEN
+ xl = grid%xdsp(iblk) + 1
+ xu = grid%nlon
+ nx = grid%nlon - grid%xdsp(iblk)
+ lon_w(1:nx) = grid%lon_w(xl:xu)
+ lon_e(1:nx) = grid%lon_e(xl:xu)
+
+ xl = 1
+ xu = grid%xcnt(iblk) - nx
+ lon_w(nx+1:grid%xcnt(iblk)) = grid%lon_w(xl:xu)
+ lon_e(nx+1:grid%xcnt(iblk)) = grid%lon_e(xl:xu)
+ ELSE
+ xl = grid%xdsp(iblk) + 1
+ xu = grid%xdsp(iblk) + grid%xcnt(iblk)
+ lon_w = grid%lon_w(xl:xu)
+ lon_e = grid%lon_e(xl:xu)
+ ENDIF
+
+ CALL ncio_define_dimension (fileblock, 'lat', grid%ycnt(jblk))
+ CALL ncio_define_dimension (fileblock, 'lon', grid%xcnt(iblk))
+ CALL ncio_write_serial (fileblock, 'lat_s', lat_s, 'lat')
+ CALL ncio_write_serial (fileblock, 'lat_n', lat_n, 'lat')
+ CALL ncio_write_serial (fileblock, 'lon_w', lon_w, 'lon')
+ CALL ncio_write_serial (fileblock, 'lon_e', lon_e, 'lon')
+
+ CALL ncio_write_colm_dimension (fileblock)
+
+ END SUBROUTINE hist_write_grid_info
+
+END MODULE MOD_HistGridded
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90
new file mode 100644
index 0000000000..2c1b748491
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistSingle.F90
@@ -0,0 +1,370 @@
+#include
+
+#ifdef SinglePoint
+MODULE MOD_HistSingle
+
+!----------------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Write out model results at sites to history files.
+!
+! Created by Shupeng Zhang, July 2023
+!
+! TODO...(need complement)
+!----------------------------------------------------------------------------
+ USE MOD_Precision
+ USE MOD_NetCDFSerial
+ USE MOD_Namelist, only: USE_SITE_HistWriteBack
+ USE MOD_SPMD_Task
+
+ logical :: memory_to_disk
+
+ integer :: ntime_mem
+ integer :: itime_mem
+ integer, allocatable :: time_memory (:)
+
+ ! -- data type --
+ type hist_memory_type
+ character(len=256) :: varname
+ real(r8), allocatable :: v2d (:,:)
+ real(r8), allocatable :: v3d (:,:,:)
+ real(r8), allocatable :: v4d (:,:,:,:)
+ type(hist_memory_type), pointer :: next
+ END type hist_memory_type
+
+ type(hist_memory_type), target :: hist_memory
+ type(hist_memory_type), pointer :: thisvar, nextvar
+
+CONTAINS
+
+ ! -- initialize history IO --
+ SUBROUTINE hist_single_init ()
+
+ USE MOD_Namelist
+ IMPLICIT NONE
+
+ ! Local Variables
+ real(r8) :: secs_group, secs_write
+
+ IF (USE_SITE_HistWriteBack) THEN
+
+ IF ( trim(DEF_HIST_groupby) == 'YEAR' ) THEN
+ secs_group = 366*24*3600
+ ELSEIF ( trim(DEF_HIST_groupby) == 'MONTH' ) THEN
+ secs_group = 31*24*3600
+ ELSEIF ( trim(DEF_HIST_groupby) == 'DAY' ) THEN
+ secs_group = 24*3600
+ ENDIF
+
+ select CASE (trim(adjustl(DEF_HIST_FREQ)))
+ CASE ('TIMESTEP')
+ secs_write = DEF_simulation_time%timestep
+ CASE ('HOURLY')
+ secs_write = 3600
+ CASE ('DAILY')
+ secs_write = 24*3600
+ CASE ('MONTHLY')
+ secs_write = 31*24*3600
+ CASE ('YEARLY')
+ secs_write = 366*24*3600
+ END select
+
+ ntime_mem = ceiling(secs_group / secs_write) + 2
+
+ allocate (time_memory (ntime_mem))
+
+ itime_mem = 0
+
+ hist_memory%next => null()
+ hist_memory%varname = ''
+
+ thisvar => hist_memory
+
+ ENDIF
+
+ END SUBROUTINE hist_single_init
+
+ ! -- finalize history IO --
+ SUBROUTINE hist_single_final ()
+
+ IMPLICIT NONE
+
+ IF (USE_SITE_HistWriteBack) THEN
+
+ thisvar => hist_memory%next
+ DO WHILE (associated(thisvar))
+ nextvar => thisvar%next
+ IF (allocated(thisvar%v2d)) deallocate(thisvar%v2d)
+ IF (allocated(thisvar%v3d)) deallocate(thisvar%v3d)
+ IF (allocated(thisvar%v4d)) deallocate(thisvar%v4d)
+ deallocate(thisvar)
+ thisvar => nextvar
+ ENDDO
+
+ deallocate (time_memory)
+
+ ENDIF
+
+ END SUBROUTINE hist_single_final
+
+ ! -- write history time --
+ SUBROUTINE hist_single_write_time (filename, filelast, dataname, time, itime)
+
+ USE MOD_Namelist
+ USE MOD_TimeManager
+ USE MOD_SingleSrfData
+ USE MOD_NetCDFSerial
+ USE MOD_Landpatch, only: numpatch
+#ifdef URBAN_MODEL
+ USE MOD_Landurban, only: numurban
+#endif
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: filename
+ character (len=*), intent(in) :: filelast
+ character (len=*), intent(in) :: dataname
+
+ integer, intent(in) :: time(3)
+ integer, intent(out) :: itime
+
+ ! Local variables
+ integer :: minutes
+ logical :: fexists
+
+ inquire (file=filename, exist=fexists)
+ IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN
+ CALL ncio_create_file (trim(filename))
+ CALL ncio_define_dimension(filename, 'patch', numpatch)
+
+ CALL ncio_write_serial (filename, 'lat', SITE_lat_location)
+ CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude')
+ CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north')
+
+ CALL ncio_write_serial (filename, 'lon', SITE_lon_location)
+ CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude')
+ CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east')
+
+ CALL ncio_write_colm_dimension (filename)
+
+ IF (.not. USE_SITE_HistWriteBack) THEN
+ CALL ncio_define_dimension(filename, 'time', 0)
+ ENDIF
+
+ ENDIF
+
+ IF (USE_SITE_HistWriteBack) THEN
+
+ minutes = minutes_since_1900 (time(1), time(2), time(3))
+
+ select CASE (trim(adjustl(DEF_HIST_FREQ)))
+ CASE ('HOURLY')
+ minutes = minutes - 30
+ CASE ('DAILY')
+ minutes = minutes - 720
+ CASE ('MONTHLY')
+ minutes = minutes - 21600
+ CASE ('YEARLY')
+ minutes = minutes - 262800
+ END select
+
+ itime_mem = itime_mem + 1
+ time_memory(itime_mem) = minutes
+
+ IF (memory_to_disk) THEN
+ CALL ncio_define_dimension(filename, 'time', itime_mem)
+ CALL ncio_write_serial (filename, dataname, time_memory(1:itime_mem), 'time')
+ CALL ncio_put_attr (filename, dataname, 'long_name', 'time')
+ CALL ncio_put_attr (filename, dataname, 'units', 'minutes since 1900-1-1 0:0:0')
+ ENDIF
+
+ thisvar => hist_memory
+
+ ELSE
+ CALL ncio_write_time (filename, dataname, time, itime, DEF_HIST_FREQ)
+ ENDIF
+
+ END SUBROUTINE hist_single_write_time
+
+ ! -- write 2D data --
+ SUBROUTINE single_write_2d ( &
+ acc_vec, file_hist, varname, itime_in_file, longname, units)
+
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(inout) :: acc_vec(:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ IF (USE_SITE_HistWriteBack) THEN
+
+ IF (.not. associated(thisvar%next)) THEN
+ allocate (thisvar%next)
+ thisvar => thisvar%next
+
+ thisvar%next => null()
+ thisvar%varname = varname
+ allocate(thisvar%v2d (size(acc_vec),ntime_mem))
+ ELSE
+ thisvar => thisvar%next
+ ENDIF
+
+ IF (thisvar%varname /= varname) THEN
+ write(*,*) 'Warning: history variable in memory is wrong: ' &
+ // trim(thisvar%varname) // ' should be ' // trim(varname)
+ CALL CoLM_stop ()
+ ENDIF
+
+ thisvar%v2d(:,itime_mem) = acc_vec(:)
+
+ IF (memory_to_disk) THEN
+ CALL ncio_write_serial (file_hist, varname, &
+ thisvar%v2d(:,1:itime_mem), 'patch', 'time')
+ CALL ncio_put_attr (file_hist, varname, 'long_name', longname)
+ CALL ncio_put_attr (file_hist, varname, 'units', units)
+ CALL ncio_put_attr (file_hist, varname, 'missing_value', spval)
+ ENDIF
+
+ ELSE
+ CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, &
+ 'patch', 'time')
+ IF (itime_in_file == 1) THEN
+ CALL ncio_put_attr (file_hist, varname, 'long_name', longname)
+ CALL ncio_put_attr (file_hist, varname, 'units', units)
+ CALL ncio_put_attr (file_hist, varname, 'missing_value', spval)
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE single_write_2d
+
+ ! -- write 3D data --
+ SUBROUTINE single_write_3d ( &
+ acc_vec, file_hist, varname, itime_in_file, dim1name, ndim1, longname, units)
+
+ USE MOD_Vars_1DAccFluxes, only: nac
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(inout) :: acc_vec(:,:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: dim1name
+ integer, intent(in) :: ndim1
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ WHERE (acc_vec /= spval) acc_vec = acc_vec / nac
+
+ IF (USE_SITE_HistWriteBack) THEN
+
+ IF (.not. associated(thisvar%next)) THEN
+ allocate (thisvar%next)
+ thisvar => thisvar%next
+
+ thisvar%next => null()
+ thisvar%varname = varname
+ allocate(thisvar%v3d (ndim1,size(acc_vec,2),ntime_mem))
+ ELSE
+ thisvar => thisvar%next
+ ENDIF
+
+ IF (thisvar%varname /= varname) THEN
+ write(*,*) 'Warning: history variable in memory is wrong: ' &
+ // trim(thisvar%varname) // ' should be ' // trim(varname)
+ CALL CoLM_stop ()
+ ENDIF
+
+ thisvar%v3d(:,:,itime_mem) = acc_vec
+
+ IF (memory_to_disk) THEN
+ CALL ncio_define_dimension (file_hist, dim1name, ndim1)
+ CALL ncio_write_serial (file_hist, varname, thisvar%v3d(:,:,1:itime_mem), &
+ dim1name, 'patch', 'time')
+ CALL ncio_put_attr (file_hist, varname, 'long_name', longname)
+ CALL ncio_put_attr (file_hist, varname, 'units', units)
+ CALL ncio_put_attr (file_hist, varname, 'missing_value', spval)
+ ENDIF
+
+ ELSE
+ CALL ncio_define_dimension (file_hist, dim1name, ndim1)
+ CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, &
+ dim1name, 'patch', 'time')
+ IF (itime_in_file == 1) THEN
+ CALL ncio_put_attr (file_hist, varname, 'long_name', longname)
+ CALL ncio_put_attr (file_hist, varname, 'units', units)
+ CALL ncio_put_attr (file_hist, varname, 'missing_value', spval)
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE single_write_3d
+
+ ! -- write 4D data --
+ SUBROUTINE single_write_4d ( &
+ acc_vec, file_hist, varname, itime_in_file, &
+ dim1name, ndim1, dim2name, ndim2, longname, units)
+
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(inout) :: acc_vec(:,:,:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: dim1name
+ integer, intent(in) :: ndim1
+ character(len=*), intent(in) :: dim2name
+ integer, intent(in) :: ndim2
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ IF (USE_SITE_HistWriteBack) THEN
+
+ IF (.not. associated(thisvar%next)) THEN
+ allocate (thisvar%next)
+ thisvar => thisvar%next
+
+ thisvar%next => null()
+ thisvar%varname = varname
+ allocate(thisvar%v4d (ndim1,ndim2,size(acc_vec,3),ntime_mem))
+ ELSE
+ thisvar => thisvar%next
+ ENDIF
+
+ IF (thisvar%varname /= varname) THEN
+ write(*,*) 'Warning: history variable in memory is wrong: ' &
+ // trim(thisvar%varname) // ' should be ' // trim(varname)
+ CALL CoLM_stop ()
+ ENDIF
+
+ thisvar%v4d(:,:,:,itime_mem) = acc_vec
+
+ IF (memory_to_disk) THEN
+ CALL ncio_define_dimension (file_hist, dim1name, ndim1)
+ CALL ncio_define_dimension (file_hist, dim2name, ndim2)
+ CALL ncio_write_serial (file_hist, varname, thisvar%v4d(:,:,:,1:itime_mem), &
+ dim1name, dim2name, 'patch', 'time')
+ CALL ncio_put_attr (file_hist, varname, 'long_name', longname)
+ CALL ncio_put_attr (file_hist, varname, 'units', units)
+ CALL ncio_put_attr (file_hist, varname, 'missing_value', spval)
+ ENDIF
+
+ ELSE
+ CALL ncio_define_dimension (file_hist, dim1name, ndim1)
+ CALL ncio_define_dimension (file_hist, dim2name, ndim2)
+ CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, &
+ dim1name, dim2name, 'patch', 'time')
+ IF (itime_in_file == 1) THEN
+ CALL ncio_put_attr (file_hist, varname, 'long_name', longname)
+ CALL ncio_put_attr (file_hist, varname, 'units', units)
+ CALL ncio_put_attr (file_hist, varname, 'missing_value', spval)
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE single_write_4d
+
+END MODULE MOD_HistSingle
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90
new file mode 100644
index 0000000000..3311b4e2e2
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistVector.F90
@@ -0,0 +1,623 @@
+#include
+
+#if (defined UNSTRUCTURED || defined CATCHMENT)
+MODULE MOD_HistVector
+
+!----------------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Write out vectorized model results to history files.
+!
+! Created by Shupeng Zhang, May 2023
+!
+! TODO...(need complement)
+!----------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Vars_Global, only: spval
+ USE MOD_Mesh
+ USE MOD_LandElm
+#ifdef CATCHMENT
+ USE MOD_LandHRU
+#endif
+ USE MOD_Pixelset
+ USE MOD_NetCDFSerial
+#ifdef CATCHMENT
+ USE MOD_HRUVector
+#else
+ USE MOD_ElmVector
+#endif
+
+CONTAINS
+
+ ! -- write history time --
+ SUBROUTINE hist_vector_write_time (filename, filelast, dataname, time, itime_in_file)
+
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: filename
+ character (len=*), intent(in) :: filelast
+ character (len=*), intent(in) :: dataname
+ integer, intent(in) :: time(3)
+ integer, intent(out) :: itime_in_file
+
+ ! Local Variables
+ logical :: fexists
+
+ IF (p_is_root) THEN
+
+ inquire (file=filename, exist=fexists)
+ IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN
+ CALL ncio_create_file (trim(filename))
+ CALL ncio_define_dimension(filename, 'time', 0)
+
+#ifdef CATCHMENT
+ CALL ncio_define_dimension(filename, 'hydrounit', totalnumhru)
+
+ CALL ncio_write_serial (filename, 'bsn_hru', eindx_hru, 'hydrounit')
+ CALL ncio_put_attr (filename, 'bsn_hru', 'long_name', &
+ 'basin index of hydrological units in mesh')
+
+ CALL ncio_write_serial (filename, 'typ_hru' , htype_hru, 'hydrounit')
+ CALL ncio_put_attr (filename, 'typ_hru' , 'long_name', &
+ 'index of hydrological units inside basin')
+#else
+ CALL ncio_define_dimension(filename, 'element', totalnumelm)
+ CALL ncio_write_serial (filename, 'elmindex', eindex_glb, 'element')
+ CALL ncio_put_attr (filename, 'elmindex', 'long_name', &
+ 'element index in mesh')
+#endif
+
+ CALL ncio_write_colm_dimension (filename)
+
+ ENDIF
+
+ CALL ncio_write_time (filename, dataname, time, itime_in_file, DEF_HIST_FREQ)
+
+ ENDIF
+
+ END SUBROUTINE hist_vector_write_time
+
+
+ SUBROUTINE aggregate_to_vector_and_write_2d ( &
+ acc_vec_patch, file_hist, varname, itime_in_file, filter, &
+ longname, units, input_mode)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_LandPatch
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: acc_vec_patch (:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ logical, intent(in) :: filter(:)
+
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ character(len=*), intent(in), optional :: input_mode
+
+ ! Local variables
+ integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress
+ logical, allocatable :: mask(:)
+ real(r8), allocatable :: frac(:)
+ real(r8), allocatable :: acc_vec(:), rcache(:)
+ real(r8) :: sumwt
+ character(len=256) :: inmode
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_compute) THEN
+#ifdef CATCHMENT
+ numset = numhru
+#else
+ numset = numelm
+#endif
+
+ inmode = 'average'
+ IF (present(input_mode)) inmode = trim(input_mode)
+
+ IF (numset > 0) THEN
+
+ allocate (acc_vec (numset))
+ acc_vec(:) = spval
+
+ DO iset = 1, numset
+#ifdef CATCHMENT
+ istt = hru_patch%substt(iset)
+ iend = hru_patch%subend(iset)
+#else
+ istt = elm_patch%substt(iset)
+ iend = elm_patch%subend(iset)
+#endif
+
+ IF ((istt > 0) .and. (iend >= istt)) THEN
+ allocate (mask(istt:iend))
+ allocate (frac(istt:iend))
+ mask = (acc_vec_patch(istt:iend) /= spval) .and. filter(istt:iend)
+ IF (any(mask)) THEN
+ IF (trim(inmode) == 'average') THEN
+#ifdef CATCHMENT
+ frac = hru_patch%subfrc(istt:iend)
+#else
+ frac = elm_patch%subfrc(istt:iend)
+#endif
+ sumwt = sum(frac, mask = mask)
+ acc_vec(iset) = sum(frac * acc_vec_patch(istt:iend), mask = mask)
+ acc_vec(iset) = acc_vec(iset) / sumwt
+ ELSE
+ acc_vec(iset) = sum(acc_vec_patch(istt:iend), mask = mask)
+ ENDIF
+ ENDIF
+ deallocate(mask)
+ deallocate(frac)
+ ENDIF
+ ENDDO
+ ENDIF
+
+#ifdef USEMPI
+ mesg = (/p_iam_glb, numset/)
+ CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ IF (numset > 0) THEN
+ CALL mpi_send (acc_vec, numset, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+#endif
+ ENDIF
+
+ IF (p_is_root) THEN
+
+#ifdef CATCHMENT
+ totalnumset = totalnumhru
+#else
+ totalnumset = totalnumelm
+#endif
+
+ IF (.not. allocated(acc_vec)) THEN
+ allocate (acc_vec (totalnumset))
+ ENDIF
+
+#ifdef USEMPI
+ DO iwork = 0, p_np_compute-1
+ CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = mesg(1)
+ ndata = mesg(2)
+ IF (ndata > 0) THEN
+ allocate(rcache (ndata))
+ CALL mpi_recv (rcache, ndata, MPI_REAL8, isrc, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+#ifdef CATCHMENT
+ acc_vec(hru_data_address(p_itis_compute(isrc))%val) = rcache
+#else
+ acc_vec(elm_data_address(p_itis_compute(isrc))%val) = rcache
+#endif
+
+ deallocate (rcache)
+ ENDIF
+ ENDDO
+#else
+#ifdef CATCHMENT
+ acc_vec(hru_data_address(0)%val) = acc_vec
+#else
+ acc_vec(elm_data_address(0)%val) = acc_vec
+#endif
+#endif
+ ENDIF
+
+ IF (p_is_root) THEN
+
+ compress = DEF_HIST_CompressLevel
+
+ IF (itime_in_file >= 1) THEN
+#ifdef CATCHMENT
+ CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, &
+ 'hydrounit', 'time', compress)
+#else
+ CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, &
+ 'element', 'time', compress)
+#endif
+ ELSE
+#ifdef CATCHMENT
+ CALL ncio_write_serial (file_hist, varname, acc_vec, 'hydrounit', compress)
+#else
+ CALL ncio_write_serial (file_hist, varname, acc_vec, 'element', compress)
+#endif
+ ENDIF
+
+ IF (itime_in_file <= 1) THEN
+ CALL ncio_put_attr (file_hist, varname, 'long_name', longname)
+ CALL ncio_put_attr (file_hist, varname, 'units', units)
+ CALL ncio_put_attr (file_hist, varname, 'missing_value', spval)
+ ENDIF
+
+ ENDIF
+
+ IF (allocated(acc_vec)) deallocate (acc_vec)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ END SUBROUTINE aggregate_to_vector_and_write_2d
+
+
+ SUBROUTINE aggregate_to_vector_and_write_3d ( &
+ acc_vec_patch, file_hist, varname, itime_in_file, dim1name, lb1, ndim1, filter, &
+ longname, units)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_LandPatch
+ USE MOD_Vars_1DAccFluxes, only: nac
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: acc_vec_patch (lb1:,:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: dim1name
+ integer, intent(in) :: lb1, ndim1
+
+ logical, intent(in) :: filter(:)
+
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ ! Local variables
+ integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress
+ integer :: ub1, i1
+ logical, allocatable :: mask(:)
+ real(r8), allocatable :: frac(:)
+ real(r8), allocatable :: acc_vec(:,:), rcache(:,:)
+ real(r8) :: sumwt
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ ub1 = lb1 + ndim1 - 1
+
+ IF (p_is_compute) THEN
+#ifdef CATCHMENT
+ numset = numhru
+#else
+ numset = numelm
+#endif
+
+ IF (numset > 0) THEN
+
+ allocate (acc_vec (lb1:ub1,numset))
+
+ acc_vec(:,:) = spval
+
+ DO iset = 1, numset
+#ifdef CATCHMENT
+ istt = hru_patch%substt(iset)
+ iend = hru_patch%subend(iset)
+#else
+ istt = elm_patch%substt(iset)
+ iend = elm_patch%subend(iset)
+#endif
+
+ IF ((istt > 0) .and. (iend >= istt)) THEN
+ allocate (mask(istt:iend))
+ allocate (frac(istt:iend))
+ DO i1 = lb1, ub1
+ mask = (acc_vec_patch(i1,istt:iend) /= spval) .and. filter(istt:iend)
+ IF (any(mask)) THEN
+#ifdef CATCHMENT
+ frac = hru_patch%subfrc(istt:iend)
+#else
+ frac = elm_patch%subfrc(istt:iend)
+#endif
+ sumwt = sum(frac, mask = mask)
+ acc_vec(i1,iset) = sum(frac * acc_vec_patch(i1,istt:iend), mask = mask)
+ acc_vec(i1,iset) = acc_vec(i1,iset) / sumwt / nac
+ ENDIF
+ ENDDO
+ deallocate(mask)
+ deallocate(frac)
+ ENDIF
+ ENDDO
+ ENDIF
+
+#ifdef USEMPI
+ mesg = (/p_iam_glb, numset/)
+ CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ IF (numset > 0) THEN
+ CALL mpi_send (acc_vec, ndim1 * numset, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+#endif
+ ENDIF
+
+ IF (p_is_root) THEN
+
+#ifdef CATCHMENT
+ totalnumset = totalnumhru
+#else
+ totalnumset = totalnumelm
+#endif
+
+ IF (.not. allocated(acc_vec)) THEN
+ allocate (acc_vec (ndim1,totalnumset))
+ ENDIF
+
+#ifdef USEMPI
+ DO iwork = 0, p_np_compute-1
+ CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = mesg(1)
+ ndata = mesg(2)
+ IF (ndata > 0) THEN
+ allocate(rcache (ndim1,ndata))
+ CALL mpi_recv (rcache, ndim1*ndata, MPI_REAL8, isrc, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ DO i1 = 1, ndim1
+#ifdef CATCHMENT
+ acc_vec(i1,hru_data_address(p_itis_compute(isrc))%val) = rcache(i1,:)
+#else
+ acc_vec(i1,elm_data_address(p_itis_compute(isrc))%val) = rcache(i1,:)
+#endif
+
+ ENDDO
+
+ deallocate (rcache)
+ ENDIF
+ ENDDO
+#else
+ DO i1 = lb1, ub1
+#ifdef CATCHMENT
+ acc_vec(i1,hru_data_address(0)%val) = acc_vec(i1,:)
+#else
+ acc_vec(i1,elm_data_address(0)%val) = acc_vec(i1,:)
+#endif
+ ENDDO
+#endif
+ ENDIF
+
+ IF (p_is_root) THEN
+
+ CALL ncio_define_dimension (file_hist, dim1name, ndim1)
+
+ compress = DEF_HIST_CompressLevel
+
+ IF (itime_in_file >= 1) THEN
+#ifdef CATCHMENT
+ CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, &
+ dim1name, 'hydrounit', 'time', compress)
+#else
+ CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, &
+ dim1name, 'element', 'time', compress)
+#endif
+ ELSE
+#ifdef CATCHMENT
+ CALL ncio_write_serial (file_hist, varname, acc_vec, &
+ dim1name, 'hydrounit', compress)
+#else
+ CALL ncio_write_serial (file_hist, varname, acc_vec, &
+ dim1name, 'element', compress)
+#endif
+ ENDIF
+
+ IF (itime_in_file <= 1) THEN
+ CALL ncio_put_attr (file_hist, varname, 'long_name', longname)
+ CALL ncio_put_attr (file_hist, varname, 'units', units)
+ CALL ncio_put_attr (file_hist, varname, 'missing_value', spval)
+ ENDIF
+
+ ENDIF
+
+ IF (allocated(acc_vec)) deallocate (acc_vec)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ END SUBROUTINE aggregate_to_vector_and_write_3d
+
+
+ SUBROUTINE aggregate_to_vector_and_write_4d ( &
+ acc_vec_patch, file_hist, varname, itime_in_file, &
+ dim1name, lb1, ndim1, dim2name, lb2, ndim2, filter, &
+ longname, units)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_LandPatch
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: acc_vec_patch (lb1:,lb2:,:)
+ character(len=*), intent(in) :: file_hist
+ character(len=*), intent(in) :: varname
+ integer, intent(in) :: itime_in_file
+ character(len=*), intent(in) :: dim1name, dim2name
+ integer, intent(in) :: lb1, ndim1, lb2, ndim2
+
+ logical, intent(in) :: filter(:)
+
+ character(len=*), intent(in) :: longname
+ character(len=*), intent(in) :: units
+
+ ! Local variables
+ integer :: numset, totalnumset, iset, istt, iend, iwork, mesg(2), isrc, ndata, compress
+ integer :: ub1, i1, ub2, i2
+ logical, allocatable :: mask(:)
+ real(r8), allocatable :: frac(:)
+ real(r8), allocatable :: acc_vec(:,:,:), rcache(:,:,:)
+ real(r8) :: sumwt
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ ub1 = lb1 + ndim1 - 1
+ ub2 = lb2 + ndim2 - 1
+
+ IF (p_is_compute) THEN
+#ifdef CATCHMENT
+ numset = numhru
+#else
+ numset = numelm
+#endif
+
+ IF (numset > 0) THEN
+
+ allocate (acc_vec (lb1:ub1,lb2:ub2,numset))
+
+ acc_vec(:,:,:) = spval
+
+ DO iset = 1, numset
+#ifdef CATCHMENT
+ istt = hru_patch%substt(iset)
+ iend = hru_patch%subend(iset)
+#else
+ istt = elm_patch%substt(iset)
+ iend = elm_patch%subend(iset)
+#endif
+
+ IF ((istt > 0) .and. (iend >= istt)) THEN
+ allocate (mask(istt:iend))
+ allocate (frac(istt:iend))
+ DO i1 = lb1, ub1
+ DO i2 = lb2, ub2
+ mask = (acc_vec_patch(i1,i2,istt:iend) /= spval) .and. filter(istt:iend)
+ IF (any(mask)) THEN
+#ifdef CATCHMENT
+ frac = hru_patch%subfrc(istt:iend)
+#else
+ frac = elm_patch%subfrc(istt:iend)
+#endif
+ sumwt = sum(frac, mask = mask)
+ acc_vec(i1,i2,iset) = sum(frac * acc_vec_patch(i1,i2,istt:iend), mask = mask)
+ acc_vec(i1,i2,iset) = acc_vec(i1,i2,iset) / sumwt
+ ENDIF
+ ENDDO
+ ENDDO
+ deallocate(mask)
+ deallocate(frac)
+ ENDIF
+ ENDDO
+ ENDIF
+
+#ifdef USEMPI
+ mesg = (/p_iam_glb, numset/)
+ CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ IF (numset > 0) THEN
+ CALL mpi_send (acc_vec, ndim1 * ndim2 * numset, MPI_REAL8, &
+ p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+#endif
+ ENDIF
+
+ IF (p_is_root) THEN
+
+#ifdef CATCHMENT
+ totalnumset = totalnumhru
+#else
+ totalnumset = totalnumelm
+#endif
+
+ IF (.not. allocated(acc_vec)) THEN
+ allocate (acc_vec (ndim1,ndim2,totalnumset))
+ ENDIF
+
+#ifdef USEMPI
+ DO iwork = 0, p_np_compute-1
+ CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = mesg(1)
+ ndata = mesg(2)
+ IF (ndata > 0) THEN
+ allocate(rcache (ndim1,ndim2,ndata))
+ CALL mpi_recv (rcache, ndim1 * ndim2 * ndata, MPI_REAL8, isrc, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ DO i1 = 1, ndim1
+ DO i2 = 1, ndim2
+#ifdef CATCHMENT
+ acc_vec(i1,i2,hru_data_address(p_itis_compute(isrc))%val) = rcache(i1,i2,:)
+#else
+ acc_vec(i1,i2,elm_data_address(p_itis_compute(isrc))%val) = rcache(i1,i2,:)
+#endif
+ ENDDO
+ ENDDO
+
+ deallocate (rcache)
+ ENDIF
+ ENDDO
+#else
+ DO i1 = lb1, ub1
+ DO i2 = lb2, ub2
+#ifdef CATCHMENT
+ acc_vec(i1,i2,hru_data_address(0)%val) = acc_vec(i1,i2,:)
+#else
+ acc_vec(i1,i2,elm_data_address(0)%val) = acc_vec(i1,i2,:)
+#endif
+ ENDDO
+ ENDDO
+#endif
+ ENDIF
+
+ IF (p_is_root) THEN
+
+ CALL ncio_define_dimension (file_hist, dim1name, ndim1)
+ CALL ncio_define_dimension (file_hist, dim2name, ndim2)
+
+ compress = DEF_HIST_CompressLevel
+
+ IF (itime_in_file >= 1) THEN
+#ifdef CATCHMENT
+ CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, &
+ dim1name, dim2name, 'hydrounit', 'time', compress)
+#else
+ CALL ncio_write_serial_time (file_hist, varname, itime_in_file, acc_vec, &
+ dim1name, dim2name, 'element', 'time', compress)
+#endif
+ ELSE
+#ifdef CATCHMENT
+ CALL ncio_write_serial (file_hist, varname, acc_vec, &
+ dim1name, dim2name, 'hydrounit', compress)
+#else
+ CALL ncio_write_serial (file_hist, varname, acc_vec, &
+ dim1name, dim2name, 'element', compress)
+#endif
+ ENDIF
+
+ IF (itime_in_file <= 1) THEN
+ CALL ncio_put_attr (file_hist, varname, 'long_name', longname)
+ CALL ncio_put_attr (file_hist, varname, 'units', units)
+ CALL ncio_put_attr (file_hist, varname, 'missing_value', spval)
+ ENDIF
+
+ ENDIF
+
+ IF (allocated(acc_vec)) deallocate (acc_vec)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ END SUBROUTINE aggregate_to_vector_and_write_4d
+
+
+END MODULE MOD_HistVector
+#endif
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90
new file mode 100644
index 0000000000..05397d1516
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_HistWriteBack.F90
@@ -0,0 +1,743 @@
+#include
+
+#ifdef USEMPI
+MODULE MOD_HistWriteBack
+!----------------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Write out data to history files by a dedicated process.
+!
+! Author: Shupeng Zhang, 11/2023
+!----------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+
+ ! type of send buffer
+ type :: HistSendBufferType
+ integer :: dataid
+ integer :: datatag
+ integer :: sendreqs (3)
+ integer :: sendint4 (5)
+ character(len=256) :: sendchar (9)
+ real(r8), allocatable :: senddata (:)
+ type(HistSendBufferType), pointer :: next
+ END type HistSendBufferType
+
+ ! Sending Variables
+ type(HistSendBufferType), pointer :: HistSendBuffer
+ type(HistSendBufferType), pointer :: LastSendBuffer
+
+ ! type of times
+ type :: timenodetype
+ character(len=256) :: filename
+ character(len=256) :: filelast
+ character(len=256) :: timename
+ integer :: time(3)
+ integer :: req (4)
+ type(timenodetype), pointer :: next
+ END type timenodetype
+
+ ! time nodes
+ integer :: dataid_zero = 0
+ integer :: req_zero
+ type(timenodetype), pointer :: timenodes, lasttime
+
+ ! dimension information
+ logical :: SDimInited = .false.
+
+ ! 1: grid-based
+ integer :: nGridData, nxGridSeg, nyGridSeg
+ integer, allocatable :: xGridDsp(:), xGridCnt(:)
+ integer, allocatable :: yGridDsp(:), yGridCnt(:)
+
+ integer :: nlat, nlon
+ real(r8), allocatable :: lat_c(:), lat_s(:), lat_n(:)
+ real(r8), allocatable :: lon_c(:), lon_w(:), lon_e(:)
+
+ ! Memory limits
+ integer*8, parameter :: MaxHistMemSize = 1073741824_8 ! 1024^3
+ integer*8 :: TotalMemSize = 0
+
+ integer :: itime_in_file_wb
+
+ ! tags
+ integer, parameter :: tag_next = 1
+ integer, parameter :: tag_time = 2
+ integer, parameter :: tag_dims = 3
+
+CONTAINS
+
+ SUBROUTINE hist_writeback_daemon ()
+
+ USE MOD_Namelist, only: DEF_HIST_FREQ
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ ! Local Variables
+ integer :: dataid, tag
+ integer :: time(3), ndims, ndim1, ndim2, dimlens(4), compress
+ integer :: i, idata, isrc, ixseg, iyseg, xdsp, ydsp, xcnt, ycnt, idim1, idim2
+
+ integer :: recvint4 (5)
+ character(len=256) :: recvchar (9)
+ real(r8), allocatable :: datathis (:)
+
+ character(len=256) :: filename, filelast, dataname, longname, units
+ character(len=256) :: dim1name, dim2name, dim3name, dim4name, dim5name
+ logical :: fexists
+
+ real(r8), allocatable :: wdata1d(:), wdata2d(:,:), wdata3d(:,:,:), wdata4d(:,:,:,:)
+ real(r8), allocatable :: tmp3d(:,:,:), tmp4d(:,:,:,:)
+
+
+ DO WHILE (.true.)
+
+ CALL mpi_recv (dataid, 1, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_next, p_comm_glb_plus, p_stat, p_err)
+
+ IF (dataid < 0) THEN
+
+ EXIT
+
+ ELSEIF (dataid == 0) THEN
+
+ CALL mpi_recv (filename, 256, MPI_CHARACTER, &
+ MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err)
+
+ CALL mpi_recv (filelast, 256, MPI_CHARACTER, &
+ MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err)
+
+ CALL mpi_recv (dataname, 256, MPI_CHARACTER, &
+ MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err)
+
+ CALL mpi_recv (time, 3, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_time, p_comm_glb_plus, p_stat, p_err)
+
+ IF (.not. SDimInited) THEN
+
+ CALL mpi_recv (nGridData, 1, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+ CALL mpi_recv (nxGridSeg, 1, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+ CALL mpi_recv (nyGridSeg, 1, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+
+ allocate (xGridDsp (nxGridSeg))
+ allocate (xGridCnt (nxGridSeg))
+ allocate (yGridDsp (nyGridSeg))
+ allocate (yGridCnt (nyGridSeg))
+
+ CALL mpi_recv (xGridDsp, nxGridSeg, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+ CALL mpi_recv (xGridCnt, nxGridSeg, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+ CALL mpi_recv (yGridDsp, nyGridSeg, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+ CALL mpi_recv (yGridCnt, nyGridSeg, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+
+ CALL mpi_recv (nlat, 1, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+
+ allocate(lat_c(nlat))
+ allocate(lat_s(nlat))
+ allocate(lat_n(nlat))
+
+ CALL mpi_recv (lat_c, nlat, MPI_REAL8, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+ CALL mpi_recv (lat_s, nlat, MPI_REAL8, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+ CALL mpi_recv (lat_n, nlat, MPI_REAL8, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+
+ CALL mpi_recv (nlon, 1, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+
+ allocate(lon_c(nlon))
+ allocate(lon_w(nlon))
+ allocate(lon_e(nlon))
+
+ CALL mpi_recv (lon_c, nlon, MPI_REAL8, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+ CALL mpi_recv (lon_w, nlon, MPI_REAL8, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+ CALL mpi_recv (lon_e, nlon, MPI_REAL8, &
+ MPI_ANY_SOURCE, tag_dims, p_comm_glb_plus, p_stat, p_err)
+
+ SDimInited = .true.
+
+ ENDIF
+
+ inquire (file=filename, exist=fexists)
+ IF ((.not. fexists) .or. (trim(filename) /= trim(filelast))) THEN
+
+ CALL ncio_create_file (trim(filename))
+
+ CALL ncio_define_dimension(filename, 'time', 0)
+
+ CALL ncio_define_dimension(filename, 'lat', nlat)
+ CALL ncio_define_dimension(filename, 'lon', nlon)
+
+ CALL ncio_write_serial (filename, 'lat', lat_c, 'lat')
+ CALL ncio_write_serial (filename, 'lon', lon_c, 'lon')
+ CALL ncio_write_serial (filename, 'lat_s', lat_s, 'lat')
+ CALL ncio_write_serial (filename, 'lat_n', lat_n, 'lat')
+ CALL ncio_write_serial (filename, 'lon_w', lon_w, 'lon')
+ CALL ncio_write_serial (filename, 'lon_e', lon_e, 'lon')
+
+ CALL ncio_put_attr (filename, 'lat', 'long_name', 'latitude')
+ CALL ncio_put_attr (filename, 'lat', 'units', 'degrees_north')
+ CALL ncio_put_attr (filename, 'lon', 'long_name', 'longitude')
+ CALL ncio_put_attr (filename, 'lon', 'units', 'degrees_east')
+
+ CALL ncio_write_colm_dimension (filename)
+
+ ENDIF
+
+ CALL ncio_write_time (filename, dataname, time, itime_in_file_wb, DEF_HIST_FREQ)
+
+ ELSE
+
+ !--------------------------------
+ ! receive and write history data.
+ !--------------------------------
+
+ ! (1) data header
+ tag = dataid*10
+ CALL mpi_recv (recvint4(1:2), 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, tag, p_comm_glb_plus, p_stat, p_err)
+
+ ndims = recvint4(1)
+ compress = recvint4(2)
+
+ CALL mpi_recv (recvchar(1:9), 256*9, MPI_CHARACTER, &
+ MPI_ANY_SOURCE, tag, p_comm_glb_plus, p_stat, p_err)
+
+ filename = recvchar(1)
+ dataname = recvchar(2)
+ dim1name = recvchar(3)
+ dim2name = recvchar(4)
+ dim3name = recvchar(5)
+ dim4name = recvchar(6)
+ dim5name = recvchar(7)
+ longname = recvchar(8)
+ units = recvchar(9)
+
+ ! (2) data
+ tag = dataid*10+1
+
+ DO idata = 1, nGridData
+
+ CALL mpi_recv (recvint4(1:5), 5, MPI_INTEGER, MPI_ANY_SOURCE, &
+ tag, p_comm_glb_plus, p_stat, p_err)
+
+ isrc = recvint4(1)
+ ixseg = recvint4(2)
+ iyseg = recvint4(3)
+ ndim1 = recvint4(4)
+ ndim2 = recvint4(5)
+
+ xdsp = xGridDsp(ixseg)
+ ydsp = yGridDsp(iyseg)
+ xcnt = xGridCnt(ixseg)
+ ycnt = yGridCnt(iyseg)
+
+ SELECTCASE (ndims)
+ CASE (2:3)
+
+ dimlens = (/nlon, nlat, 0, 0/)
+
+ IF (.not. allocated(wdata2d)) THEN
+ allocate (wdata2d (nlon,nlat))
+ ENDIF
+
+ allocate (datathis(xcnt*ycnt))
+ CALL mpi_recv (datathis, xcnt*ycnt, MPI_REAL8, &
+ isrc, tag, p_comm_glb_plus, p_stat, p_err)
+
+ wdata2d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt) = &
+ reshape(datathis,(/xcnt,ycnt/))
+
+ CASE (4)
+
+ dimlens = (/ndim1, nlon, nlat, 0/)
+
+ IF (.not. allocated(wdata3d)) THEN
+ allocate (wdata3d (nlon,nlat,ndim1))
+ allocate (tmp3d (ndim1,nlon,nlat))
+ ENDIF
+
+ allocate (datathis(ndim1*xcnt*ycnt))
+ CALL mpi_recv (datathis, ndim1*xcnt*ycnt, MPI_REAL8, &
+ isrc, tag, p_comm_glb_plus, p_stat, p_err)
+
+ tmp3d = reshape(datathis,(/ndim1,xcnt,ycnt/))
+ DO idim1 = 1, ndim1
+ wdata3d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt, idim1) = tmp3d(idim1, :, :)
+ ENDDO
+
+ CASE (5)
+
+ dimlens = (/ndim1, ndim2, nlon, nlat/)
+
+ IF (.not. allocated(wdata4d)) THEN
+ allocate (wdata4d (nlon,nlat,ndim1,ndim2))
+ allocate (tmp4d (ndim1,ndim2,nlon,nlat))
+ ENDIF
+
+ allocate (datathis(ndim1*ndim2*xcnt*ycnt))
+ CALL mpi_recv (datathis, ndim1*ndim2*xcnt*ycnt, MPI_REAL8, &
+ isrc, tag, p_comm_glb_plus, p_stat, p_err)
+
+ tmp4d = reshape(datathis,(/ndim1, ndim2, xcnt, ycnt/))
+
+ DO idim1 = 1, ndim1
+ DO idim2 = 1, ndim2
+ wdata4d(xdsp+1:xdsp+xcnt, ydsp+1:ydsp+ycnt, idim1, idim2) = &
+ tmp4d(idim1, idim2, :, :)
+ ENDDO
+ ENDDO
+
+ ENDSELECT
+
+ deallocate (datathis)
+
+ ENDDO
+
+
+ IF (ndims >= 4) CALL ncio_define_dimension (filename, dim3name, dimlens(1))
+ IF (ndims >= 5) CALL ncio_define_dimension (filename, dim4name, dimlens(2))
+
+ SELECTCASE (ndims)
+ CASE (2) ! for variables with [lon,lat]
+
+ CALL ncio_write_serial (filename, dataname, wdata2d, dim1name, dim2name, compress)
+
+ deallocate(wdata2d)
+ CASE (3) ! for variables with [lon,lat,time]
+
+ CALL ncio_write_serial_time (filename, dataname, itime_in_file_wb, wdata2d, &
+ dim1name, dim2name, dim3name, compress)
+
+ deallocate(wdata2d)
+ CASE (4) ! for variables with [lon,lat,dim3,time]
+
+ CALL ncio_write_serial_time (filename, dataname, itime_in_file_wb, wdata3d, &
+ dim1name, dim2name, dim3name, dim4name, compress)
+
+ deallocate(tmp3d )
+ deallocate(wdata3d)
+ CASE (5) ! for variables with [lon,lat,dim3,dim4,time]
+
+ CALL ncio_write_serial_time (filename, dataname, itime_in_file_wb, wdata4d, &
+ dim1name, dim2name, dim3name, dim4name, dim5name, compress)
+
+ deallocate(tmp4d )
+ deallocate(wdata4d)
+ ENDSELECT
+
+ IF (itime_in_file_wb <= 1) THEN
+ CALL ncio_put_attr (filename, dataname, 'long_name', longname)
+ CALL ncio_put_attr (filename, dataname, 'units', units)
+ CALL ncio_put_attr (filename, dataname, 'missing_value', spval)
+ ENDIF
+
+ write(*,'(3A,I0,2A)') 'HIST WriteBack: ', trim(basename(filename)), &
+ ' (time ', itime_in_file_wb, '): ', trim(dataname)
+
+ ENDIF
+
+ ENDDO
+
+ END SUBROUTINE hist_writeback_daemon
+
+ ! -----
+ SUBROUTINE hist_writeback_latlon_time (filename, filelast, timename, time, HistConcat)
+
+ USE MOD_Namelist
+ USE MOD_Grid
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: filename
+ character (len=*), intent(in) :: filelast
+ character (len=*), intent(in) :: timename
+ integer, intent(in) :: time(3)
+ type(grid_concat_type), intent(in) :: HistConcat
+
+ ! Local Variables
+ integer :: i
+ logical :: senddone
+ integer :: sendstat(MPI_STATUS_SIZE,4)
+ type(timenodetype), pointer :: tempnode
+
+ IF (.not. associated(timenodes)) THEN
+ allocate (timenodes)
+ lasttime => timenodes
+ ELSE
+ allocate (lasttime%next)
+ lasttime => lasttime%next
+ ENDIF
+
+ lasttime%filename = filename
+ lasttime%filelast = filelast
+ lasttime%timename = timename
+ lasttime%time = time
+ lasttime%next => null()
+
+ CALL mpi_isend (dataid_zero, 1, MPI_INTEGER, &
+ p_address_history_task, tag_next, p_comm_glb_plus, req_zero, p_err)
+
+ CALL mpi_isend (lasttime%filename, 256, MPI_CHARACTER, &
+ p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(1), p_err)
+
+ CALL mpi_isend (lasttime%filelast, 256, MPI_CHARACTER, &
+ p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(2), p_err)
+
+ CALL mpi_isend (lasttime%timename, 256, MPI_CHARACTER, &
+ p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(3), p_err)
+
+ CALL mpi_isend (lasttime%time, 3, MPI_INTEGER, &
+ p_address_history_task, tag_time, p_comm_glb_plus, lasttime%req(4), p_err)
+
+
+ IF (.not. SDimInited) THEN
+
+ nGridData = HistConcat%ndatablk
+ nxGridSeg = HistConcat%nxseg
+ nyGridSeg = HistConcat%nyseg
+
+ allocate (xGridDsp (nxGridSeg))
+ allocate (xGridCnt (nxGridSeg))
+ allocate (yGridDsp (nyGridSeg))
+ allocate (yGridCnt (nyGridSeg))
+
+ DO i = 1, nxGridSeg
+ xGridDsp(i) = HistConcat%xsegs(i)%gdsp
+ xGridCnt(i) = HistConcat%xsegs(i)%cnt
+ ENDDO
+
+ DO i = 1, nyGridSeg
+ yGridDsp(i) = HistConcat%ysegs(i)%gdsp
+ yGridCnt(i) = HistConcat%ysegs(i)%cnt
+ ENDDO
+
+ CALL mpi_send (nGridData, 1, MPI_INTEGER, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (nxGridSeg, 1, MPI_INTEGER, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (nyGridSeg, 1, MPI_INTEGER, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+
+ CALL mpi_send (xGridDsp, nxGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (xGridCnt, nxGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (yGridDsp, nyGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (yGridCnt, nyGridSeg, MPI_INTEGER, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+
+ nlat = HistConcat%ginfo%nlat
+ nlon = HistConcat%ginfo%nlon
+ allocate(lat_c(nlat)); lat_c = HistConcat%ginfo%lat_c
+ allocate(lat_s(nlat)); lat_s = HistConcat%ginfo%lat_s
+ allocate(lat_n(nlat)); lat_n = HistConcat%ginfo%lat_n
+ allocate(lon_c(nlon)); lon_c = HistConcat%ginfo%lon_c
+ allocate(lon_w(nlon)); lon_w = HistConcat%ginfo%lon_w
+ allocate(lon_e(nlon)); lon_e = HistConcat%ginfo%lon_e
+
+ CALL mpi_send (nlat, 1, MPI_INTEGER, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (lat_c, nlat, MPI_REAL8, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (lat_s, nlat, MPI_REAL8, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (lat_n, nlat, MPI_REAL8, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (nlon, 1, MPI_INTEGER, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (lon_c, nlon, MPI_REAL8, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (lon_w, nlon, MPI_REAL8, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+ CALL mpi_send (lon_e, nlon, MPI_REAL8, p_address_history_task, tag_dims, &
+ p_comm_glb_plus, p_err)
+
+ SDimInited = .true.
+
+ ENDIF
+
+ DO WHILE (associated(timenodes%next))
+
+ CALL MPI_TestAll (4, timenodes%req, senddone, sendstat(:,1:4), p_err)
+
+ IF (senddone) THEN
+ tempnode => timenodes
+ timenodes => timenodes%next
+ deallocate(tempnode)
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+
+ END SUBROUTINE hist_writeback_latlon_time
+
+ ! -----
+ SUBROUTINE hist_writeback_var_header (dataid, filename, dataname, &
+ ndims, dim1name, dim2name, dim3name, dim4name, dim5name, &
+ compress, longname, units)
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: dataid
+ character(len=*), intent(in) :: filename, dataname
+ integer, intent(in) :: ndims
+ character(len=*), intent(in) :: dim1name, dim2name, dim3name, dim4name, dim5name
+ integer, intent(in) :: compress
+ character(len=*), intent(in) :: longname, units
+
+ ! Local Variables
+ logical :: senddone
+ integer :: sendstat(MPI_STATUS_SIZE,3)
+ type(HistSendBufferType), pointer :: TempSendBuffer
+
+ ! append sending buffer
+ IF (.not. associated(HistSendBuffer)) THEN
+ allocate (HistSendBuffer)
+ LastSendBuffer => HistSendBuffer
+ ELSE
+ allocate (LastSendBuffer%next)
+ LastSendBuffer => LastSendBuffer%next
+ ENDIF
+
+ LastSendBuffer%next => null()
+
+ ! clean sending buffer and free memory
+ DO WHILE (associated(HistSendBuffer%next))
+
+ CALL MPI_Testall (3, HistSendBuffer%sendreqs, senddone, sendstat(:,1:3), p_err)
+
+ IF (senddone) THEN
+
+ TempSendBuffer => HistSendBuffer
+ HistSendBuffer => HistSendBuffer%next
+
+ IF (allocated(TempSendBuffer%senddata)) THEN
+ deallocate (TempSendBuffer%senddata)
+ ENDIF
+ deallocate (TempSendBuffer)
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+
+ LastSendBuffer%dataid = dataid
+ LastSendBuffer%datatag = dataid*10
+
+ LastSendBuffer%sendint4(1:2) = (/ndims, compress/)
+
+ LastSendBuffer%sendchar(1) = filename
+ LastSendBuffer%sendchar(2) = dataname
+ LastSendBuffer%sendchar(3) = dim1name
+ LastSendBuffer%sendchar(4) = dim2name
+ LastSendBuffer%sendchar(5) = dim3name
+ LastSendBuffer%sendchar(6) = dim4name
+ LastSendBuffer%sendchar(7) = dim5name
+ LastSendBuffer%sendchar(8) = longname
+ LastSendBuffer%sendchar(9) = units
+
+ CALL mpi_isend (LastSendBuffer%dataid, 1, MPI_INTEGER, &
+ p_address_history_task, tag_next, p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err)
+
+ CALL mpi_isend (LastSendBuffer%sendint4(1:2), 2, MPI_INTEGER, &
+ p_address_history_task, LastSendBuffer%datatag, &
+ p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err)
+
+ CALL mpi_isend (LastSendBuffer%sendchar, 256*9, MPI_CHARACTER, &
+ p_address_history_task, LastSendBuffer%datatag, &
+ p_comm_glb_plus, LastSendBuffer%sendreqs(3), p_err)
+
+ END SUBROUTINE hist_writeback_var_header
+
+ ! -----
+ SUBROUTINE hist_writeback_var ( dataid, ixseg, iyseg, &
+ wdata1d, wdata2d, wdata3d, wdata4d)
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: dataid, ixseg, iyseg
+
+ real(r8), intent(in), optional :: wdata1d(:)
+ real(r8), intent(in), optional :: wdata2d(:,:)
+ real(r8), intent(in), optional :: wdata3d(:,:,:)
+ real(r8), intent(in), optional :: wdata4d(:,:,:,:)
+
+ ! Local Variables
+ integer :: totalsize, ndim1, ndim2
+ logical :: senddone
+ integer :: sendstat(MPI_STATUS_SIZE,2)
+ type(HistSendBufferType), pointer :: TempSendBuffer
+
+ ! append sending buffer
+ IF (.not. associated(HistSendBuffer)) THEN
+ allocate (HistSendBuffer)
+ LastSendBuffer => HistSendBuffer
+ TotalMemSize = 0
+ ELSE
+ allocate (LastSendBuffer%next)
+ LastSendBuffer => LastSendBuffer%next
+ ENDIF
+
+ LastSendBuffer%next => null()
+
+ ! clean sending buffer and free memory
+ DO WHILE (associated(HistSendBuffer%next))
+
+ IF (TotalMemSize > MaxHistMemSize) THEN
+ CALL MPI_Waitall (2, HistSendBuffer%sendreqs(1:2), sendstat(:,1:2), p_err)
+ ELSE
+ CALL MPI_Testall (2, HistSendBuffer%sendreqs(1:2), senddone, sendstat(:,1:2), p_err)
+ IF (.not. senddone) EXIT
+ ENDIF
+
+ TotalMemSize = TotalMemSize - size(HistSendBuffer%senddata)
+
+ TempSendBuffer => HistSendBuffer
+ HistSendBuffer => HistSendBuffer%next
+ deallocate(TempSendBuffer%senddata)
+ deallocate(TempSendBuffer)
+
+ ENDDO
+
+ LastSendBuffer%datatag = dataid*10+1
+
+ ndim1 = 0
+ ndim2 = 0
+
+ IF (present(wdata2d)) THEN
+
+ totalsize = size(wdata2d)
+ allocate(LastSendBuffer%senddata(totalsize))
+ LastSendBuffer%senddata = reshape(wdata2d, (/totalsize/))
+
+ ELSEIF (present(wdata3d)) THEN
+
+ ndim1 = size(wdata3d,1)
+ totalsize = size(wdata3d)
+ allocate(LastSendBuffer%senddata(totalsize))
+ LastSendBuffer%senddata = reshape(wdata3d, (/totalsize/))
+
+ ELSEIF (present(wdata4d)) THEN
+
+ ndim1 = size(wdata4d,1)
+ ndim2 = size(wdata4d,2)
+ totalsize = size(wdata4d)
+ allocate(LastSendBuffer%senddata(totalsize))
+ LastSendBuffer%senddata = reshape(wdata4d, (/totalsize/))
+
+ ENDIF
+
+ TotalMemSize = TotalMemSize + totalsize
+
+ LastSendBuffer%sendint4(1:5) = (/p_iam_glb_plus, ixseg, iyseg, ndim1, ndim2/)
+
+ CALL mpi_isend (LastSendBuffer%sendint4(1:5), 5, MPI_INTEGER, &
+ p_address_history_task, LastSendBuffer%datatag, &
+ p_comm_glb_plus, LastSendBuffer%sendreqs(1), p_err)
+
+ CALL mpi_isend (LastSendBuffer%senddata, totalsize, MPI_REAL8, &
+ p_address_history_task, LastSendBuffer%datatag, &
+ p_comm_glb_plus, LastSendBuffer%sendreqs(2), p_err)
+
+ END SUBROUTINE hist_writeback_var
+
+ ! -----
+ SUBROUTINE hist_writeback_exit ()
+
+ IMPLICIT NONE
+
+ ! Local Variables
+ integer :: dataid, nreq
+ integer :: sendstat(MPI_STATUS_SIZE,4)
+ type(timenodetype), pointer :: tempnode
+ type(HistSendBufferType), pointer :: TempSendBuffer
+
+ lasttime => null()
+ DO WHILE (associated(timenodes))
+
+ CALL MPI_WaitAll (4, timenodes%req, sendstat(:,1:4), p_err)
+
+ tempnode => timenodes
+ timenodes => timenodes%next
+ deallocate(tempnode)
+ ENDDO
+
+ LastSendBuffer => null()
+ DO WHILE (associated(HistSendBuffer))
+
+ IF (allocated(HistSendBuffer%senddata)) THEN
+ CALL MPI_Waitall (2, HistSendBuffer%sendreqs(1:2), sendstat(:,1:2), p_err)
+ deallocate(HistSendBuffer%senddata)
+ ELSE
+ CALL MPI_Waitall (3, HistSendBuffer%sendreqs(1:3), sendstat(:,1:3), p_err)
+ ENDIF
+
+ TempSendBuffer => HistSendBuffer
+ HistSendBuffer => HistSendBuffer%next
+ deallocate (TempSendBuffer)
+
+ ENDDO
+
+ IF (allocated(xGridDsp)) deallocate(xGridDsp)
+ IF (allocated(yGridDsp)) deallocate(yGridDsp)
+ IF (allocated(xGridCnt)) deallocate(xGridCnt)
+ IF (allocated(yGridCnt)) deallocate(yGridCnt)
+ IF (allocated(lat_c )) deallocate(lat_c )
+ IF (allocated(lat_s )) deallocate(lat_s )
+ IF (allocated(lat_n )) deallocate(lat_n )
+ IF (allocated(lon_c )) deallocate(lon_c )
+ IF (allocated(lon_w )) deallocate(lon_w )
+ IF (allocated(lon_e )) deallocate(lon_e )
+
+
+ IF (.not. p_is_history_task) THEN
+ CALL mpi_barrier (p_comm_glb, p_err)
+ ENDIF
+
+ IF (p_is_root) THEN
+ dataid = -1
+ CALL mpi_send (dataid, 1, MPI_INTEGER, p_address_history_task, &
+ tag_next, p_comm_glb_plus, p_err)
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb_plus, p_err)
+
+ END SUBROUTINE hist_writeback_exit
+
+ ! ----
+ character(len=256) FUNCTION basename (fullname)
+
+ IMPLICIT NONE
+ character(len=*), intent(in) :: fullname
+
+ ! Local variables
+ integer :: i, n
+
+ i = len_trim (fullname)
+ DO WHILE (i > 0)
+ IF (fullname(i:i) == '/') EXIT
+ i = i - 1
+ ENDDO
+
+ IF (i > 0) THEN
+ basename = fullname(i+1:)
+ ELSE
+ basename = fullname
+ ENDIF
+
+ END FUNCTION basename
+
+END MODULE MOD_HistWriteBack
+#endif
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..69deecce49
--- /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_SPMD_Task
+ 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..367999943b
--- /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_SPMD_Task
+ 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 (p_is_compute) 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 (p_is_compute) 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..2628092057
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafInterception.F90
@@ -0,0 +1,2458 @@
+#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_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 abort
+ 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 abort
+ 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 abort
+ 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 abort
+ 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 abort
+ 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 abort
+ 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 abort
+ 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 abort
+ 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 abort
+ 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 abort
+ 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 abort
+ 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 abort
+ 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..48a3f61941
--- /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_SPMD_Task
+
+ 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_UserSpecifiedForcing, only: 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 (trim(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 abort
+ 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,p_iam_glb, 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 abort
+ 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..df68a494b7
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_LeafTemperaturePC.F90
@@ -0,0 +1,2145 @@
+#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_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_UserSpecifiedForcing, only: 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 (trim(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 abort
+ 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 abort
+ 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..365fd4e68c
--- /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_SPMD_Task
+ 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..4fcb84bd62
--- /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_SPMD_Task
+ 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 (p_is_active) 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 (p_is_compute .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_SPMD_Task
+ 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 (p_is_active) 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 (p_is_compute .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..21729cfff0
--- /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_SPMD_Task
+ 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 (p_is_compute) THEN
+ allocate(tCONC_O2_UNSAT_tmp (numpatch))
+ allocate(tO2_DECOMP_DEPTH_UNSAT_tmp(numpatch))
+ ENDIF
+
+ IF (p_is_active) 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 (p_is_active) 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 (p_is_compute) 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 (p_is_active) 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 (p_is_compute) 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 (p_is_compute) 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..20904245a8
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Ozone.F90
@@ -0,0 +1,275 @@
+#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_SPMD_Task
+ 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
+ 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
+ USE MOD_RangeCheck
+ 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..a7127f8c58
--- /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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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..f85365c619
--- /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_SPMD_Task
+ 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..32c623c28d
--- /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_SPMD_Task
+ 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..74df71130c
--- /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_SPMD_Task
+
+ 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 (p_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 abort
+ 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 (p_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 abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum
+ CALL abort
+ 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 (p_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 abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "snow_shape = ", snow_shape
+ CALL abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "snicar_atm_type = ", snicar_atm_type
+ CALL abort
+ 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 (p_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 abort
+ 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 (p_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 abort
+ 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 (p_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 abort
+ ENDIF
+ ENDIF
+
+ albout_lcl(bnd_idx) = albedo
+ ! Check that albedo is less than 1
+ IF (p_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 abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min
+ CALL abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "snicar_atm_type = ", snicar_atm_type
+ CALL abort
+ ENDIF
+ ENDIF
+
+ !
+ ! Open optics file:
+ IF (p_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 (p_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 (p_is_root) THEN
+ write(iulog,*) 'Successfully read snow optical properties'
+ ENDIF
+
+
+ ! print some diagnostics:
+ IF (p_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 (p_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 (p_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 (p_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 (p_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 (p_is_root) THEN
+ write(iulog,*) 'Successfully read snow aging properties'
+ ENDIF
+ !
+ ! print some diagnostics:
+ IF (p_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..10dad47088
--- /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_SPMD_Task
+
+ 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 (p_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 abort
+ 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 (p_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 abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "SNICAR ERROR: Energy conservation error of : ", energy_sum
+ CALL abort
+ 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 (p_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 abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "snow_shape = ", snow_shape
+ CALL abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "snicar_atm_type = ", snicar_atm_type
+ CALL abort
+ 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 (p_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 abort
+ 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 (p_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 abort
+ 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 (p_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 abort
+ ENDIF
+ ENDIF
+
+ albout_lcl(bnd_idx) = albedo
+ ! Check that albedo is less than 1
+ IF (p_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 abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "dr_fresh = ", dr_fresh, snw_rds(i), snw_rds_min
+ CALL abort
+ 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 (p_is_root) THEN
+ write(iulog,*) "snicar_atm_type = ", snicar_atm_type
+ CALL abort
+ ENDIF
+ ENDIF
+
+ !
+ ! Open optics file:
+ IF (p_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 (p_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 (p_is_root) THEN
+ write(iulog,*) 'Successfully read snow optical properties'
+ ENDIF
+
+
+ ! print some diagnostics:
+ IF (p_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 (p_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 (p_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 (p_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 (p_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 (p_is_root) THEN
+ write(iulog,*) 'Successfully read snow aging properties'
+ ENDIF
+ !
+ ! print some diagnostics:
+ IF (p_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..bc5571c3d1
--- /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_SPMD_Task
+ 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_UserSpecifiedForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90
new file mode 100644
index 0000000000..692a8a5be6
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_UserSpecifiedForcing.F90
@@ -0,0 +1,969 @@
+#include
+
+MODULE MOD_UserSpecifiedForcing
+
+!DESCRIPTION
+!===========
+ !---This MODULE is used for read atmospheric forcing dataset from various sources.
+ ! ------------------------------------------------------------
+ ! Read forcing data from :
+ ! 1) PRINCETON 2) GSWP2 3) GSWP3
+ ! 4) QIAN 5) CRUNCEPV4 6) CRUNCEPV7
+ ! 7) ERA5LAND 8) ERA5 9) MSWX
+ ! 10) WFDE5 11) CRUJRA 12) WFDEI
+ ! 13) JRA55 14) GDAS 15) CLDAS
+ ! 16) CMFD 17) TPMFD 18) CMIP6
+ ! 19) POINT 20) JRA3Q 21) CRA40
+ !
+ ! PLEASE modify the following codes when specified forcing used
+ ! ------------------------------------------------------------
+!Original Author:
+!-------------------
+ !---Shupeng Zhang and Zhongwang Wei
+
+!References:
+!-------------------
+ !---In preparation
+
+!ANCILLARY FUNCTIONS AND SUBROUTINES
+!-------------------
+ !* :SUBROUTINE:"init_user_specified_forcing" : initialization of the selected forcing dataset
+ !* :SUBROUTINE:"metfilename" : identify the forcing file name
+ !* :SUBROUTINE:"metpreprocess" : preprocess the forcing data
+
+!REVISION HISTORY
+ !----------------
+ ! 2023.05.01 Shupeng Zhang and Zhongwang Wei @ SYSU
+ ! 2021.12.02 Shupeng Zhang and Zhongwang Wei @ SYSU
+ ! Siguang Zhu and Nan Wei, 10/2014: metpreprocess for forc_q calibration
+ ! Hua Yuan, 04/2014: initial code of forcing structure for CoLM2014
+
+ USE MOD_Precision
+
+ IMPLICIT NONE
+
+ character(len=256) :: dataset
+
+ logical :: solarin_all_band ! whether solar radiation in all bands is available
+
+ character(len=256) :: HEIGHT_mode ! observation height mode
+ real(r8) :: HEIGHT_V ! observation height of wind speed
+ real(r8) :: HEIGHT_T ! observation height of air temperature
+ real(r8) :: HEIGHT_Q ! observation height of specific humidity
+
+ integer :: NVAR ! variable number of forcing data
+ integer :: startyr ! start year of forcing data
+ integer :: startmo ! start month of forcing data
+ integer :: endyr ! END year of forcing data
+ integer :: endmo ! END month of forcing data
+
+ integer, allocatable :: dtime(:) ! time interval of forcing data
+ integer, allocatable :: offset(:) ! offset of forcing data
+
+ logical :: leapyear ! leapyear calendar
+ logical :: data2d ! data in 2 dimension (lon, lat)
+ logical :: hightdim ! have "z" dimension
+ logical :: dim2d ! lat/lon value in 2 dimension (lon, lat)
+
+ character(len=256) :: latname ! dimension name of latitude
+ character(len=256) :: lonname ! dimension name of longitude
+
+ character(len=256) :: groupby ! file grouped by year/month
+
+ character(len=256), allocatable :: fprefix(:) ! file prefix
+ character(len=256), allocatable :: vname(:) ! variable name
+ character(len=256), allocatable :: timelog(:) ! variable time log info
+ character(len=256), allocatable :: tintalgo(:) ! interpolation algorithm
+
+ ! ----- public subroutines -----
+ PUBLIC :: init_user_specified_forcing ! initialization of the selected forcing dataset
+ PUBLIC :: metfilename ! identify the forcing file name
+ PUBLIC :: metpreprocess ! preprocess the forcing data
+
+CONTAINS
+
+ ! ----------------
+ SUBROUTINE init_user_specified_forcing
+
+ USE MOD_Namelist
+ IMPLICIT NONE
+
+ ! Local variables
+ integer :: ivar,NVAR_default
+
+ NVAR = DEF_forcing%NVAR
+ NVAR_default=NVAR
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ NVAR=NVAR+1
+ ENDIF
+
+ IF (allocated(dtime )) deallocate(dtime)
+ IF (allocated(offset)) deallocate(offset)
+ allocate (dtime (NVAR))
+ allocate (offset (NVAR))
+
+ IF (allocated(fprefix )) deallocate(fprefix )
+ IF (allocated(vname )) deallocate(vname )
+ IF (allocated(timelog )) deallocate(timelog )
+ IF (allocated(tintalgo)) deallocate(tintalgo)
+ allocate (fprefix (NVAR))
+ allocate (vname (NVAR))
+ allocate (timelog (NVAR))
+ allocate (tintalgo (NVAR))
+
+ solarin_all_band = DEF_forcing%solarin_all_band ! whether solar radiation in all bands
+ HEIGHT_mode = DEF_forcing%HEIGHT_mode ! observation height mode
+ HEIGHT_V = DEF_forcing%HEIGHT_V ! observation height of wind speed
+ HEIGHT_T = DEF_forcing%HEIGHT_T ! observation height of air temperature
+ HEIGHT_Q = DEF_forcing%HEIGHT_Q ! observation height of specific humidity
+
+ startyr = DEF_forcing%startyr ! start year of forcing data
+ startmo = DEF_forcing%startmo ! start month of forcing data
+ endyr = DEF_forcing%endyr ! end year of forcing data
+ endmo = DEF_forcing%endmo ! end month of forcing data
+ dtime(:) = DEF_forcing%dtime(:) ! time interval of forcing data
+ offset(:) = DEF_forcing%offset(:) ! offset of forcing data
+
+ leapyear = DEF_forcing%leapyear ! whether leapyear calendar
+ data2d = DEF_forcing%data2d ! whether data in 2 dimension (lon, lat)
+ hightdim = DEF_forcing%hightdim ! whether have "z" dimension (height)
+ dim2d = DEF_forcing%dim2d ! whether lat/lon in 2 dimension (lon,lat)
+
+ latname = DEF_forcing%latname ! dimension name of latitude
+ lonname = DEF_forcing%lonname ! dimension name of longitude
+
+ groupby = DEF_forcing%groupby ! file grouped by year/month
+
+ DO ivar = 1, NVAR_default
+ fprefix (ivar) = DEF_forcing%fprefix(ivar) ! file prefix
+ vname (ivar) = DEF_forcing%vname(ivar) ! variable name
+ timelog (ivar) = DEF_forcing%timelog(ivar) ! variable name
+ tintalgo(ivar) = DEF_forcing%tintalgo(ivar) ! interpolation algorithm
+ ENDDO
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ fprefix (NVAR) = DEF_forcing%CBL_fprefix
+ vname (NVAR) = DEF_forcing%CBL_vname
+ tintalgo(NVAR) = DEF_forcing%CBL_tintalgo
+ dtime (NVAR) = DEF_forcing%CBL_dtime
+ offset (NVAR) = DEF_forcing%CBL_offset
+ ENDIF
+ END SUBROUTINE init_user_specified_forcing
+
+ ! ----------------
+ FUNCTION metfilename(year, month, day, var_i, is_spinup)
+
+ USE MOD_Namelist
+ IMPLICIT NONE
+
+ integer, intent(in) :: year
+ integer, intent(in) :: month
+ integer, intent(in) :: day
+ integer, intent(in) :: var_i
+
+ logical, intent(in), optional :: is_spinup
+
+ character(len=256) :: metfilename
+ character(len=256) :: yearstr
+ character(len=256) :: monthstr
+
+ write(yearstr, '(I4.4)') year
+ write(monthstr, '(I2.2)') month
+
+ IF (present(is_spinup)) THEN
+ IF (DEF_USE_ClimForcing_for_Spinup .and. is_spinup) THEN
+ yearstr = 'clim'
+ ENDIF
+ ENDIF
+
+ select CASE (trim(DEF_forcing%dataset))
+ CASE ('PRINCETON') ! Princeton forcing data
+ !DESCRIPTION
+ !===========
+ !---Princeton Global Meteorological Forcing Dataset for Land Surface Modeling
+
+ !data source:
+ !-------------------
+ !---https://rda.ucar.edu/datasets/ds314.0/
+
+ !References:
+ !-------------------
+ !---Sheffield, J., G. Goteti, and E. F. Wood, 2006: Development of a 50-year
+ ! high-resolution global dataset of meteorological forcings for land surface modeling J.
+ ! Climate, 19(13), 3088-3111.
+
+ !REVISION HISTORY
+ !----------------
+ !---2022.05.01 Zhongwang Wei @ SYSU: remove the "z" dimension
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(yearstr)//'.nc'
+ CASE ('GSWP3') ! GSWP3 forcing data
+ !DESCRIPTION
+ !===========
+ !---Global Meteorological Forcing Dataset for Global Soil Wetness Project Phase 3
+
+ !data source:
+ !-------------------
+ !---http://hydro.iis.u-tokyo.ac.jp/GSWP3/
+ !---https://www.isimip.org/gettingstarted/input-data-bias-adjustment/details/4/
+
+ !References:
+ !-------------------
+ !---Dirmeyer, P. A., Gao, X., Zhao, M., Guo, Z., Oki, T. and Hanasaki, N. (2006) GSWP-2:
+ ! Multimodel Analysis and Implications for Our Perception of the Land Surface. Bulletin
+ ! of the American Meteorological Society, 87(10), 1381-98.
+
+ !REVISION HISTORY
+ !----------------
+ !---
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc'
+ CASE ('QIAN') ! Qian forcing data
+ !DESCRIPTION
+ !===========
+ !---Qian Global Meteorological Forcing Dataset from 1948 to 2004
+
+ !data source:
+ !-------------------
+ !---Not available now!
+
+ !References:
+ !-------------------
+ !---Qian T., and co-authors, 2006: Simulation of Global Land Surface Conditions from 1948
+ ! to 2004. Part I: Forcing Data and Evaluations. J. Hydrometeorol., 7, 953-975.
+
+ !REVISION HISTORY
+ !----------------
+ !---
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc'
+ CASE ('CRUNCEPV4') ! CRUNCEP V4 forcing data
+ !DESCRIPTION
+ !===========
+ !---CRUNCEP Version 4 - Atmospheric Forcing Data for the Community Land Model
+
+ !data source:
+ !-------------------
+ !---http://dods.extra.cea.fr/data/p529viov/cruncep/V5_1901_2013/
+
+ !References:
+ !-------------------
+ !---Viovy, N. (2010), CRU‐NCEP dataset.
+ ! [Available at: http://dods.extra.cea.fr/data/p529viov/cruncep/readme.htm.]
+
+ !REVISION HISTORY
+ !----------------
+ !---
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc'
+ CASE ('CRUNCEPV7') ! CRUNCEP V7 forcing data
+ !DESCRIPTION
+ !===========
+ !---CRUNCEP Version 7 - Atmospheric Forcing Data for the Community Land Model
+
+ !data source:
+ !-------------------
+ !---https://rda.ucar.edu/datasets/ds314.3/
+
+ !References:
+ !-------------------
+ !---Viovy, Nicolas. (2018). CRUNCEP Version 7 -
+ ! Atmospheric Forcing Data for the Community Land Model.
+ ! Research Data Archive at the National Center for Atmospheric Research,
+ ! Computational and Information Systems Laboratory.
+ ! https://doi.org/10.5065/PZ8F-F017. Accessed 05 May 2023.
+
+ !REVISION HISTORY
+ !----------------
+ !---
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc'
+ CASE ('ERA5LAND') ! ERA5-Land forcing data
+ !DESCRIPTION
+ !===========
+ !---enhanced global dataset for the land component of the fifth
+ ! generation of European ReAnalysis (ERA5)
+
+ !data source:
+ !-------------------
+ !---https://cds.climate.copernicus.eu/cdsapp#!/dataset/reanalysis-era5-land?tab=form
+
+ !References:
+ !-------------------
+ !---Muñoz-Sabater, J., Dutra, E., Agustí-Panareda, A., Albergel, C., Arduini, G., Balsamo,
+ ! G., Boussetta, S., Choulga, M., Harrigan, S., Hersbach, H. and Martens, B., 2021.
+ ! ERA5-Land: A state-of-the-art global reanalysis dataset for land applications. Earth
+ ! System Science Data, 13(9), pp.4349-4383.
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data;
+ ! remove offset and scale_factor
+
+ metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr)
+ select CASE (var_i)
+ CASE (1)
+ metfilename = trim(metfilename) // '_2m_temperature.nc'
+ CASE (2)
+ metfilename = trim(metfilename) //'_specific_humidity.nc'
+ CASE (3)
+ metfilename = trim(metfilename) //'_surface_pressure.nc'
+ CASE (4)
+ metfilename = trim(metfilename) //'_total_precipitation_m_hr.nc'
+ CASE (5)
+ metfilename = trim(metfilename) //'_10m_u_component_of_wind.nc'
+ CASE (6)
+ metfilename = trim(metfilename) //'_10m_v_component_of_wind.nc'
+ CASE (7)
+ metfilename = trim(metfilename) //'_surface_solar_radiation_downwards_w_m2.nc'
+ CASE (8)
+ metfilename = trim(metfilename) //'_surface_thermal_radiation_downwards_w_m2.nc'
+ END select
+ CASE ('ERA5') ! ERA5 forcing data
+ !DESCRIPTION
+ !===========
+ !---The fifth generation of European ReAnalysis (ERA5)
+
+ !data source:
+ !-------------------
+ !---https://cds.climate.copernicus.eu/cdsapp#!
+ ! /dataset/reanalysis-era5-single-levels?tab=overview
+
+ !References:
+ !-------------------
+ !---Hersbach, H., Bell, B., Berrisford, P., Hirahara, S., Horányi, A., Muñoz‐Sabater, J.,
+ ! Nicolas, J., Peubey, C., Radu, R., Schepers, D. and Simmons, A., 2020. The ERA5 global
+ ! reanalysis. Quarterly Journal of the Royal Meteorological Society, 146(730),
+ ! pp.1999-2049.
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data; remove
+ ! offset and scale_factor
+
+ metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr)
+ select CASE (var_i)
+ CASE (1)
+ metfilename = trim(metfilename) // '_2m_temperature.nc4'
+ CASE (2)
+ metfilename = trim(metfilename) //'_q.nc4'
+ CASE (3)
+ metfilename = trim(metfilename) //'_surface_pressure.nc4'
+ CASE (4)
+ metfilename = trim(metfilename) //'_mean_total_precipitation_rate.nc4'
+ CASE (5)
+ metfilename = trim(metfilename) //'_10m_u_component_of_wind.nc4'
+ CASE (6)
+ metfilename = trim(metfilename) //'_10m_v_component_of_wind.nc4'
+ CASE (7)
+ metfilename = trim(metfilename) //'_mean_surface_downward_short_wave_radiation_flux.nc4'
+ CASE (8)
+ metfilename = trim(metfilename) //'_mean_surface_downward_long_wave_radiation_flux.nc4'
+ END select
+ CASE ('MSWX') ! MSWX forcing data
+ !DESCRIPTION
+ !===========
+ !---Multi-Source Weather forcing data
+
+ !data source:
+ !-------------------
+ !---https://www.gloh2o.org/mswx/
+
+ !References:
+ !-------------------
+ !---Beck, H.E., van Dijk, A.I., Larraondo, P.R., McVicar, T.R., Pan, M., Dutra, E. and
+ ! Miralles, D.G., 2022. MSWX: Global 3-hourly 0.1 bias-corrected meteorological data
+ ! including near-real-time updates and forecast ensembles. Bulletin of the American
+ ! Meteorological Society, 103(3), pp.E710-E732.
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: Regroup data into monthly
+
+ metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr)//'.nc'
+ CASE ('WFDE5')
+ !DESCRIPTION
+ !===========
+ !---WATCH Forcing Data methodology applied to ERA5 reanalysis data
+
+ !data source:
+ !-------------------
+ !---https://doi.org/10.24381/cds.20d54e34
+
+ !References:
+ !-------------------
+ !---Cucchi, M., Weedon, G.P., Amici, A., Bellouin, N., Lange, S., Müller Schmied, H.,
+ ! Hersbach, H. and Buontempo, C., 2020. WFDE5: bias-adjusted ERA5 reanalysis data
+ ! for impact studies. Earth System Science Data, 12(3), pp.2097-2120.
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data;
+ ! remove offset and scale_factor
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'_v2.1.nc'
+ CASE ('CRUJRA')
+ !DESCRIPTION
+ !===========
+ !---Collection of CRU JRA forcing datasets of gridded land surface blend
+ ! of Climatic Research Unit (CRU) and Japanese reanalysis (JRA) data
+
+ !data source:
+ !-------------------
+ !---https://catalogue.ceda.ac.uk/uuid/863a47a6d8414b6982e1396c69a9efe8
+
+ !References:
+ !-------------------
+ !---University of East Anglia Climatic Research Unit; Harris, I.C. (2019):
+ ! CRU JRA: Collection of CRU JRA forcing datasets of gridded land surface blend
+ ! of Climatic Research Unit (CRU) and Japanese reanalysis (JRA) data..
+ ! Centre for Environmental Data Analysis, date of citation.
+ !http://catalogue.ceda.ac.uk/uuid/863a47a6d8414b6982e1396c69a9efe8
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data;
+ ! remove offset and scale_factor
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'.365d.noc.nc'
+
+
+ CASE ('WFDEI')
+ !DESCRIPTION
+ !===========
+ !---WATCH Forcing Data methodology applied to ERA-Interim reanalysis data
+
+ !data source:
+ !-------------------
+ !---https://doi.org/10.24381/cds.20d54e34
+
+ !References:
+ !-------------------
+ !---Weedon, G.P., Balsamo, G., Bellouin, N., Gomes, S., Best, M.J. and Viterbo, P., 2014.
+ ! The WFDEI meteorological forcing data set: WATCH Forcing Data methodology applied
+ ! to ERA‐Interim reanalysis data. Water Resources Research, 50(9), pp.7505-7514.
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data;
+ ! remove offset and scale_factor
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//'-'//trim(monthstr)//'.nc'
+ CASE ('JRA3Q')
+ !DESCRIPTION
+ !===========
+ !---Japanese Reanalysis for Three Quarters of a Century
+
+ !data source:
+ !-------------------
+ !---https://rda.ucar.edu/datasets/ds640.0/
+
+ !References:
+ !-------------------
+ !---Kosaka Y., S. Kobayashi, Y. Harada, C. Kobayashi, H. Naoe, K. Yoshimoto, M. Harada, N.
+ ! Goto, J. Chiba, K. Miyaoka, R. Sekiguchi, M. Deushi, H. Kamahori, T. Nakaegawa; T.
+ ! Y.Tanaka, T. Tokuhiro, Y. Sato, Y. Matsushita, and K. Onogi, 2024: The JRA-3Q
+ ! reanalysis. J. Meteor. Soc. Japan, 102, https://doi.org/10.2151/jmsj.2024-004.
+
+
+ !REVISION HISTORY
+ !----------------
+ !---2024.03.04 Zhongwang Wei @ SYSU: remove offset and scale_factor
+ metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'_'//trim(monthstr)//'.nc'
+
+ CASE ('JRA55')
+ !DESCRIPTION
+ !===========
+ !---the Japanese 55-year Reanalysis
+
+ !data source:
+ !-------------------
+ !---https://jra.kishou.go.jp/JRA-55/index_en.html
+
+ !References:
+ !-------------------
+ !---Kobayashi, S., Y. Ota, Y. Harada, A. Ebita, M. Moriya, H. Onoda, K. Onogi,
+ ! H. Kamahori, C. Kobayashi, H. Endo, K. Miyaoka, and K. Takahashi , 2015:
+ ! The JRA-55 Reanalysis: General specifications and basic characteristics.
+ ! J. Meteor. Soc. Japan, 93, 5-48, doi:10.2151/jmsj.2015-001.
+ !---Harada, Y., H. Kamahori, C. Kobayashi, H. Endo, S. Kobayashi, Y. Ota, H. Onoda,
+ ! K. Onogi, K. Miyaoka, and K. Takahashi, 2016: The JRA-55 Reanalysis: Representation
+ ! of atmospheric circulation and climate variability, J. Meteor. Soc. Japan, 94,
+ ! 269-302, doi:10.2151/jmsj.2016-015.
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: zip file to reduce the size of the data;
+ ! remove offset and scale_factor
+
+
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc'
+
+
+ CASE ('GDAS')
+ !DESCRIPTION
+ !===========
+ !--- Forcing Data From Global Data Assimilation System
+
+ !data source:
+ !-------------------
+ !--https://disc.sci.gsfc.nasa.gov/datasets/GLDAS_NOAH025_3H_V2.1/summary
+
+ !References:
+ !-------------------
+ !---Beaudoing, H. and M. Rodell, NASA/GSFC/HSL (2020), GLDAS Noah Land Surface Model L4 3
+ ! hourly 0.25 x 0.25 degree V2.1, Greenbelt, Maryland, USA, Goddard Earth Sciences Data
+ ! and Information Services Center (GES DISC), Accessed: [Data Access Date],
+ ! 10.5067/E7TYRXPJKWOQ
+ !---Rodell, M., P.R. Houser, U. Jambor, J. Gottschalck, K. Mitchell, C. Meng, K. Arsenault,
+ ! B. Cosgrove, J. Radakovich, M. Bosilovich, J.K. Entin, J.P. Walker, D. Lohmann, and D.
+ ! Toll, 2004: The Global Land Data Assimilation System, Bull. Amer. Meteor. Soc., 85,
+ ! 381-394, doi:10.1175/BAMS-85-3-381
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: merge the data into monthly file;
+ ! zip file to reduce the size of the data; remove offset and scale_factor
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc4'
+ CASE ('CLDAS')
+
+ !DESCRIPTION
+ !===========
+ !---The Real-Time Product Dataset Of The China Meteorological Administration
+ ! Land Data Assimilation System
+
+ !data source:
+ !-------------------
+ !--CMA, not pulicly available
+
+ !References:
+ !-------------------
+ !---Xia, Y.L.; Hao, Z.C.; Shi, C.X.; Li, Y.H.; Meng, J.; Xu, T.R.; Wu, X.Y.; Zhang, B.Q.
+ ! Regional and global land data assimilation systems: Innovations, challenges, and
+ ! prospects. J. Meteorol. Res. 2019, 33, 159-189.
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: gap filling for the missing data;
+ ! zip file to reduce the size of the data; remove offset and scale_factor
+
+ metfilename = '/'//trim(fprefix(var_i))//'-'//trim(yearstr)//trim(monthstr)//'.nc'
+ CASE ('CMFD')
+ !DESCRIPTION
+ !===========
+ !--- The China Meteorological Forcing Dataset
+
+ !data source:
+ !-------------------
+ !--https://data.tpdc.ac.cn/en/data/8028b944-daaa-4511-8769-965612652c49/
+
+ !References:
+ !-------------------
+ !---He, J., Yang, K., Tang, W., Lu, H., Qin, J., Chen, Y. and Li, X., 2020.
+ ! The first high-resolution meteorological forcing dataset for land process
+ ! studies over China. Scientific data, 7(1), p.25.
+
+ !REVISION HISTORY
+ !----------------
+ !---
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc4'
+ CASE ('CMFDv2')
+ !DESCRIPTION
+ !===========
+ !--- The China Meteorological Forcing Dataset version 2.0
+
+ !data source:
+ !-------------------
+ !--https://data.tpdc.ac.cn/en/data/e60dfd96-5fd8-493f-beae-e8e5d24dece4
+
+ !References:
+ !-------------------
+ !---He, J., Yang, K., Li, X., Tang, W., Shao, C., Jiang, Y., Ding, B. 2024.
+ ! The China Meteorological Forcing Dataset (CMFD) version 2.0.
+ ! National Tibetan Plateau/Third Pole Environment Data Center,
+ ! https://doi.org/10.11888/Atmos.tpdc.300398. https://cstr.cn/18406.11.Atmos.tpdc.300398.
+
+ !REVISION HISTORY
+ !----------------
+ !---
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc'
+ CASE ('CMIP6')
+ !DESCRIPTION
+ !===========
+ !---the Climate Model Intercomparison Project Phase 6 (CMIP6) forcing data sets
+
+ !data source:
+ !-------------------
+ !---https://esgf-node.llnl.gov/projects/cmip6/
+
+ !References:
+ !-------------------
+ !---
+
+ !REVISION HISTORY
+ !----------------
+ !---2021.11.01 Zhongwang Wei @ SYSU: regroup the data into monthly file;
+ ! zip file to reduce the size of the data; remove offset and scale_factor
+
+
+ metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'.nc'
+
+ CASE ('CRA40')
+ !DESCRIPTION
+ !===========
+ !---CMA first-generation global atmospheric reanalysis (RA) covering 1979-2018 (CRA-40)
+
+ !data source:
+ !-------------------
+ !---https://data.cma.cn/en
+
+ !References:
+ !-------------------
+ !---Liu, Z., Jiang, L., Shi, C. et al. CRA-40/Atmosphere—The First-Generation Chinese
+ ! Atmospheric Reanalysis (1979-2018): System Description and Performance Evaluation. J
+ ! Meteorol Res 37, 1-19 (2023). https://doi.org/10.1007/s13351-023-2086-x
+
+
+
+ !REVISION HISTORY
+ !----------------
+ !---2024.04.10 Zhongwang Wei @ SYSU: regroup the data into annual file;
+ ! zip file to reduce the size of the data; remove offset and scale_factor
+
+
+ metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'.nc'
+ CASE ('TPMFD')
+ !DESCRIPTION
+ !===========
+ !---A high-resolution near-surface meteorological forcing dataset for the Third Pole region
+
+ !data source:
+ !-------------------
+ !---https://data.tpdc.ac.cn/zh-hans/data/44a449ce-e660-44c3-bbf2-31ef7d716ec7
+
+ !References:
+ !-------------------
+ !---Yang, K., Jiang, Y., Tang, W., He, J., Shao, C., Zhou, X., Lu, H.,
+ ! Chen, Y., Li, X., Shi, J. (2023). A high-resolution near-surface
+ ! meteorological forcing dataset for the Third Pole region （TPMFD, 1979-2020）.
+ ! National Tibetan Plateau/Third Pole Environment Data Center,
+ ! https://doi.org/10.11888/Atmos.tpdc.300398. https://cstr.cn/18406.11.Atmos.tpdc.300398.
+
+ !REVISION HISTORY
+ !----------------
+ !---2023.11.01 Zhongwang Wei @ SYSU: regroup the data into monthly file;
+ ! zip file to reduce the size of the data; remove offset and scale_factor
+
+ metfilename = '/'//trim(fprefix(var_i))//trim(yearstr)//trim(monthstr)//'.nc'
+ CASE ('IsoGSM')
+ !DESCRIPTION
+ !===========
+ !--- Isotopes-incorporated Global Spectral Model (IsoGSM)
+
+ !data source:
+ !-------------------
+ !---https://isotope.iis.u-tokyo.ac.jp/about-our-lab?lang=en
+
+ !References:
+ !-------------------
+ !---Bong, H., Cauquoin, A., Okazaki, A., Chang, E.-C., Werner, M., Wei, Z., et al. (2024).
+ ! Process-based intercomparison of water isotope-enabled models and reanalysis nudging effects.
+ ! Journal of Geophysical Research: Atmospheres, 129, e2023JD038719.
+ ! https://doi.org/10.1029/2023JD038719
+
+ !REVISION HISTORY
+ !----------------
+ !---2025.03.23 Zhongwang Wei @ SYSU: add the isotope forcing data
+
+ metfilename = '/'//trim(fprefix(var_i))//'_'//trim(yearstr)//'.nc'
+
+
+ CASE ('POINT')
+ metfilename = '/'//trim(fprefix(1))
+ END select
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ select CASE (var_i)
+ CASE (9)
+ metfilename = '/'//trim(fprefix(9))//'_'//trim(yearstr)//'_'//trim(monthstr)//&
+ '_boundary_layer_height.nc4'
+ END select
+ ENDIF
+ END FUNCTION metfilename
+
+ ! preprocess for forcing data [not applicable yet for PRINCETON]
+ ! ------------------------------------------------------------
+ SUBROUTINE metpreprocess(grid, forcn, has_missing_value, forcfirst, missing_value)
+
+ USE MOD_Const_Physical
+ USE MOD_Namelist
+ USE MOD_SPMD_Task
+ USE MOD_Block
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_Qsadv
+ IMPLICIT NONE
+ type(grid_type), intent(in) :: grid
+ type(block_data_real8_2d), intent(inout) :: forcn(:)
+ type(block_data_real8_2d), intent(in) :: forcfirst
+ logical, intent(in) :: has_missing_value
+ real(r8), intent(in) :: missing_value
+
+ integer :: iblkme, ib, jb, i, j
+ real(r8) :: es, esdT, qsat_tmp, dqsat_tmpdT, e, ea
+
+ !----------------------------------------------------------------------------
+ ! use polynomials to calculate saturation vapor pressure and derivative with
+ ! respect to temperature: over water when t > 0 c and over ice when t <= 0 c
+ ! required to convert relative humidity to specific humidity
+ !----------------------------------------------------------------------------
+ IF (trim(DEF_forcing%dataset) == 'POINT') THEN
+#ifdef SinglePoint
+ CALL qsadv(forcn(1)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1), &
+ forcn(3)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1)) THEN
+ forcn(2)%blk(gblock%xblkme(1),gblock%yblkme(1))%val(1,1) = qsat_tmp
+ ENDIF
+#endif
+ ELSE
+ DO iblkme = 1, gblock%nblkme
+ ib = gblock%xblkme(iblkme)
+ jb = gblock%yblkme(iblkme)
+
+ DO j = 1, grid%ycnt(jb)
+ DO i = 1, grid%xcnt(ib)
+
+ IF (has_missing_value) THEN
+ IF (forcfirst%blk(ib,jb)%val(i,j) == missing_value) THEN
+ CYCLE
+ ENDIF
+ ENDIF
+
+ select CASE (trim(DEF_forcing%dataset))
+
+ CASE ('PRINCETON')
+
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('GSWP2')
+
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('GSWP3')
+ IF (forcn(1)%blk(ib,jb)%val(i,j)<212.0) forcn(1)%blk(ib,jb)%val(i,j) = 212.0
+ IF (forcn(4)%blk(ib,jb)%val(i,j)<0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('QIAN')
+
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ e = forcn(3)%blk(ib,jb)%val(i,j) * forcn(2)%blk(ib,jb)%val(i,j) &
+ / (0.622_R8 + 0.378_R8 * forcn(2)%blk(ib,jb)%val(i,j))
+ ea = 0.70_R8 + 5.95e-05_R8 * 0.01_R8 * e &
+ * exp(1500.0_R8/forcn(1)%blk(ib,jb)%val(i,j))
+ forcn(8)%blk(ib,jb)%val(i,j) = ea * stefnc * forcn(1)%blk(ib,jb)%val(i,j)**4
+
+ CASE ('CRUNCEPV4')
+
+ IF (forcn(1)%blk(ib,jb)%val(i,j) < 212.0) forcn(1)%blk(ib,jb)%val(i,j) = 212.0
+ IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0
+ IF (forcn(7)%blk(ib,jb)%val(i,j) < 0.0) forcn(7)%blk(ib,jb)%val(i,j) = 0.0
+ ! 12th grade of Typhoon 32.7-36.9 m/s
+ IF (abs(forcn(5)%blk(ib,jb)%val(i,j)) > 40.0) forcn(5)%blk(ib,jb)%val(i,j) = &
+ 40.0*forcn(5)%blk(ib,jb)%val(i,j)/abs(forcn(5)%blk(ib,jb)%val(i,j))
+ IF (abs(forcn(6)%blk(ib,jb)%val(i,j)) > 40.0) forcn(6)%blk(ib,jb)%val(i,j) = &
+ 40.0*forcn(6)%blk(ib,jb)%val(i,j)/abs(forcn(6)%blk(ib,jb)%val(i,j))
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('CRUNCEPV7')
+
+ IF (forcn(1)%blk(ib,jb)%val(i,j) < 212.0) forcn(1)%blk(ib,jb)%val(i,j) = 212.0
+ IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0
+ IF (forcn(7)%blk(ib,jb)%val(i,j) < 0.0) forcn(7)%blk(ib,jb)%val(i,j) = 0.0
+ ! 12th grade of Typhoon 32.7-36.9 m/s
+ ! NOTE by Wenzong: This is a problem when running a GNU-compiled PROGRAM,
+ ! because there is no data of forcn(5), temporarily comment the code below
+ ! IF (abs(forcn(5)%blk(ib,jb)%val(i,j))>40.0) forcn(5)%blk(ib,jb)%val(i,j) = &
+ ! 40.0*forcn(5)%blk(ib,jb)%val(i,j)/abs(forcn(5)%blk(ib,jb)%val(i,j))
+ IF (abs(forcn(6)%blk(ib,jb)%val(i,j)) > 40.0) forcn(6)%blk(ib,jb)%val(i,j) = &
+ 40.0*forcn(6)%blk(ib,jb)%val(i,j)/abs(forcn(6)%blk(ib,jb)%val(i,j))
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('ERA5LAND')
+
+ forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j) * 1000./3600.
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('ERA5')
+
+ IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0
+ IF (abs(forcn(5)%blk(ib,jb)%val(i,j)) > 40.0) &
+ forcn(5)%blk(ib,jb)%val(i,j) = 40.0*sign(1.0,forcn(5)%blk(ib,jb)%val(i,j))
+ IF (abs(forcn(6)%blk(ib,jb)%val(i,j)) > 40.0) &
+ forcn(6)%blk(ib,jb)%val(i,j) = 40.0*sign(1.0,forcn(6)%blk(ib,jb)%val(i,j))
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+ IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0
+
+ CASE ('MSWX')
+
+ forcn(1)%blk(ib,jb)%val(i,j)=forcn(1)%blk(ib,jb)%val(i,j)+273.15
+ forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/10800.
+ IF (forcn(4)%blk(ib,jb)%val(i,j)>1000.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+ IF (forcn(2)%blk(ib,jb)%val(i,j)<0.5E-05) &
+ forcn(2)%blk(ib,jb)%val(i,j) = 0.5E-05
+
+ CASE ('WFDE5')
+
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('WFDEI')
+
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('CLDAS') ! CLDAS forcing
+
+ forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/3600.
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('CMFD') ! CMFD forcing
+
+ forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/3600.
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+ CASE ('CMFDv2') ! CMFDv2 forcing
+
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('CRUJRA') ! CRUJRA forcing
+ forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/21600.
+ forcn(7)%blk(ib,jb)%val(i,j)=forcn(7)%blk(ib,jb)%val(i,j)/21600.
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('GDAS') ! GDAS forcing
+
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('JRA55') ! JRA55 forcing
+
+ forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/86400.0 !mm/s
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('JRA3Q') ! JRA3Q forcing
+
+ forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('TPMFD') ! TPMFD forcing
+
+ forcn(4)%blk(ib,jb)%val(i,j)=forcn(4)%blk(ib,jb)%val(i,j)/3600.!convert to mm/s
+ forcn(3)%blk(ib,jb)%val(i,j)=forcn(3)%blk(ib,jb)%val(i,j)*100. !convert to pa
+
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ CASE ('CMIP6') ! CMIP6 forcing
+
+ IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+ IF (forcn(4)%blk(ib,jb)%val(i,j) < 0.0) forcn(4)%blk(ib,jb)%val(i,j) = 0.0
+
+ CASE ('IsoGSM') ! IsoGSM forcing
+ CALL qsadv (forcn(1)%blk(ib,jb)%val(i,j), forcn(3)%blk(ib,jb)%val(i,j), &
+ es,esdT,qsat_tmp,dqsat_tmpdT)
+ IF (qsat_tmp < forcn(2)%blk(ib,jb)%val(i,j)) THEN
+ forcn(2)%blk(ib,jb)%val(i,j) = qsat_tmp
+ ENDIF
+
+ END select
+
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE metpreprocess
+
+END MODULE MOD_UserSpecifiedForcing
+! ---------- EOP ------------
diff --git a/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90
new file mode 100644
index 0000000000..ee50c2aa0f
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DAccFluxes.F90
@@ -0,0 +1,2970 @@
+#include
+
+MODULE MOD_Vars_1DAccFluxes
+
+ USE MOD_Precision
+#ifdef DataAssimilation
+ USE MOD_DA_Vars_TimeVariables
+ USE MOD_DA_Vars_1DFluxes
+ USE MOD_Namelist
+#endif
+#ifdef EXTERNAL_LAKE
+ USE MOD_Lake_1DAccVars
+#endif
+
+ real(r8) :: nac ! number of accumulation
+ real(r8), allocatable :: nac_ln (:)
+ real(r8), allocatable :: nac_dt (:)
+ logical, allocatable :: filter_dt (:)
+
+ real(r8), allocatable :: a_us (:)
+ real(r8), allocatable :: a_vs (:)
+ real(r8), allocatable :: a_t (:)
+ real(r8), allocatable :: a_q (:)
+ real(r8), allocatable :: a_prc (:)
+ real(r8), allocatable :: a_prl (:)
+ real(r8), allocatable :: a_pbot (:)
+ real(r8), allocatable :: a_frl (:)
+ real(r8), allocatable :: a_solarin (:)
+ real(r8), allocatable :: a_hpbl (:)
+
+ real(r8), allocatable :: a_taux (:)
+ real(r8), allocatable :: a_tauy (:)
+ real(r8), allocatable :: a_fsena (:)
+ real(r8), allocatable :: a_lfevpa (:)
+ real(r8), allocatable :: a_fevpa (:)
+ real(r8), allocatable :: a_fsenl (:)
+ real(r8), allocatable :: a_fevpl (:)
+ real(r8), allocatable :: a_etr (:)
+ real(r8), allocatable :: a_fseng (:)
+ real(r8), allocatable :: a_fevpg (:)
+ real(r8), allocatable :: a_fgrnd (:)
+ real(r8), allocatable :: a_sabvsun (:)
+ real(r8), allocatable :: a_sabvsha (:)
+ real(r8), allocatable :: a_sabg (:)
+ real(r8), allocatable :: a_olrg (:)
+ real(r8), allocatable :: a_rnet (:)
+ real(r8), allocatable :: a_xerr (:)
+ real(r8), allocatable :: a_zerr (:)
+ real(r8), allocatable :: a_rsur (:)
+ real(r8), allocatable :: a_rsur_se (:)
+ real(r8), allocatable :: a_rsur_ie (:)
+ real(r8), allocatable :: a_rsub (:)
+ real(r8), allocatable :: a_rnof (:)
+#ifdef CatchLateralFlow
+ real(r8), allocatable :: a_xwsur (:)
+ real(r8), allocatable :: a_xwsub (:)
+ real(r8), allocatable :: a_fldarea (:)
+#endif
+ real(r8), allocatable :: a_qintr (:)
+ real(r8), allocatable :: a_qinfl (:)
+ real(r8), allocatable :: a_qdrip (:)
+ real(r8), allocatable :: a_rstfacsun (:)
+ real(r8), allocatable :: a_rstfacsha (:)
+ real(r8), allocatable :: a_gssun (:)
+ real(r8), allocatable :: a_gssha (:)
+ real(r8), allocatable :: a_rss (:)
+ real(r8), allocatable :: a_wdsrf (:)
+ real(r8), allocatable :: a_zwt (:)
+ real(r8), allocatable :: a_wa (:)
+ real(r8), allocatable :: a_wat (:)
+ real(r8), allocatable :: a_wetwat (:)
+ real(r8), allocatable :: a_assim (:)
+ real(r8), allocatable :: a_respc (:)
+ real(r8), allocatable :: a_assimsun (:)
+ real(r8), allocatable :: a_assimsha (:)
+ real(r8), allocatable :: a_etrsun (:)
+ real(r8), allocatable :: a_etrsha (:)
+
+ real(r8), allocatable :: a_qcharge (:)
+
+ real(r8), allocatable :: a_t_grnd (:)
+ real(r8), allocatable :: a_tleaf (:)
+ real(r8), allocatable :: a_ldew (:)
+ real(r8), allocatable :: a_ldew_rain (:)
+ real(r8), allocatable :: a_ldew_snow (:)
+ real(r8), allocatable :: a_scv (:)
+ real(r8), allocatable :: a_snowdp (:)
+ real(r8), allocatable :: a_fsno (:)
+ real(r8), allocatable :: a_frcsat (:)
+ real(r8), allocatable :: a_sigf (:)
+ real(r8), allocatable :: a_green (:)
+ real(r8), allocatable :: a_lai (:)
+ real(r8), allocatable :: a_laisun (:)
+ real(r8), allocatable :: a_laisha (:)
+ real(r8), allocatable :: a_sai (:)
+ real(r8), allocatable :: a_alb (:,:,:)
+
+#ifdef HYPERSPECTRAL
+ real(r8), allocatable :: a_alb_hires (:,:,:)
+ real(r8), allocatable :: a_reflectance_out (:,:,:)
+ real(r8), allocatable :: a_transmittance_out (:,:,:)
+#endif
+ real(r8), allocatable :: a_emis (:)
+ real(r8), allocatable :: a_z0m (:)
+ real(r8), allocatable :: a_trad (:)
+ real(r8), allocatable :: a_tref (:)
+ real(r8), allocatable :: a_t2m_wmo (:)
+ real(r8), allocatable :: a_qref (:)
+ real(r8), allocatable :: a_rain (:)
+ real(r8), allocatable :: a_snow (:)
+
+ real(r8), allocatable :: a_o3uptakesun(:)
+ real(r8), allocatable :: a_o3uptakesha(:)
+
+#ifdef DataAssimilation
+ real(r8), allocatable :: a_h2osoi_ens (:,:,:)
+ real(r8), allocatable :: a_t_brt_smap_ens (:,:,:)
+ real(r8), allocatable :: a_t_brt_fy3d_ens (:,:,:)
+ real(r8), allocatable :: a_t_brt_smap (:,:)
+ real(r8), allocatable :: a_t_brt_fy3d (:,:)
+ real(r8), allocatable :: a_wliq_soisno_ens(:,:,:)
+ real(r8), allocatable :: a_wice_soisno_ens(:,:,:)
+ real(r8), allocatable :: a_t_soisno_ens (:,:,:)
+#endif
+
+#ifdef URBAN_MODEL
+ real(r8), allocatable :: a_t_room (:) !temperature of inner building [K]
+ real(r8), allocatable :: a_tafu (:) !temperature of outer building [K]
+ real(r8), allocatable :: a_fhac (:) !sensible flux from heat or cool AC [W/m2]
+ real(r8), allocatable :: a_fwst (:) !waste heat flux from heat or cool AC [W/m2]
+ real(r8), allocatable :: a_fach (:) !flux from inner and outer air exchange [W/m2]
+ real(r8), allocatable :: a_fahe (:) !flux from metabolic and vehicle [W/m2]
+ real(r8), allocatable :: a_fhah (:) !sensible flux from heating [W/m2]
+ real(r8), allocatable :: a_vehc (:) !flux from vehicle [W/m2]
+ real(r8), allocatable :: a_meta (:) !flux from metabolic [W/m2]
+
+ real(r8), allocatable :: a_senroof (:) !sensible heat flux from roof [W/m2]
+ real(r8), allocatable :: a_senwsun (:) !sensible heat flux from sunlit wall [W/m2]
+ real(r8), allocatable :: a_senwsha (:) !sensible heat flux from shaded wall [W/m2]
+ real(r8), allocatable :: a_sengimp (:) !sensible heat flux from impervious road [W/m2]
+ real(r8), allocatable :: a_sengper (:) !sensible heat flux from pervious road [W/m2]
+ real(r8), allocatable :: a_senurbl (:) !sensible heat flux from urban vegetation [W/m2]
+
+ real(r8), allocatable :: a_lfevproof (:) !latent heat flux from roof [W/m2]
+ real(r8), allocatable :: a_lfevpgimp (:) !latent heat flux from impervious road [W/m2]
+ real(r8), allocatable :: a_lfevpgper (:) !latent heat flux from pervious road [W/m2]
+ real(r8), allocatable :: a_lfevpurbl (:) !latent heat flux from urban vegetation [W/m2]
+
+ real(r8), allocatable :: a_troof (:) !temperature of roof [K]
+ real(r8), allocatable :: a_twall (:) !temperature of wall [K]
+#endif
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ real(r8), allocatable :: a_lai_enftemp (:) !1
+ real(r8), allocatable :: a_lai_enfboreal (:) !2
+ real(r8), allocatable :: a_lai_dnfboreal (:) !3
+ real(r8), allocatable :: a_lai_ebftrop (:) !4
+ real(r8), allocatable :: a_lai_ebftemp (:) !5
+ real(r8), allocatable :: a_lai_dbftrop (:) !6
+ real(r8), allocatable :: a_lai_dbftemp (:) !7
+ real(r8), allocatable :: a_lai_dbfboreal (:) !8
+ real(r8), allocatable :: a_lai_ebstemp (:) !9
+ real(r8), allocatable :: a_lai_dbstemp (:) !10
+ real(r8), allocatable :: a_lai_dbsboreal (:) !11
+ real(r8), allocatable :: a_lai_c3arcgrass (:) !12
+ real(r8), allocatable :: a_lai_c3grass (:) !13
+ real(r8), allocatable :: a_lai_c4grass (:) !14
+#endif
+
+#ifdef BGC
+ real(r8), allocatable :: a_leafc (:)
+ real(r8), allocatable :: a_leafc_storage (:)
+ real(r8), allocatable :: a_leafc_xfer (:)
+ real(r8), allocatable :: a_frootc (:)
+ real(r8), allocatable :: a_frootc_storage (:)
+ real(r8), allocatable :: a_frootc_xfer (:)
+ real(r8), allocatable :: a_livestemc (:)
+ real(r8), allocatable :: a_livestemc_storage (:)
+ real(r8), allocatable :: a_livestemc_xfer (:)
+ real(r8), allocatable :: a_deadstemc (:)
+ real(r8), allocatable :: a_deadstemc_storage (:)
+ real(r8), allocatable :: a_deadstemc_xfer (:)
+ real(r8), allocatable :: a_livecrootc (:)
+ real(r8), allocatable :: a_livecrootc_storage (:)
+ real(r8), allocatable :: a_livecrootc_xfer (:)
+ real(r8), allocatable :: a_deadcrootc (:)
+ real(r8), allocatable :: a_deadcrootc_storage (:)
+ real(r8), allocatable :: a_deadcrootc_xfer (:)
+ real(r8), allocatable :: a_grainc (:)
+ real(r8), allocatable :: a_grainc_storage (:)
+ real(r8), allocatable :: a_grainc_xfer (:)
+ real(r8), allocatable :: a_leafn (:)
+ real(r8), allocatable :: a_leafn_storage (:)
+ real(r8), allocatable :: a_leafn_xfer (:)
+ real(r8), allocatable :: a_frootn (:)
+ real(r8), allocatable :: a_frootn_storage (:)
+ real(r8), allocatable :: a_frootn_xfer (:)
+ real(r8), allocatable :: a_livestemn (:)
+ real(r8), allocatable :: a_livestemn_storage (:)
+ real(r8), allocatable :: a_livestemn_xfer (:)
+ real(r8), allocatable :: a_deadstemn (:)
+ real(r8), allocatable :: a_deadstemn_storage (:)
+ real(r8), allocatable :: a_deadstemn_xfer (:)
+ real(r8), allocatable :: a_livecrootn (:)
+ real(r8), allocatable :: a_livecrootn_storage (:)
+ real(r8), allocatable :: a_livecrootn_xfer (:)
+ real(r8), allocatable :: a_deadcrootn (:)
+ real(r8), allocatable :: a_deadcrootn_storage (:)
+ real(r8), allocatable :: a_deadcrootn_xfer (:)
+ real(r8), allocatable :: a_grainn (:)
+ real(r8), allocatable :: a_grainn_storage (:)
+ real(r8), allocatable :: a_grainn_xfer (:)
+ real(r8), allocatable :: a_retransn (:)
+ real(r8), allocatable :: a_gpp (:)
+ real(r8), allocatable :: a_downreg (:)
+ real(r8), allocatable :: a_ar (:)
+ real(r8), allocatable :: a_cwdprod (:)
+ real(r8), allocatable :: a_cwddecomp (:)
+ real(r8), allocatable :: a_hr (:)
+ real(r8), allocatable :: a_fpg (:)
+ real(r8), allocatable :: a_fpi (:)
+ real(r8), allocatable :: a_totvegc (:)
+ real(r8), allocatable :: a_totlitc (:)
+ real(r8), allocatable :: a_totcwdc (:)
+ real(r8), allocatable :: a_totsomc (:)
+ real(r8), allocatable :: a_totcolc (:)
+ real(r8), allocatable :: a_totvegn (:)
+ real(r8), allocatable :: a_totlitn (:)
+ real(r8), allocatable :: a_totcwdn (:)
+ real(r8), allocatable :: a_totsomn (:)
+ real(r8), allocatable :: a_totcoln (:)
+ real(r8), allocatable :: a_gpp_enftemp (:) !1
+ real(r8), allocatable :: a_gpp_enfboreal (:) !2
+ real(r8), allocatable :: a_gpp_dnfboreal (:) !3
+ real(r8), allocatable :: a_gpp_ebftrop (:) !4
+ real(r8), allocatable :: a_gpp_ebftemp (:) !5
+ real(r8), allocatable :: a_gpp_dbftrop (:) !6
+ real(r8), allocatable :: a_gpp_dbftemp (:) !7
+ real(r8), allocatable :: a_gpp_dbfboreal (:) !8
+ real(r8), allocatable :: a_gpp_ebstemp (:) !9
+ real(r8), allocatable :: a_gpp_dbstemp (:) !10
+ real(r8), allocatable :: a_gpp_dbsboreal (:) !11
+ real(r8), allocatable :: a_gpp_c3arcgrass (:) !12
+ real(r8), allocatable :: a_gpp_c3grass (:) !13
+ real(r8), allocatable :: a_gpp_c4grass (:) !14
+ real(r8), allocatable :: a_npp_enftemp (:) !1
+ real(r8), allocatable :: a_npp_enfboreal (:) !2
+ real(r8), allocatable :: a_npp_dnfboreal (:) !3
+ real(r8), allocatable :: a_npp_ebftrop (:) !4
+ real(r8), allocatable :: a_npp_ebftemp (:) !5
+ real(r8), allocatable :: a_npp_dbftrop (:) !6
+ real(r8), allocatable :: a_npp_dbftemp (:) !7
+ real(r8), allocatable :: a_npp_dbfboreal (:) !8
+ real(r8), allocatable :: a_npp_ebstemp (:) !9
+ real(r8), allocatable :: a_npp_dbstemp (:) !10
+ real(r8), allocatable :: a_npp_dbsboreal (:) !11
+ real(r8), allocatable :: a_npp_c3arcgrass (:) !12
+ real(r8), allocatable :: a_npp_c3grass (:) !13
+ real(r8), allocatable :: a_npp_c4grass (:) !14
+ real(r8), allocatable :: a_npptoleafc_enftemp (:) !1
+ real(r8), allocatable :: a_npptoleafc_enfboreal (:) !2
+ real(r8), allocatable :: a_npptoleafc_dnfboreal (:) !3
+ real(r8), allocatable :: a_npptoleafc_ebftrop (:) !4
+ real(r8), allocatable :: a_npptoleafc_ebftemp (:) !5
+ real(r8), allocatable :: a_npptoleafc_dbftrop (:) !6
+ real(r8), allocatable :: a_npptoleafc_dbftemp (:) !7
+ real(r8), allocatable :: a_npptoleafc_dbfboreal (:) !8
+ real(r8), allocatable :: a_npptoleafc_ebstemp (:) !9
+ real(r8), allocatable :: a_npptoleafc_dbstemp (:) !10
+ real(r8), allocatable :: a_npptoleafc_dbsboreal (:) !11
+ real(r8), allocatable :: a_npptoleafc_c3arcgrass (:) !12
+ real(r8), allocatable :: a_npptoleafc_c3grass (:) !13
+ real(r8), allocatable :: a_npptoleafc_c4grass (:) !14
+ real(r8), allocatable :: a_leafc_enftemp (:) !1
+ real(r8), allocatable :: a_leafc_enfboreal (:) !2
+ real(r8), allocatable :: a_leafc_dnfboreal (:) !3
+ real(r8), allocatable :: a_leafc_ebftrop (:) !4
+ real(r8), allocatable :: a_leafc_ebftemp (:) !5
+ real(r8), allocatable :: a_leafc_dbftrop (:) !6
+ real(r8), allocatable :: a_leafc_dbftemp (:) !7
+ real(r8), allocatable :: a_leafc_dbfboreal (:) !8
+ real(r8), allocatable :: a_leafc_ebstemp (:) !9
+ real(r8), allocatable :: a_leafc_dbstemp (:) !10
+ real(r8), allocatable :: a_leafc_dbsboreal (:) !11
+ real(r8), allocatable :: a_leafc_c3arcgrass (:) !12
+ real(r8), allocatable :: a_leafc_c3grass (:) !13
+ real(r8), allocatable :: a_leafc_c4grass (:) !14
+ real(r8), allocatable :: a_O2_DECOMP_DEPTH_UNSAT (:,:)
+ real(r8), allocatable :: a_CONC_O2_UNSAT (:,:)
+#ifdef CROP
+ real(r8), allocatable :: a_pdcorn (:)
+ real(r8), allocatable :: a_pdswheat (:)
+ real(r8), allocatable :: a_pdwwheat (:)
+ real(r8), allocatable :: a_pdsoybean (:)
+ real(r8), allocatable :: a_pdcotton (:)
+ real(r8), allocatable :: a_pdrice1 (:)
+ real(r8), allocatable :: a_pdrice2 (:)
+ real(r8), allocatable :: a_pdsugarcane (:)
+ real(r8), allocatable :: a_plantdate (:)
+ real(r8), allocatable :: a_manunitro (:)
+ real(r8), allocatable :: a_fertnitro_corn (:)
+ real(r8), allocatable :: a_fertnitro_swheat (:)
+ real(r8), allocatable :: a_fertnitro_wwheat (:)
+ real(r8), allocatable :: a_fertnitro_soybean (:)
+ real(r8), allocatable :: a_fertnitro_cotton (:)
+ real(r8), allocatable :: a_fertnitro_rice1 (:)
+ real(r8), allocatable :: a_fertnitro_rice2 (:)
+ real(r8), allocatable :: a_fertnitro_sugarcane (:)
+ real(r8), allocatable :: a_irrig_method_corn (:)
+ real(r8), allocatable :: a_irrig_method_swheat (:)
+ real(r8), allocatable :: a_irrig_method_wwheat (:)
+ real(r8), allocatable :: a_irrig_method_soybean (:)
+ real(r8), allocatable :: a_irrig_method_cotton (:)
+ real(r8), allocatable :: a_irrig_method_rice1 (:)
+ real(r8), allocatable :: a_irrig_method_rice2 (:)
+ real(r8), allocatable :: a_irrig_method_sugarcane(:)
+
+ real(r8), allocatable :: a_cphase (:)
+ real(r8), allocatable :: a_gddplant (:)
+ real(r8), allocatable :: a_gddmaturity (:)
+ real(r8), allocatable :: a_vf (:)
+ real(r8), allocatable :: a_hui (:)
+ real(r8), allocatable :: a_cropprod1c (:)
+ real(r8), allocatable :: a_cropprod1c_loss (:)
+ real(r8), allocatable :: a_cropseedc_deficit (:)
+ real(r8), allocatable :: a_grainc_to_cropprodc (:)
+ real(r8), allocatable :: a_grainc_to_seed (:)
+ real(r8), allocatable :: a_fert_to_sminn (:)
+
+ real(r8), allocatable :: a_sum_irrig (:)
+ real(r8), allocatable :: a_sum_deficit_irrig (:)
+ real(r8), allocatable :: a_sum_irrig_count (:)
+ real(r8), allocatable :: a_waterstorage (:)
+ real(r8), allocatable :: a_groundwater_demand (:)
+ real(r8), allocatable :: a_groundwater_supply (:)
+ real(r8), allocatable :: a_reservoirriver_demand(:)
+ real(r8), allocatable :: a_reservoirriver_supply(:)
+ real(r8), allocatable :: a_reservoir_supply (:)
+ real(r8), allocatable :: a_river_supply (:)
+ real(r8), allocatable :: a_runoff_supply (:)
+#endif
+ real(r8), allocatable :: a_ndep_to_sminn (:)
+ real(r8), allocatable :: a_abm (:)
+ real(r8), allocatable :: a_gdp (:)
+ real(r8), allocatable :: a_peatf (:)
+ real(r8), allocatable :: a_hdm (:)
+ real(r8), allocatable :: a_lnfm (:)
+ real(r8), allocatable :: a_leafcCap (:)
+ real(r8), allocatable :: a_leafc_storageCap (:)
+ real(r8), allocatable :: a_leafc_xferCap (:)
+ real(r8), allocatable :: a_frootcCap (:)
+ real(r8), allocatable :: a_frootc_storageCap (:)
+ real(r8), allocatable :: a_frootc_xferCap (:)
+ real(r8), allocatable :: a_livestemcCap (:)
+ real(r8), allocatable :: a_livestemc_storageCap (:)
+ real(r8), allocatable :: a_livestemc_xferCap (:)
+ real(r8), allocatable :: a_deadstemcCap (:)
+ real(r8), allocatable :: a_deadstemc_storageCap (:)
+ real(r8), allocatable :: a_deadstemc_xferCap (:)
+ real(r8), allocatable :: a_livecrootcCap (:)
+ real(r8), allocatable :: a_livecrootc_storageCap (:)
+ real(r8), allocatable :: a_livecrootc_xferCap (:)
+ real(r8), allocatable :: a_deadcrootcCap (:)
+ real(r8), allocatable :: a_deadcrootc_storageCap (:)
+ real(r8), allocatable :: a_deadcrootc_xferCap (:)
+ real(r8), allocatable :: a_leafnCap (:)
+ real(r8), allocatable :: a_leafn_storageCap (:)
+ real(r8), allocatable :: a_leafn_xferCap (:)
+ real(r8), allocatable :: a_frootnCap (:)
+ real(r8), allocatable :: a_frootn_storageCap (:)
+ real(r8), allocatable :: a_frootn_xferCap (:)
+ real(r8), allocatable :: a_livestemnCap (:)
+ real(r8), allocatable :: a_livestemn_storageCap (:)
+ real(r8), allocatable :: a_livestemn_xferCap (:)
+ real(r8), allocatable :: a_deadstemnCap (:)
+ real(r8), allocatable :: a_deadstemn_storageCap (:)
+ real(r8), allocatable :: a_deadstemn_xferCap (:)
+ real(r8), allocatable :: a_livecrootnCap (:)
+ real(r8), allocatable :: a_livecrootn_storageCap (:)
+ real(r8), allocatable :: a_livecrootn_xferCap (:)
+ real(r8), allocatable :: a_deadcrootnCap (:)
+ real(r8), allocatable :: a_deadcrootn_storageCap (:)
+ real(r8), allocatable :: a_deadcrootn_xferCap (:)
+#endif
+! Ozone stress variables
+ real(r8), allocatable :: a_ozone (:)
+! End ozone stress variables
+
+ real(r8), allocatable :: a_t_soisno (:,:)
+ real(r8), allocatable :: a_wliq_soisno (:,:)
+ real(r8), allocatable :: a_wice_soisno (:,:)
+ real(r8), allocatable :: a_h2osoi (:,:)
+ real(r8), allocatable :: a_qlayer (:,:)
+ real(r8), allocatable :: a_lake_deficit (:)
+ real(r8), allocatable :: a_rootr (:,:)
+ real(r8), allocatable :: a_BD_all (:,:)
+ real(r8), allocatable :: a_wfc (:,:)
+ real(r8), allocatable :: a_OM_density (:,:)
+!Plant Hydraulic parameters
+ real(r8), allocatable :: a_vegwp (:,:)
+!END plant hydraulic parameters
+ real(r8), allocatable :: a_dz_lake (:,:)
+ real(r8), allocatable :: a_t_lake (:,:)
+ real(r8), allocatable :: a_lake_icefrac(:,:)
+
+#ifdef BGC
+ real(r8), allocatable :: a_litr1c_vr (:,:)
+ real(r8), allocatable :: a_litr2c_vr (:,:)
+ real(r8), allocatable :: a_litr3c_vr (:,:)
+ real(r8), allocatable :: a_soil1c_vr (:,:)
+ real(r8), allocatable :: a_soil2c_vr (:,:)
+ real(r8), allocatable :: a_soil3c_vr (:,:)
+ real(r8), allocatable :: a_cwdc_vr (:,:)
+ real(r8), allocatable :: a_litr1n_vr (:,:)
+ real(r8), allocatable :: a_litr2n_vr (:,:)
+ real(r8), allocatable :: a_litr3n_vr (:,:)
+ real(r8), allocatable :: a_soil1n_vr (:,:)
+ real(r8), allocatable :: a_soil2n_vr (:,:)
+ real(r8), allocatable :: a_soil3n_vr (:,:)
+ real(r8), allocatable :: a_cwdn_vr (:,:)
+ real(r8), allocatable :: a_totsoiln_vr (:,:)
+ real(r8), allocatable :: a_litr1cCap_vr(:,:)
+ real(r8), allocatable :: a_litr2cCap_vr(:,:)
+ real(r8), allocatable :: a_litr3cCap_vr(:,:)
+ real(r8), allocatable :: a_soil1cCap_vr(:,:)
+ real(r8), allocatable :: a_soil2cCap_vr(:,:)
+ real(r8), allocatable :: a_soil3cCap_vr(:,:)
+ real(r8), allocatable :: a_cwdcCap_vr (:,:)
+ real(r8), allocatable :: a_litr1nCap_vr(:,:)
+ real(r8), allocatable :: a_litr2nCap_vr(:,:)
+ real(r8), allocatable :: a_litr3nCap_vr(:,:)
+ real(r8), allocatable :: a_soil1nCap_vr(:,:)
+ real(r8), allocatable :: a_soil2nCap_vr(:,:)
+ real(r8), allocatable :: a_soil3nCap_vr(:,:)
+ real(r8), allocatable :: a_cwdnCap_vr (:,:)
+ real(r8), allocatable :: a_t_scalar (:,:)
+ real(r8), allocatable :: a_w_scalar (:,:)
+ real(r8), allocatable :: a_sminn_vr (:,:)
+ real(r8), allocatable :: decomp_vr_tmp (:,:)
+#endif
+
+ real(r8), allocatable :: a_ustar (:)
+ real(r8), allocatable :: a_ustar2 (:)
+ real(r8), allocatable :: a_tstar (:)
+ real(r8), allocatable :: a_qstar (:)
+ real(r8), allocatable :: a_zol (:)
+ real(r8), allocatable :: a_rib (:)
+ real(r8), allocatable :: a_fm (:)
+ real(r8), allocatable :: a_fh (:)
+ real(r8), allocatable :: a_fq (:)
+
+ real(r8), allocatable :: a_us10m (:)
+ real(r8), allocatable :: a_vs10m (:)
+ real(r8), allocatable :: a_fm10m (:)
+
+ real(r8), allocatable :: a_sr (:)
+ real(r8), allocatable :: a_solvd (:)
+ real(r8), allocatable :: a_solvi (:)
+ real(r8), allocatable :: a_solnd (:)
+ real(r8), allocatable :: a_solni (:)
+ real(r8), allocatable :: a_srvd (:)
+ real(r8), allocatable :: a_srvi (:)
+ real(r8), allocatable :: a_srnd (:)
+ real(r8), allocatable :: a_srni (:)
+ real(r8), allocatable :: a_solvdln (:)
+ real(r8), allocatable :: a_solviln (:)
+ real(r8), allocatable :: a_solndln (:)
+ real(r8), allocatable :: a_solniln (:)
+ real(r8), allocatable :: a_srvdln (:)
+ real(r8), allocatable :: a_srviln (:)
+ real(r8), allocatable :: a_srndln (:)
+ real(r8), allocatable :: a_srniln (:)
+#ifdef HYPERSPECTRAL
+ real(r8), allocatable :: a_sol_dir_ln_hires(:,:)
+ real(r8), allocatable :: a_sol_dif_ln_hires(:,:)
+ real(r8), allocatable :: a_sr_dir_ln_hires (:,:)
+ real(r8), allocatable :: a_sr_dif_ln_hires (:,:)
+#endif
+ real(r8), allocatable :: a_sensors (:,:)
+
+ PUBLIC :: allocate_acc_fluxes
+ PUBLIC :: deallocate_acc_fluxes
+ PUBLIC :: flush_acc_fluxes
+ PUBLIC :: accumulate_fluxes
+
+CONTAINS
+
+ SUBROUTINE allocate_acc_fluxes
+
+ USE MOD_SPMD_Task
+ USE MOD_LandElm
+ USE MOD_LandPatch
+ USE MOD_LandUrban, only: numurban
+ USE MOD_Vars_1DFluxes, only: nsensor
+#ifdef CROP
+ USE MOD_LandCrop
+#endif
+ USE MOD_Vars_Global
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ allocate (a_us (numpatch))
+ allocate (a_vs (numpatch))
+ allocate (a_t (numpatch))
+ allocate (a_q (numpatch))
+ allocate (a_prc (numpatch))
+ allocate (a_prl (numpatch))
+ allocate (a_pbot (numpatch))
+ allocate (a_frl (numpatch))
+ allocate (a_solarin (numpatch))
+ allocate (a_hpbl (numpatch))
+
+ allocate (a_taux (numpatch))
+ allocate (a_tauy (numpatch))
+ allocate (a_fsena (numpatch))
+ allocate (a_lfevpa (numpatch))
+ allocate (a_fevpa (numpatch))
+ allocate (a_fsenl (numpatch))
+ allocate (a_fevpl (numpatch))
+ allocate (a_etr (numpatch))
+ allocate (a_fseng (numpatch))
+ allocate (a_fevpg (numpatch))
+ allocate (a_fgrnd (numpatch))
+ allocate (a_sabvsun (numpatch))
+ allocate (a_sabvsha (numpatch))
+ allocate (a_sabg (numpatch))
+ allocate (a_olrg (numpatch))
+ allocate (a_rnet (numpatch))
+ allocate (a_xerr (numpatch))
+ allocate (a_zerr (numpatch))
+ allocate (a_rsur (numpatch))
+ allocate (a_rsur_se (numpatch))
+ allocate (a_rsur_ie (numpatch))
+ allocate (a_rsub (numpatch))
+ allocate (a_rnof (numpatch))
+#ifdef CatchLateralFlow
+ allocate (a_xwsur (numpatch))
+ allocate (a_xwsub (numpatch))
+ allocate (a_fldarea (numpatch))
+#endif
+ allocate (a_qintr (numpatch))
+ allocate (a_qinfl (numpatch))
+ allocate (a_qdrip (numpatch))
+ allocate (a_rstfacsun (numpatch))
+ allocate (a_rstfacsha (numpatch))
+ allocate (a_gssun (numpatch))
+ allocate (a_gssha (numpatch))
+ allocate (a_rss (numpatch))
+ allocate (a_wdsrf (numpatch))
+
+ allocate (a_zwt (numpatch))
+ allocate (a_wa (numpatch))
+ allocate (a_wat (numpatch))
+ allocate (a_wetwat (numpatch))
+ allocate (a_assim (numpatch))
+ allocate (a_respc (numpatch))
+
+ allocate (a_assimsun (numpatch))
+ allocate (a_assimsha (numpatch))
+ allocate (a_etrsun (numpatch))
+ allocate (a_etrsha (numpatch))
+
+ allocate (a_qcharge (numpatch))
+
+ allocate (a_t_grnd (numpatch))
+ allocate (a_tleaf (numpatch))
+ allocate (a_ldew_rain (numpatch))
+ allocate (a_ldew_snow (numpatch))
+ allocate (a_ldew (numpatch))
+ allocate (a_scv (numpatch))
+ allocate (a_snowdp (numpatch))
+ allocate (a_fsno (numpatch))
+ allocate (a_frcsat (numpatch))
+ allocate (a_sigf (numpatch))
+ allocate (a_green (numpatch))
+ allocate (a_lai (numpatch))
+ allocate (a_laisun (numpatch))
+ allocate (a_laisha (numpatch))
+ allocate (a_sai (numpatch))
+
+ allocate (a_alb (2 ,2,numpatch))
+#ifdef HYPERSPECTRAL
+ allocate (a_alb_hires (211,2,numpatch))
+ allocate (a_reflectance_out (211,16,numpatch))
+ allocate (a_transmittance_out(211,16,numpatch))
+#endif
+ allocate (a_emis (numpatch))
+ allocate (a_z0m (numpatch))
+ allocate (a_trad (numpatch))
+ allocate (a_tref (numpatch))
+ allocate (a_t2m_wmo (numpatch))
+ allocate (a_qref (numpatch))
+ allocate (a_rain (numpatch))
+ allocate (a_snow (numpatch))
+
+ allocate (a_o3uptakesun(numpatch))
+ allocate (a_o3uptakesha(numpatch))
+
+#ifdef DataAssimilation
+ allocate (a_h2osoi_ens (1:nl_soil,DEF_DA_ENS_NUM,numpatch))
+ allocate (a_t_brt_smap_ens (2,DEF_DA_ENS_NUM,numpatch))
+ allocate (a_t_brt_fy3d_ens (2,DEF_DA_ENS_NUM,numpatch))
+ allocate (a_t_brt_smap (2,numpatch))
+ allocate (a_t_brt_fy3d (2,numpatch))
+ allocate (a_wliq_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch))
+ allocate (a_wice_soisno_ens(maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch))
+ allocate (a_t_soisno_ens (maxsnl+1:nl_soil,DEF_DA_ENS_NUM,numpatch))
+#endif
+
+#ifdef URBAN_MODEL
+ IF (numurban > 0) THEN
+ allocate (a_t_room (numurban))
+ allocate (a_tafu (numurban))
+ allocate (a_fhac (numurban))
+ allocate (a_fwst (numurban))
+ allocate (a_fach (numurban))
+ allocate (a_fahe (numurban))
+ allocate (a_fhah (numurban))
+ allocate (a_vehc (numurban))
+ allocate (a_meta (numurban))
+
+ allocate (a_senroof (numurban))
+ allocate (a_senwsun (numurban))
+ allocate (a_senwsha (numurban))
+ allocate (a_sengimp (numurban))
+ allocate (a_sengper (numurban))
+ allocate (a_senurbl (numurban))
+
+ allocate (a_lfevproof (numurban))
+ allocate (a_lfevpgimp (numurban))
+ allocate (a_lfevpgper (numurban))
+ allocate (a_lfevpurbl (numurban))
+
+ allocate (a_troof (numurban))
+ allocate (a_twall (numurban))
+ ENDIF
+#endif
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ allocate (a_lai_enftemp (numpatch))
+ allocate (a_lai_enfboreal (numpatch))
+ allocate (a_lai_dnfboreal (numpatch))
+ allocate (a_lai_ebftrop (numpatch))
+ allocate (a_lai_ebftemp (numpatch))
+ allocate (a_lai_dbftrop (numpatch))
+ allocate (a_lai_dbftemp (numpatch))
+ allocate (a_lai_dbfboreal (numpatch))
+ allocate (a_lai_ebstemp (numpatch))
+ allocate (a_lai_dbstemp (numpatch))
+ allocate (a_lai_dbsboreal (numpatch))
+ allocate (a_lai_c3arcgrass (numpatch))
+ allocate (a_lai_c3grass (numpatch))
+ allocate (a_lai_c4grass (numpatch))
+#endif
+#ifdef BGC
+ allocate (a_leafc (numpatch))
+ allocate (a_leafc_storage (numpatch))
+ allocate (a_leafc_xfer (numpatch))
+ allocate (a_frootc (numpatch))
+ allocate (a_frootc_storage (numpatch))
+ allocate (a_frootc_xfer (numpatch))
+ allocate (a_livestemc (numpatch))
+ allocate (a_livestemc_storage (numpatch))
+ allocate (a_livestemc_xfer (numpatch))
+ allocate (a_deadstemc (numpatch))
+ allocate (a_deadstemc_storage (numpatch))
+ allocate (a_deadstemc_xfer (numpatch))
+ allocate (a_livecrootc (numpatch))
+ allocate (a_livecrootc_storage (numpatch))
+ allocate (a_livecrootc_xfer (numpatch))
+ allocate (a_deadcrootc (numpatch))
+ allocate (a_deadcrootc_storage (numpatch))
+ allocate (a_deadcrootc_xfer (numpatch))
+ allocate (a_grainc (numpatch))
+ allocate (a_grainc_storage (numpatch))
+ allocate (a_grainc_xfer (numpatch))
+ allocate (a_leafn (numpatch))
+ allocate (a_leafn_storage (numpatch))
+ allocate (a_leafn_xfer (numpatch))
+ allocate (a_frootn (numpatch))
+ allocate (a_frootn_storage (numpatch))
+ allocate (a_frootn_xfer (numpatch))
+ allocate (a_livestemn (numpatch))
+ allocate (a_livestemn_storage (numpatch))
+ allocate (a_livestemn_xfer (numpatch))
+ allocate (a_deadstemn (numpatch))
+ allocate (a_deadstemn_storage (numpatch))
+ allocate (a_deadstemn_xfer (numpatch))
+ allocate (a_livecrootn (numpatch))
+ allocate (a_livecrootn_storage (numpatch))
+ allocate (a_livecrootn_xfer (numpatch))
+ allocate (a_deadcrootn (numpatch))
+ allocate (a_deadcrootn_storage (numpatch))
+ allocate (a_deadcrootn_xfer (numpatch))
+ allocate (a_grainn (numpatch))
+ allocate (a_grainn_storage (numpatch))
+ allocate (a_grainn_xfer (numpatch))
+ allocate (a_retransn (numpatch))
+ allocate (a_gpp (numpatch))
+ allocate (a_downreg (numpatch))
+ allocate (a_ar (numpatch))
+ allocate (a_cwdprod (numpatch))
+ allocate (a_cwddecomp (numpatch))
+ allocate (a_hr (numpatch))
+ allocate (a_fpg (numpatch))
+ allocate (a_fpi (numpatch))
+ allocate (a_totvegc (numpatch))
+ allocate (a_totlitc (numpatch))
+ allocate (a_totcwdc (numpatch))
+ allocate (a_totsomc (numpatch))
+ allocate (a_totcolc (numpatch))
+ allocate (a_totvegn (numpatch))
+ allocate (a_totlitn (numpatch))
+ allocate (a_totcwdn (numpatch))
+ allocate (a_totsomn (numpatch))
+ allocate (a_totcoln (numpatch))
+ allocate (a_gpp_enftemp (numpatch)) !1
+ allocate (a_gpp_enfboreal (numpatch)) !2
+ allocate (a_gpp_dnfboreal (numpatch)) !3
+ allocate (a_gpp_ebftrop (numpatch)) !4
+ allocate (a_gpp_ebftemp (numpatch)) !5
+ allocate (a_gpp_dbftrop (numpatch)) !6
+ allocate (a_gpp_dbftemp (numpatch)) !7
+ allocate (a_gpp_dbfboreal (numpatch)) !8
+ allocate (a_gpp_ebstemp (numpatch)) !9
+ allocate (a_gpp_dbstemp (numpatch)) !10
+ allocate (a_gpp_dbsboreal (numpatch)) !11
+ allocate (a_gpp_c3arcgrass (numpatch)) !12
+ allocate (a_gpp_c3grass (numpatch)) !13
+ allocate (a_gpp_c4grass (numpatch)) !14
+ allocate (a_npp_enftemp (numpatch)) !1
+ allocate (a_npp_enfboreal (numpatch)) !2
+ allocate (a_npp_dnfboreal (numpatch)) !3
+ allocate (a_npp_ebftrop (numpatch)) !4
+ allocate (a_npp_ebftemp (numpatch)) !5
+ allocate (a_npp_dbftrop (numpatch)) !6
+ allocate (a_npp_dbftemp (numpatch)) !7
+ allocate (a_npp_dbfboreal (numpatch)) !8
+ allocate (a_npp_ebstemp (numpatch)) !9
+ allocate (a_npp_dbstemp (numpatch)) !10
+ allocate (a_npp_dbsboreal (numpatch)) !11
+ allocate (a_npp_c3arcgrass (numpatch)) !12
+ allocate (a_npp_c3grass (numpatch)) !13
+ allocate (a_npp_c4grass (numpatch)) !14
+ allocate (a_npptoleafc_enftemp (numpatch)) !1
+ allocate (a_npptoleafc_enfboreal (numpatch)) !2
+ allocate (a_npptoleafc_dnfboreal (numpatch)) !3
+ allocate (a_npptoleafc_ebftrop (numpatch)) !4
+ allocate (a_npptoleafc_ebftemp (numpatch)) !5
+ allocate (a_npptoleafc_dbftrop (numpatch)) !6
+ allocate (a_npptoleafc_dbftemp (numpatch)) !7
+ allocate (a_npptoleafc_dbfboreal (numpatch)) !8
+ allocate (a_npptoleafc_ebstemp (numpatch)) !9
+ allocate (a_npptoleafc_dbstemp (numpatch)) !10
+ allocate (a_npptoleafc_dbsboreal (numpatch)) !11
+ allocate (a_npptoleafc_c3arcgrass (numpatch)) !12
+ allocate (a_npptoleafc_c3grass (numpatch)) !13
+ allocate (a_npptoleafc_c4grass (numpatch)) !14
+ allocate (a_leafc_enftemp (numpatch)) !1
+ allocate (a_leafc_enfboreal (numpatch)) !2
+ allocate (a_leafc_dnfboreal (numpatch)) !3
+ allocate (a_leafc_ebftrop (numpatch)) !4
+ allocate (a_leafc_ebftemp (numpatch)) !5
+ allocate (a_leafc_dbftrop (numpatch)) !6
+ allocate (a_leafc_dbftemp (numpatch)) !7
+ allocate (a_leafc_dbfboreal (numpatch)) !8
+ allocate (a_leafc_ebstemp (numpatch)) !9
+ allocate (a_leafc_dbstemp (numpatch)) !10
+ allocate (a_leafc_dbsboreal (numpatch)) !11
+ allocate (a_leafc_c3arcgrass (numpatch)) !12
+ allocate (a_leafc_c3grass (numpatch)) !13
+ allocate (a_leafc_c4grass (numpatch)) !14
+
+ allocate (a_O2_DECOMP_DEPTH_UNSAT (1:nl_soil,numpatch))
+ allocate (a_CONC_O2_UNSAT (1:nl_soil,numpatch))
+
+#ifdef CROP
+ allocate (a_pdcorn (numpatch))
+ allocate (a_pdswheat (numpatch))
+ allocate (a_pdwwheat (numpatch))
+ allocate (a_pdsoybean (numpatch))
+ allocate (a_pdcotton (numpatch))
+ allocate (a_pdrice1 (numpatch))
+ allocate (a_pdrice2 (numpatch))
+ allocate (a_pdsugarcane (numpatch))
+ allocate (a_plantdate (numpatch))
+ allocate (a_manunitro (numpatch))
+ allocate (a_fertnitro_corn (numpatch))
+ allocate (a_fertnitro_swheat (numpatch))
+ allocate (a_fertnitro_wwheat (numpatch))
+ allocate (a_fertnitro_soybean (numpatch))
+ allocate (a_fertnitro_cotton (numpatch))
+ allocate (a_fertnitro_rice1 (numpatch))
+ allocate (a_fertnitro_rice2 (numpatch))
+ allocate (a_fertnitro_sugarcane(numpatch))
+ allocate (a_irrig_method_corn (numpatch))
+ allocate (a_irrig_method_swheat (numpatch))
+ allocate (a_irrig_method_wwheat (numpatch))
+ allocate (a_irrig_method_soybean (numpatch))
+ allocate (a_irrig_method_cotton (numpatch))
+ allocate (a_irrig_method_rice1 (numpatch))
+ allocate (a_irrig_method_rice2 (numpatch))
+ allocate (a_irrig_method_sugarcane(numpatch))
+ allocate (a_cphase (numpatch))
+ allocate (a_hui (numpatch))
+ allocate (a_gddmaturity (numpatch))
+ allocate (a_gddplant (numpatch))
+ allocate (a_vf (numpatch))
+ allocate (a_cropprod1c (numpatch))
+ allocate (a_cropprod1c_loss (numpatch))
+ allocate (a_cropseedc_deficit (numpatch))
+ allocate (a_grainc_to_cropprodc(numpatch))
+ allocate (a_grainc_to_seed (numpatch))
+ allocate (a_fert_to_sminn (numpatch))
+
+ allocate (a_sum_irrig (numpatch))
+ allocate (a_sum_deficit_irrig (numpatch))
+ allocate (a_sum_irrig_count (numpatch))
+ allocate (a_waterstorage (numpatch))
+ allocate (a_groundwater_demand (numpatch))
+ allocate (a_groundwater_supply (numpatch))
+ allocate (a_reservoirriver_demand(numpatch))
+ allocate (a_reservoirriver_supply(numpatch))
+ allocate (a_reservoir_supply (numpatch))
+ allocate (a_river_supply (numpatch))
+ allocate (a_runoff_supply (numpatch))
+#endif
+ allocate (a_ndep_to_sminn (numpatch))
+
+ allocate (a_abm (numpatch))
+ allocate (a_gdp (numpatch))
+ allocate (a_peatf (numpatch))
+ allocate (a_hdm (numpatch))
+ allocate (a_lnfm (numpatch))
+
+ allocate (a_leafcCap (numpatch))
+ allocate (a_leafc_storageCap (numpatch))
+ allocate (a_leafc_xferCap (numpatch))
+ allocate (a_frootcCap (numpatch))
+ allocate (a_frootc_storageCap (numpatch))
+ allocate (a_frootc_xferCap (numpatch))
+ allocate (a_livestemcCap (numpatch))
+ allocate (a_livestemc_storageCap (numpatch))
+ allocate (a_livestemc_xferCap (numpatch))
+ allocate (a_deadstemcCap (numpatch))
+ allocate (a_deadstemc_storageCap (numpatch))
+ allocate (a_deadstemc_xferCap (numpatch))
+ allocate (a_livecrootcCap (numpatch))
+ allocate (a_livecrootc_storageCap (numpatch))
+ allocate (a_livecrootc_xferCap (numpatch))
+ allocate (a_deadcrootcCap (numpatch))
+ allocate (a_deadcrootc_storageCap (numpatch))
+ allocate (a_deadcrootc_xferCap (numpatch))
+ allocate (a_leafnCap (numpatch))
+ allocate (a_leafn_storageCap (numpatch))
+ allocate (a_leafn_xferCap (numpatch))
+ allocate (a_frootnCap (numpatch))
+ allocate (a_frootn_storageCap (numpatch))
+ allocate (a_frootn_xferCap (numpatch))
+ allocate (a_livestemnCap (numpatch))
+ allocate (a_livestemn_storageCap (numpatch))
+ allocate (a_livestemn_xferCap (numpatch))
+ allocate (a_deadstemnCap (numpatch))
+ allocate (a_deadstemn_storageCap (numpatch))
+ allocate (a_deadstemn_xferCap (numpatch))
+ allocate (a_livecrootnCap (numpatch))
+ allocate (a_livecrootn_storageCap (numpatch))
+ allocate (a_livecrootn_xferCap (numpatch))
+ allocate (a_deadcrootnCap (numpatch))
+ allocate (a_deadcrootn_storageCap (numpatch))
+ allocate (a_deadcrootn_xferCap (numpatch))
+#endif
+! Ozone stress variables
+ allocate (a_ozone (numpatch))
+! End ozone stress variables
+ allocate (a_t_soisno (maxsnl+1:nl_soil,numpatch))
+ allocate (a_wliq_soisno (maxsnl+1:nl_soil,numpatch))
+ allocate (a_wice_soisno (maxsnl+1:nl_soil,numpatch))
+ allocate (a_h2osoi (1:nl_soil, numpatch))
+ allocate (a_qlayer (0:nl_soil, numpatch))
+ allocate (a_lake_deficit (numpatch))
+ allocate (a_rootr (1:nl_soil, numpatch))
+ allocate (a_BD_all (1:nl_soil, numpatch))
+ allocate (a_wfc (1:nl_soil, numpatch))
+ allocate (a_OM_density (1:nl_soil, numpatch))
+!Plant Hydraulic parameters
+ allocate (a_vegwp (1:nvegwcs, numpatch))
+!End Plant Hydraulic parameters
+ allocate (a_dz_lake (nl_lake, numpatch))
+ allocate (a_t_lake (nl_lake, numpatch))
+ allocate (a_lake_icefrac(nl_lake, numpatch))
+
+#ifdef BGC
+ allocate (a_litr1c_vr (1:nl_soil, numpatch))
+ allocate (a_litr2c_vr (1:nl_soil, numpatch))
+ allocate (a_litr3c_vr (1:nl_soil, numpatch))
+ allocate (a_soil1c_vr (1:nl_soil, numpatch))
+ allocate (a_soil2c_vr (1:nl_soil, numpatch))
+ allocate (a_soil3c_vr (1:nl_soil, numpatch))
+ allocate (a_cwdc_vr (1:nl_soil, numpatch))
+ allocate (a_litr1n_vr (1:nl_soil, numpatch))
+ allocate (a_litr2n_vr (1:nl_soil, numpatch))
+ allocate (a_litr3n_vr (1:nl_soil, numpatch))
+ allocate (a_soil1n_vr (1:nl_soil, numpatch))
+ allocate (a_soil2n_vr (1:nl_soil, numpatch))
+ allocate (a_soil3n_vr (1:nl_soil, numpatch))
+ allocate (a_cwdn_vr (1:nl_soil, numpatch))
+ allocate (a_totsoiln_vr (1:nl_soil, numpatch))
+ allocate (a_sminn_vr (1:nl_soil, numpatch))
+ allocate (decomp_vr_tmp (1:nl_soil, numpatch))
+
+ allocate (a_litr1cCap_vr(1:nl_soil, numpatch))
+ allocate (a_litr2cCap_vr(1:nl_soil, numpatch))
+ allocate (a_litr3cCap_vr(1:nl_soil, numpatch))
+ allocate (a_soil1cCap_vr(1:nl_soil, numpatch))
+ allocate (a_soil2cCap_vr(1:nl_soil, numpatch))
+ allocate (a_soil3cCap_vr(1:nl_soil, numpatch))
+ allocate (a_cwdcCap_vr (1:nl_soil, numpatch))
+ allocate (a_litr1nCap_vr(1:nl_soil, numpatch))
+ allocate (a_litr2nCap_vr(1:nl_soil, numpatch))
+ allocate (a_litr3nCap_vr(1:nl_soil, numpatch))
+ allocate (a_soil1nCap_vr(1:nl_soil, numpatch))
+ allocate (a_soil2nCap_vr(1:nl_soil, numpatch))
+ allocate (a_soil3nCap_vr(1:nl_soil, numpatch))
+ allocate (a_cwdnCap_vr (1:nl_soil, numpatch))
+ allocate (a_t_scalar (1:nl_soil, numpatch))
+ allocate (a_w_scalar (1:nl_soil, numpatch))
+#endif
+
+ allocate (a_ustar (numpatch))
+ allocate (a_ustar2 (numpatch))
+ allocate (a_tstar (numpatch))
+ allocate (a_qstar (numpatch))
+ allocate (a_zol (numpatch))
+ allocate (a_rib (numpatch))
+ allocate (a_fm (numpatch))
+ allocate (a_fh (numpatch))
+ allocate (a_fq (numpatch))
+
+ allocate (a_us10m (numpatch))
+ allocate (a_vs10m (numpatch))
+ allocate (a_fm10m (numpatch))
+
+ allocate (a_sr (numpatch))
+ allocate (a_solvd (numpatch))
+ allocate (a_solvi (numpatch))
+ allocate (a_solnd (numpatch))
+ allocate (a_solni (numpatch))
+ allocate (a_srvd (numpatch))
+ allocate (a_srvi (numpatch))
+ allocate (a_srnd (numpatch))
+ allocate (a_srni (numpatch))
+ allocate (a_solvdln (numpatch))
+ allocate (a_solviln (numpatch))
+ allocate (a_solndln (numpatch))
+ allocate (a_solniln (numpatch))
+ allocate (a_srvdln (numpatch))
+ allocate (a_srviln (numpatch))
+ allocate (a_srndln (numpatch))
+ allocate (a_srniln (numpatch))
+#ifdef HYPERSPECTRAL
+ allocate (a_sol_dir_ln_hires(211, numpatch))
+ allocate (a_sol_dif_ln_hires(211, numpatch))
+ allocate (a_sr_dir_ln_hires (211, numpatch))
+ allocate (a_sr_dif_ln_hires (211, numpatch))
+#endif
+ allocate (a_sensors (nsensor,numpatch))
+
+ allocate (nac_ln (numpatch))
+ allocate (nac_dt (numpatch))
+ allocate (filter_dt (numpatch))
+
+ ENDIF
+ ENDIF
+
+#ifdef EXTERNAL_LAKE
+ CALL allocate_LakeAccVars
+#endif
+
+ IF (p_is_compute) THEN
+ CALL elm_patch%build (landelm, landpatch, use_frac = .true.)
+ ENDIF
+
+ END SUBROUTINE allocate_acc_fluxes
+
+ SUBROUTINE deallocate_acc_fluxes ()
+
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ USE MOD_LandUrban, only: numurban
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ deallocate (a_us )
+ deallocate (a_vs )
+ deallocate (a_t )
+ deallocate (a_q )
+ deallocate (a_prc )
+ deallocate (a_prl )
+ deallocate (a_pbot )
+ deallocate (a_frl )
+ deallocate (a_solarin)
+ deallocate (a_hpbl )
+
+ deallocate (a_taux )
+ deallocate (a_tauy )
+ deallocate (a_fsena )
+ deallocate (a_lfevpa )
+ deallocate (a_fevpa )
+ deallocate (a_fsenl )
+ deallocate (a_fevpl )
+ deallocate (a_etr )
+ deallocate (a_fseng )
+ deallocate (a_fevpg )
+ deallocate (a_fgrnd )
+ deallocate (a_sabvsun )
+ deallocate (a_sabvsha )
+ deallocate (a_sabg )
+ deallocate (a_olrg )
+ deallocate (a_rnet )
+ deallocate (a_xerr )
+ deallocate (a_zerr )
+ deallocate (a_rsur )
+ deallocate (a_rsur_se )
+ deallocate (a_rsur_ie )
+ deallocate (a_rsub )
+ deallocate (a_rnof )
+#ifdef CatchLateralFlow
+ deallocate (a_xwsur )
+ deallocate (a_xwsub )
+ deallocate (a_fldarea )
+#endif
+ deallocate (a_qintr )
+ deallocate (a_qinfl )
+ deallocate (a_qdrip )
+ deallocate (a_rstfacsun )
+ deallocate (a_rstfacsha )
+ deallocate (a_gssun )
+ deallocate (a_gssha )
+ deallocate (a_rss )
+ deallocate (a_wdsrf )
+
+ deallocate (a_zwt )
+ deallocate (a_wa )
+ deallocate (a_wat )
+ deallocate (a_wetwat )
+ deallocate (a_assim )
+ deallocate (a_respc )
+
+ deallocate (a_assimsun ) !1
+ deallocate (a_assimsha ) !1
+ deallocate (a_etrsun ) !1
+ deallocate (a_etrsha ) !1
+
+ deallocate (a_qcharge )
+
+ deallocate (a_t_grnd )
+ deallocate (a_tleaf )
+ deallocate (a_ldew_rain )
+ deallocate (a_ldew_snow )
+ deallocate (a_ldew )
+ deallocate (a_scv )
+ deallocate (a_snowdp )
+ deallocate (a_fsno )
+ deallocate (a_frcsat )
+ deallocate (a_sigf )
+ deallocate (a_green )
+ deallocate (a_lai )
+ deallocate (a_laisun )
+ deallocate (a_laisha )
+ deallocate (a_sai )
+
+ deallocate (a_alb )
+#ifdef HYPERSPECTRAL
+ deallocate (a_alb_hires )
+ deallocate (a_reflectance_out )
+ deallocate (a_transmittance_out)
+#endif
+
+ deallocate (a_emis )
+ deallocate (a_z0m )
+ deallocate (a_trad )
+ deallocate (a_tref )
+ deallocate (a_t2m_wmo )
+ deallocate (a_qref )
+ deallocate (a_rain )
+ deallocate (a_snow )
+
+ deallocate (a_o3uptakesun)
+ deallocate (a_o3uptakesha)
+
+#ifdef DataAssimilation
+ deallocate (a_h2osoi_ens )
+ deallocate (a_t_brt_smap_ens )
+ deallocate (a_t_brt_fy3d_ens )
+ deallocate (a_t_brt_fy3d )
+ deallocate (a_t_brt_smap )
+ deallocate (a_wliq_soisno_ens)
+ deallocate (a_wice_soisno_ens)
+ deallocate (a_t_soisno_ens )
+#endif
+
+#ifdef URBAN_MODEL
+ IF (numurban > 0) THEN
+ deallocate (a_t_room )
+ deallocate (a_tafu )
+ deallocate (a_fhac )
+ deallocate (a_fwst )
+ deallocate (a_fach )
+ deallocate (a_fahe )
+ deallocate (a_fhah )
+ deallocate (a_vehc )
+ deallocate (a_meta )
+
+ deallocate (a_senroof )
+ deallocate (a_senwsun )
+ deallocate (a_senwsha )
+ deallocate (a_sengimp )
+ deallocate (a_sengper )
+ deallocate (a_senurbl )
+
+ deallocate (a_lfevproof )
+ deallocate (a_lfevpgimp )
+ deallocate (a_lfevpgper )
+ deallocate (a_lfevpurbl )
+
+ deallocate (a_troof )
+ deallocate (a_twall )
+ ENDIF
+#endif
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ deallocate (a_lai_enftemp )
+ deallocate (a_lai_enfboreal )
+ deallocate (a_lai_dnfboreal )
+ deallocate (a_lai_ebftrop )
+ deallocate (a_lai_ebftemp )
+ deallocate (a_lai_dbftrop )
+ deallocate (a_lai_dbftemp )
+ deallocate (a_lai_dbfboreal )
+ deallocate (a_lai_ebstemp )
+ deallocate (a_lai_dbstemp )
+ deallocate (a_lai_dbsboreal )
+ deallocate (a_lai_c3arcgrass )
+ deallocate (a_lai_c3grass )
+ deallocate (a_lai_c4grass )
+#endif
+
+#ifdef BGC
+ deallocate (a_leafc )
+ deallocate (a_leafc_storage )
+ deallocate (a_leafc_xfer )
+ deallocate (a_frootc )
+ deallocate (a_frootc_storage )
+ deallocate (a_frootc_xfer )
+ deallocate (a_livestemc )
+ deallocate (a_livestemc_storage )
+ deallocate (a_livestemc_xfer )
+ deallocate (a_deadstemc )
+ deallocate (a_deadstemc_storage )
+ deallocate (a_deadstemc_xfer )
+ deallocate (a_livecrootc )
+ deallocate (a_livecrootc_storage )
+ deallocate (a_livecrootc_xfer )
+ deallocate (a_deadcrootc )
+ deallocate (a_deadcrootc_storage )
+ deallocate (a_deadcrootc_xfer )
+ deallocate (a_grainc )
+ deallocate (a_grainc_storage )
+ deallocate (a_grainc_xfer )
+ deallocate (a_leafn )
+ deallocate (a_leafn_storage )
+ deallocate (a_leafn_xfer )
+ deallocate (a_frootn )
+ deallocate (a_frootn_storage )
+ deallocate (a_frootn_xfer )
+ deallocate (a_livestemn )
+ deallocate (a_livestemn_storage )
+ deallocate (a_livestemn_xfer )
+ deallocate (a_deadstemn )
+ deallocate (a_deadstemn_storage )
+ deallocate (a_deadstemn_xfer )
+ deallocate (a_livecrootn )
+ deallocate (a_livecrootn_storage )
+ deallocate (a_livecrootn_xfer )
+ deallocate (a_deadcrootn )
+ deallocate (a_deadcrootn_storage )
+ deallocate (a_deadcrootn_xfer )
+ deallocate (a_grainn )
+ deallocate (a_grainn_storage )
+ deallocate (a_grainn_xfer )
+ deallocate (a_retransn )
+ deallocate (a_gpp )
+ deallocate (a_downreg )
+ deallocate (a_ar )
+ deallocate (a_cwdprod )
+ deallocate (a_cwddecomp )
+ deallocate (a_hr )
+ deallocate (a_fpg )
+ deallocate (a_fpi )
+ deallocate (a_totvegc )
+ deallocate (a_totlitc )
+ deallocate (a_totcwdc )
+ deallocate (a_totsomc )
+ deallocate (a_totcolc )
+ deallocate (a_totvegn )
+ deallocate (a_totlitn )
+ deallocate (a_totcwdn )
+ deallocate (a_totsomn )
+ deallocate (a_totcoln )
+ deallocate (a_gpp_enftemp ) !1
+ deallocate (a_gpp_enfboreal ) !2
+ deallocate (a_gpp_dnfboreal ) !3
+ deallocate (a_gpp_ebftrop ) !4
+ deallocate (a_gpp_ebftemp ) !5
+ deallocate (a_gpp_dbftrop ) !6
+ deallocate (a_gpp_dbftemp ) !7
+ deallocate (a_gpp_dbfboreal ) !8
+ deallocate (a_gpp_ebstemp ) !9
+ deallocate (a_gpp_dbstemp ) !10
+ deallocate (a_gpp_dbsboreal ) !11
+ deallocate (a_gpp_c3arcgrass ) !12
+ deallocate (a_gpp_c3grass ) !13
+ deallocate (a_gpp_c4grass ) !14
+ deallocate (a_npp_enftemp ) !1
+ deallocate (a_npp_enfboreal ) !2
+ deallocate (a_npp_dnfboreal ) !3
+ deallocate (a_npp_ebftrop ) !4
+ deallocate (a_npp_ebftemp ) !5
+ deallocate (a_npp_dbftrop ) !6
+ deallocate (a_npp_dbftemp ) !7
+ deallocate (a_npp_dbfboreal ) !8
+ deallocate (a_npp_ebstemp ) !9
+ deallocate (a_npp_dbstemp ) !10
+ deallocate (a_npp_dbsboreal ) !11
+ deallocate (a_npp_c3arcgrass ) !12
+ deallocate (a_npp_c3grass ) !13
+ deallocate (a_npp_c4grass ) !14
+ deallocate (a_npptoleafc_enftemp ) !1
+ deallocate (a_npptoleafc_enfboreal ) !2
+ deallocate (a_npptoleafc_dnfboreal ) !3
+ deallocate (a_npptoleafc_ebftrop ) !4
+ deallocate (a_npptoleafc_ebftemp ) !5
+ deallocate (a_npptoleafc_dbftrop ) !6
+ deallocate (a_npptoleafc_dbftemp ) !7
+ deallocate (a_npptoleafc_dbfboreal ) !8
+ deallocate (a_npptoleafc_ebstemp ) !9
+ deallocate (a_npptoleafc_dbstemp ) !10
+ deallocate (a_npptoleafc_dbsboreal ) !11
+ deallocate (a_npptoleafc_c3arcgrass ) !12
+ deallocate (a_npptoleafc_c3grass ) !13
+ deallocate (a_npptoleafc_c4grass ) !14
+ deallocate (a_leafc_enftemp ) !1
+ deallocate (a_leafc_enfboreal ) !2
+ deallocate (a_leafc_dnfboreal ) !3
+ deallocate (a_leafc_ebftrop ) !4
+ deallocate (a_leafc_ebftemp ) !5
+ deallocate (a_leafc_dbftrop ) !6
+ deallocate (a_leafc_dbftemp ) !7
+ deallocate (a_leafc_dbfboreal ) !8
+ deallocate (a_leafc_ebstemp ) !9
+ deallocate (a_leafc_dbstemp ) !10
+ deallocate (a_leafc_dbsboreal ) !11
+ deallocate (a_leafc_c3arcgrass ) !12
+ deallocate (a_leafc_c3grass ) !13
+ deallocate (a_leafc_c4grass ) !14
+
+ deallocate (a_O2_DECOMP_DEPTH_UNSAT )
+ deallocate (a_CONC_O2_UNSAT )
+
+#ifdef CROP
+ deallocate (a_pdcorn )
+ deallocate (a_pdswheat )
+ deallocate (a_pdwwheat )
+ deallocate (a_pdsoybean )
+ deallocate (a_pdcotton )
+ deallocate (a_pdrice1 )
+ deallocate (a_pdrice2 )
+ deallocate (a_pdsugarcane )
+ deallocate (a_plantdate )
+ deallocate (a_manunitro )
+ deallocate (a_fertnitro_corn )
+ deallocate (a_fertnitro_swheat )
+ deallocate (a_fertnitro_wwheat )
+ deallocate (a_fertnitro_soybean )
+ deallocate (a_fertnitro_cotton )
+ deallocate (a_fertnitro_rice1 )
+ deallocate (a_fertnitro_rice2 )
+ deallocate (a_fertnitro_sugarcane)
+ deallocate (a_irrig_method_corn )
+ deallocate (a_irrig_method_swheat )
+ deallocate (a_irrig_method_wwheat )
+ deallocate (a_irrig_method_soybean )
+ deallocate (a_irrig_method_cotton )
+ deallocate (a_irrig_method_rice1 )
+ deallocate (a_irrig_method_rice2 )
+ deallocate (a_irrig_method_sugarcane)
+ deallocate (a_cphase )
+ deallocate (a_hui )
+ deallocate (a_vf )
+ deallocate (a_gddmaturity )
+ deallocate (a_gddplant )
+ deallocate (a_cropprod1c )
+ deallocate (a_cropprod1c_loss )
+ deallocate (a_cropseedc_deficit )
+ deallocate (a_grainc_to_cropprodc)
+ deallocate (a_grainc_to_seed )
+ deallocate (a_fert_to_sminn )
+
+ deallocate (a_sum_irrig )
+ deallocate (a_sum_deficit_irrig )
+ deallocate (a_sum_irrig_count )
+ deallocate (a_waterstorage )
+ deallocate (a_groundwater_demand )
+ deallocate (a_groundwater_supply )
+ deallocate (a_reservoirriver_demand)
+ deallocate (a_reservoirriver_supply)
+ deallocate (a_reservoir_supply )
+ deallocate (a_river_supply )
+ deallocate (a_runoff_supply )
+#endif
+ deallocate (a_ndep_to_sminn )
+
+ deallocate (a_abm )
+ deallocate (a_gdp )
+ deallocate (a_peatf )
+ deallocate (a_hdm )
+ deallocate (a_lnfm )
+
+ deallocate (a_leafcCap )
+ deallocate (a_leafc_storageCap )
+ deallocate (a_leafc_xferCap )
+ deallocate (a_frootcCap )
+ deallocate (a_frootc_storageCap )
+ deallocate (a_frootc_xferCap )
+ deallocate (a_livestemcCap )
+ deallocate (a_livestemc_storageCap )
+ deallocate (a_livestemc_xferCap )
+ deallocate (a_deadstemcCap )
+ deallocate (a_deadstemc_storageCap )
+ deallocate (a_deadstemc_xferCap )
+ deallocate (a_livecrootcCap )
+ deallocate (a_livecrootc_storageCap)
+ deallocate (a_livecrootc_xferCap )
+ deallocate (a_deadcrootcCap )
+ deallocate (a_deadcrootc_storageCap)
+ deallocate (a_deadcrootc_xferCap )
+ deallocate (a_leafnCap )
+ deallocate (a_leafn_storageCap )
+ deallocate (a_leafn_xferCap )
+ deallocate (a_frootnCap )
+ deallocate (a_frootn_storageCap )
+ deallocate (a_frootn_xferCap )
+ deallocate (a_livestemnCap )
+ deallocate (a_livestemn_storageCap )
+ deallocate (a_livestemn_xferCap )
+ deallocate (a_deadstemnCap )
+ deallocate (a_deadstemn_storageCap )
+ deallocate (a_deadstemn_xferCap )
+ deallocate (a_livecrootnCap )
+ deallocate (a_livecrootn_storageCap)
+ deallocate (a_livecrootn_xferCap )
+ deallocate (a_deadcrootnCap )
+ deallocate (a_deadcrootn_storageCap)
+ deallocate (a_deadcrootn_xferCap )
+#endif
+! Ozone stress variables
+ deallocate (a_ozone )
+! END ozone stress variables
+
+ deallocate (a_t_soisno )
+ deallocate (a_wliq_soisno )
+ deallocate (a_wice_soisno )
+ deallocate (a_h2osoi )
+ deallocate (a_qlayer )
+ deallocate (a_lake_deficit)
+ deallocate (a_rootr )
+ deallocate (a_BD_all )
+ deallocate (a_wfc )
+ deallocate (a_OM_density )
+!Plant Hydraulic parameters
+ deallocate (a_vegwp )
+!END plant hydraulic parameters
+ deallocate (a_dz_lake )
+ deallocate (a_t_lake )
+ deallocate (a_lake_icefrac)
+#ifdef BGC
+ deallocate (a_litr1c_vr )
+ deallocate (a_litr2c_vr )
+ deallocate (a_litr3c_vr )
+ deallocate (a_soil1c_vr )
+ deallocate (a_soil2c_vr )
+ deallocate (a_soil3c_vr )
+ deallocate (a_cwdc_vr )
+ deallocate (a_litr1n_vr )
+ deallocate (a_litr2n_vr )
+ deallocate (a_litr3n_vr )
+ deallocate (a_soil1n_vr )
+ deallocate (a_soil2n_vr )
+ deallocate (a_soil3n_vr )
+ deallocate (a_cwdn_vr )
+ deallocate (a_totsoiln_vr )
+ deallocate (a_sminn_vr )
+ deallocate (decomp_vr_tmp )
+ deallocate (a_litr1cCap_vr)
+ deallocate (a_litr2cCap_vr)
+ deallocate (a_litr3cCap_vr)
+ deallocate (a_soil1cCap_vr)
+ deallocate (a_soil2cCap_vr)
+ deallocate (a_soil3cCap_vr)
+ deallocate (a_cwdcCap_vr )
+ deallocate (a_litr1nCap_vr)
+ deallocate (a_litr2nCap_vr)
+ deallocate (a_litr3nCap_vr)
+ deallocate (a_soil1nCap_vr)
+ deallocate (a_soil2nCap_vr)
+ deallocate (a_soil3nCap_vr)
+ deallocate (a_cwdnCap_vr )
+ deallocate (a_t_scalar )
+ deallocate (a_w_scalar )
+#endif
+
+ deallocate (a_ustar )
+ deallocate (a_ustar2 )
+ deallocate (a_tstar )
+ deallocate (a_qstar )
+ deallocate (a_zol )
+ deallocate (a_rib )
+ deallocate (a_fm )
+ deallocate (a_fh )
+ deallocate (a_fq )
+
+ deallocate (a_us10m )
+ deallocate (a_vs10m )
+ deallocate (a_fm10m )
+
+ deallocate (a_sr )
+ deallocate (a_solvd )
+ deallocate (a_solvi )
+ deallocate (a_solnd )
+ deallocate (a_solni )
+ deallocate (a_srvd )
+ deallocate (a_srvi )
+ deallocate (a_srnd )
+ deallocate (a_srni )
+ deallocate (a_solvdln )
+ deallocate (a_solviln )
+ deallocate (a_solndln )
+ deallocate (a_solniln )
+ deallocate (a_srvdln )
+ deallocate (a_srviln )
+ deallocate (a_srndln )
+ deallocate (a_srniln )
+#ifdef HYPERSPECTRAL
+ deallocate (a_sol_dir_ln_hires)
+ deallocate (a_sol_dif_ln_hires)
+ deallocate (a_sr_dir_ln_hires )
+ deallocate (a_sr_dif_ln_hires )
+#endif
+ deallocate (a_sensors )
+
+ deallocate (nac_ln )
+ deallocate (nac_dt )
+ deallocate (filter_dt )
+
+ ENDIF
+ ENDIF
+
+#ifdef EXTERNAL_LAKE
+ CALL deallocate_LakeAccVars
+#endif
+
+ END SUBROUTINE deallocate_acc_fluxes
+
+ !-----------------------
+ SUBROUTINE FLUSH_acc_fluxes ()
+
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ USE MOD_LandUrban, only: numurban
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ IF (p_is_compute) THEN
+
+ nac = 0
+
+ IF (numpatch > 0) THEN
+
+ ! flush the Fluxes for accumulation
+ a_us (:) = spval
+ a_vs (:) = spval
+ a_t (:) = spval
+ a_q (:) = spval
+ a_prc (:) = spval
+ a_prl (:) = spval
+ a_pbot (:) = spval
+ a_frl (:) = spval
+ a_solarin (:) = spval
+ a_hpbl (:) = spval
+
+ a_taux (:) = spval
+ a_tauy (:) = spval
+ a_fsena (:) = spval
+ a_lfevpa (:) = spval
+ a_fevpa (:) = spval
+ a_fsenl (:) = spval
+ a_fevpl (:) = spval
+ a_etr (:) = spval
+ a_fseng (:) = spval
+ a_fevpg (:) = spval
+ a_fgrnd (:) = spval
+ a_sabvsun (:) = spval
+ a_sabvsha (:) = spval
+ a_sabg (:) = spval
+ a_olrg (:) = spval
+ a_rnet (:) = spval
+ a_xerr (:) = spval
+ a_zerr (:) = spval
+ a_rsur (:) = spval
+ a_rsur_se (:) = spval
+ a_rsur_ie (:) = spval
+ a_rsub (:) = spval
+ a_rnof (:) = spval
+#ifdef CatchLateralFlow
+ a_xwsur (:) = spval
+ a_xwsub (:) = spval
+ a_fldarea (:) = spval
+#endif
+ a_qintr (:) = spval
+ a_qinfl (:) = spval
+ a_qdrip (:) = spval
+ a_rstfacsun (:) = spval
+ a_rstfacsha (:) = spval
+ a_gssun (:) = spval
+ a_gssha (:) = spval
+ a_rss (:) = spval
+
+ a_wdsrf (:) = spval
+ a_zwt (:) = spval
+ a_wa (:) = spval
+ a_wat (:) = spval
+ a_wetwat (:) = spval
+ a_assim (:) = spval
+ a_respc (:) = spval
+ a_assimsun (:) = spval
+ a_assimsha (:) = spval
+ a_etrsun (:) = spval
+ a_etrsha (:) = spval
+
+ a_qcharge (:) = spval
+
+ a_t_grnd (:) = spval
+ a_tleaf (:) = spval
+ a_ldew_rain (:) = spval
+ a_ldew_snow (:) = spval
+ a_ldew (:) = spval
+ a_scv (:) = spval
+ a_snowdp (:) = spval
+ a_fsno (:) = spval
+ a_frcsat (:) = spval
+ a_sigf (:) = spval
+ a_green (:) = spval
+ a_lai (:) = spval
+ a_laisun (:) = spval
+ a_laisha (:) = spval
+ a_sai (:) = spval
+
+ a_alb (:,:,:) = spval
+
+#ifdef HYPERSPECTRAL
+ a_alb_hires (:,:,:) = spval
+#endif
+
+ a_emis (:) = spval
+ a_z0m (:) = spval
+ a_trad (:) = spval
+ a_tref (:) = spval
+ a_t2m_wmo (:) = spval
+ a_qref (:) = spval
+ a_rain (:) = spval
+ a_snow (:) = spval
+
+ a_o3uptakesun(:) = spval
+ a_o3uptakesha(:) = spval
+
+#ifdef DataAssimilation
+ a_h2osoi_ens (:,:,:) = spval
+ a_t_brt_smap_ens (:,:,:) = spval
+ a_t_brt_fy3d_ens (:,:,:) = spval
+ a_t_brt_fy3d (:,:) = spval
+ a_t_brt_smap (:,:) = spval
+ a_wliq_soisno_ens(:,:,:) = spval
+ a_wice_soisno_ens(:,:,:) = spval
+ a_t_soisno_ens (:,:,:) = spval
+#endif
+
+#ifdef URBAN_MODEL
+ IF (numurban > 0) THEN
+ a_t_room (:) = spval
+ a_tafu (:) = spval
+ a_fhac (:) = spval
+ a_fwst (:) = spval
+ a_fach (:) = spval
+ a_fahe (:) = spval
+ a_fhah (:) = spval
+ a_vehc (:) = spval
+ a_meta (:) = spval
+
+ a_senroof (:) = spval
+ a_senwsun (:) = spval
+ a_senwsha (:) = spval
+ a_sengimp (:) = spval
+ a_sengper (:) = spval
+ a_senurbl (:) = spval
+
+ a_lfevproof(:) = spval
+ a_lfevpgimp(:) = spval
+ a_lfevpgper(:) = spval
+ a_lfevpurbl(:) = spval
+
+ a_troof (:) = spval
+ a_twall (:) = spval
+ ENDIF
+#endif
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ a_lai_enftemp (:) = spval
+ a_lai_enfboreal (:) = spval
+ a_lai_dnfboreal (:) = spval
+ a_lai_ebftrop (:) = spval
+ a_lai_ebftemp (:) = spval
+ a_lai_dbftrop (:) = spval
+ a_lai_dbftemp (:) = spval
+ a_lai_dbfboreal (:) = spval
+ a_lai_ebstemp (:) = spval
+ a_lai_dbstemp (:) = spval
+ a_lai_dbsboreal (:) = spval
+ a_lai_c3arcgrass (:) = spval
+ a_lai_c3grass (:) = spval
+ a_lai_c4grass (:) = spval
+#endif
+#ifdef BGC
+ a_leafc (:) = spval
+ a_leafc_storage (:) = spval
+ a_leafc_xfer (:) = spval
+ a_frootc (:) = spval
+ a_frootc_storage (:) = spval
+ a_frootc_xfer (:) = spval
+ a_livestemc (:) = spval
+ a_livestemc_storage (:) = spval
+ a_livestemc_xfer (:) = spval
+ a_deadstemc (:) = spval
+ a_deadstemc_storage (:) = spval
+ a_deadstemc_xfer (:) = spval
+ a_livecrootc (:) = spval
+ a_livecrootc_storage (:) = spval
+ a_livecrootc_xfer (:) = spval
+ a_deadcrootc (:) = spval
+ a_deadcrootc_storage (:) = spval
+ a_deadcrootc_xfer (:) = spval
+ a_grainc (:) = spval
+ a_grainc_storage (:) = spval
+ a_grainc_xfer (:) = spval
+ a_leafn (:) = spval
+ a_leafn_storage (:) = spval
+ a_leafn_xfer (:) = spval
+ a_frootn (:) = spval
+ a_frootn_storage (:) = spval
+ a_frootn_xfer (:) = spval
+ a_livestemn (:) = spval
+ a_livestemn_storage (:) = spval
+ a_livestemn_xfer (:) = spval
+ a_deadstemn (:) = spval
+ a_deadstemn_storage (:) = spval
+ a_deadstemn_xfer (:) = spval
+ a_livecrootn (:) = spval
+ a_livecrootn_storage (:) = spval
+ a_livecrootn_xfer (:) = spval
+ a_deadcrootn (:) = spval
+ a_deadcrootn_storage (:) = spval
+ a_deadcrootn_xfer (:) = spval
+ a_grainn (:) = spval
+ a_grainn_storage (:) = spval
+ a_grainn_xfer (:) = spval
+ a_retransn (:) = spval
+ a_gpp (:) = spval
+ a_downreg (:) = spval
+ a_ar (:) = spval
+ a_cwdprod (:) = spval
+ a_cwddecomp (:) = spval
+ a_hr (:) = spval
+ a_fpg (:) = spval
+ a_fpi (:) = spval
+ a_totvegc (:) = spval
+ a_totlitc (:) = spval
+ a_totcwdc (:) = spval
+ a_totsomc (:) = spval
+ a_totcolc (:) = spval
+ a_totvegn (:) = spval
+ a_totlitn (:) = spval
+ a_totcwdn (:) = spval
+ a_totsomn (:) = spval
+ a_totcoln (:) = spval
+ a_gpp_enftemp (:) = spval
+ a_gpp_enfboreal (:) = spval
+ a_gpp_dnfboreal (:) = spval
+ a_gpp_ebftrop (:) = spval
+ a_gpp_ebftemp (:) = spval
+ a_gpp_dbftrop (:) = spval
+ a_gpp_dbftemp (:) = spval
+ a_gpp_dbfboreal (:) = spval
+ a_gpp_ebstemp (:) = spval
+ a_gpp_dbstemp (:) = spval
+ a_gpp_dbsboreal (:) = spval
+ a_gpp_c3arcgrass (:) = spval
+ a_gpp_c3grass (:) = spval
+ a_gpp_c4grass (:) = spval
+ a_npp_enftemp (:) = spval
+ a_npp_enfboreal (:) = spval
+ a_npp_dnfboreal (:) = spval
+ a_npp_ebftrop (:) = spval
+ a_npp_ebftemp (:) = spval
+ a_npp_dbftrop (:) = spval
+ a_npp_dbftemp (:) = spval
+ a_npp_dbfboreal (:) = spval
+ a_npp_ebstemp (:) = spval
+ a_npp_dbstemp (:) = spval
+ a_npp_dbsboreal (:) = spval
+ a_npp_c3arcgrass (:) = spval
+ a_npp_c3grass (:) = spval
+ a_npp_c4grass (:) = spval
+ a_npptoleafc_enftemp (:) = spval
+ a_npptoleafc_enfboreal (:) = spval
+ a_npptoleafc_dnfboreal (:) = spval
+ a_npptoleafc_ebftrop (:) = spval
+ a_npptoleafc_ebftemp (:) = spval
+ a_npptoleafc_dbftrop (:) = spval
+ a_npptoleafc_dbftemp (:) = spval
+ a_npptoleafc_dbfboreal (:) = spval
+ a_npptoleafc_ebstemp (:) = spval
+ a_npptoleafc_dbstemp (:) = spval
+ a_npptoleafc_dbsboreal (:) = spval
+ a_npptoleafc_c3arcgrass (:) = spval
+ a_npptoleafc_c3grass (:) = spval
+ a_npptoleafc_c4grass (:) = spval
+ a_leafc_enftemp (:) = spval
+ a_leafc_enfboreal (:) = spval
+ a_leafc_dnfboreal (:) = spval
+ a_leafc_ebftrop (:) = spval
+ a_leafc_ebftemp (:) = spval
+ a_leafc_dbftrop (:) = spval
+ a_leafc_dbftemp (:) = spval
+ a_leafc_dbfboreal (:) = spval
+ a_leafc_ebstemp (:) = spval
+ a_leafc_dbstemp (:) = spval
+ a_leafc_dbsboreal (:) = spval
+ a_leafc_c3arcgrass (:) = spval
+ a_leafc_c3grass (:) = spval
+ a_leafc_c4grass (:) = spval
+
+ a_O2_DECOMP_DEPTH_UNSAT (:,:) = spval
+ a_CONC_O2_UNSAT (:,:) = spval
+#ifdef CROP
+ a_pdcorn (:) = spval
+ a_pdswheat (:) = spval
+ a_pdwwheat (:) = spval
+ a_pdsoybean (:) = spval
+ a_pdcotton (:) = spval
+ a_pdrice1 (:) = spval
+ a_pdrice2 (:) = spval
+ a_pdsugarcane (:) = spval
+ a_plantdate (:) = spval
+ a_manunitro (:) = spval
+ a_fertnitro_corn (:) = spval
+ a_fertnitro_swheat (:) = spval
+ a_fertnitro_wwheat (:) = spval
+ a_fertnitro_soybean (:) = spval
+ a_fertnitro_cotton (:) = spval
+ a_fertnitro_rice1 (:) = spval
+ a_fertnitro_rice2 (:) = spval
+ a_fertnitro_sugarcane(:) = spval
+ a_irrig_method_corn (:) = spval
+ a_irrig_method_swheat (:) = spval
+ a_irrig_method_wwheat (:) = spval
+ a_irrig_method_soybean (:) = spval
+ a_irrig_method_cotton (:) = spval
+ a_irrig_method_rice1 (:) = spval
+ a_irrig_method_rice2 (:) = spval
+ a_irrig_method_sugarcane(:) = spval
+ a_cphase (:) = spval
+ a_vf (:) = spval
+ a_gddmaturity (:) = spval
+ a_gddplant (:) = spval
+ a_hui (:) = spval
+ a_cropprod1c (:) = spval
+ a_cropprod1c_loss (:) = spval
+ a_cropseedc_deficit (:) = spval
+ a_grainc_to_cropprodc(:) = spval
+ a_grainc_to_seed (:) = spval
+ a_fert_to_sminn (:) = spval
+
+ a_sum_irrig (:) = spval
+ a_sum_deficit_irrig (:) = spval
+ a_sum_irrig_count (:) = spval
+ a_waterstorage (:) = spval
+ a_groundwater_demand (:) = spval
+ a_groundwater_supply (:) = spval
+ a_reservoirriver_demand(:) = spval
+ a_reservoirriver_supply(:) = spval
+ a_reservoir_supply (:) = spval
+ a_river_supply (:) = spval
+ a_runoff_supply (:) = spval
+#endif
+ a_ndep_to_sminn (:) = spval
+
+ a_abm (:) = spval
+ a_gdp (:) = spval
+ a_peatf (:) = spval
+ a_hdm (:) = spval
+ a_lnfm (:) = spval
+
+ a_leafcCap (:) = spval
+ a_leafc_storageCap (:) = spval
+ a_leafc_xferCap (:) = spval
+ a_frootcCap (:) = spval
+ a_frootc_storageCap (:) = spval
+ a_frootc_xferCap (:) = spval
+ a_livestemcCap (:) = spval
+ a_livestemc_storageCap (:) = spval
+ a_livestemc_xferCap (:) = spval
+ a_deadstemcCap (:) = spval
+ a_deadstemc_storageCap (:) = spval
+ a_deadstemc_xferCap (:) = spval
+ a_livecrootcCap (:) = spval
+ a_livecrootc_storageCap(:) = spval
+ a_livecrootc_xferCap (:) = spval
+ a_deadcrootcCap (:) = spval
+ a_deadcrootc_storageCap(:) = spval
+ a_deadcrootc_xferCap (:) = spval
+ a_leafnCap (:) = spval
+ a_leafn_storageCap (:) = spval
+ a_leafn_xferCap (:) = spval
+ a_frootnCap (:) = spval
+ a_frootn_storageCap (:) = spval
+ a_frootn_xferCap (:) = spval
+ a_livestemnCap (:) = spval
+ a_livestemn_storageCap (:) = spval
+ a_livestemn_xferCap (:) = spval
+ a_deadstemnCap (:) = spval
+ a_deadstemn_storageCap (:) = spval
+ a_deadstemn_xferCap (:) = spval
+ a_livecrootnCap (:) = spval
+ a_livecrootn_storageCap(:) = spval
+ a_livecrootn_xferCap (:) = spval
+ a_deadcrootnCap (:) = spval
+ a_deadcrootn_storageCap(:) = spval
+ a_deadcrootn_xferCap (:) = spval
+#endif
+ a_ozone (:) = spval
+
+ a_t_soisno (:,:) = spval
+ a_wliq_soisno (:,:) = spval
+ a_wice_soisno (:,:) = spval
+ a_h2osoi (:,:) = spval
+ a_qlayer (:,:) = spval
+ a_lake_deficit (:) = spval
+ a_rootr (:,:) = spval
+ a_BD_all (:,:) = spval
+ a_wfc (:,:) = spval
+ a_OM_density (:,:) = spval
+!Plant Hydraulic parameters
+ a_vegwp (:,:) = spval
+!END plant hydraulic parameters
+ a_dz_lake (:,:) = spval
+ a_t_lake (:,:) = spval
+ a_lake_icefrac (:,:) = spval
+#ifdef BGC
+ a_litr1c_vr (:,:) = spval
+ a_litr2c_vr (:,:) = spval
+ a_litr3c_vr (:,:) = spval
+ a_soil1c_vr (:,:) = spval
+ a_soil2c_vr (:,:) = spval
+ a_soil3c_vr (:,:) = spval
+ a_cwdc_vr (:,:) = spval
+ a_litr1n_vr (:,:) = spval
+ a_litr2n_vr (:,:) = spval
+ a_litr3n_vr (:,:) = spval
+ a_soil1n_vr (:,:) = spval
+ a_soil2n_vr (:,:) = spval
+ a_soil3n_vr (:,:) = spval
+ a_cwdn_vr (:,:) = spval
+ a_totsoiln_vr (:,:) = spval
+
+ a_litr1cCap_vr (:,:) = spval
+ a_litr2cCap_vr (:,:) = spval
+ a_litr3cCap_vr (:,:) = spval
+ a_soil1cCap_vr (:,:) = spval
+ a_soil2cCap_vr (:,:) = spval
+ a_soil3cCap_vr (:,:) = spval
+ a_cwdcCap_vr (:,:) = spval
+ a_litr1nCap_vr (:,:) = spval
+ a_litr2nCap_vr (:,:) = spval
+ a_litr3nCap_vr (:,:) = spval
+ a_soil1nCap_vr (:,:) = spval
+ a_soil2nCap_vr (:,:) = spval
+ a_soil3nCap_vr (:,:) = spval
+ a_cwdnCap_vr (:,:) = spval
+
+ a_t_scalar (:,:) = spval
+ a_w_scalar (:,:) = spval
+
+ a_sminn_vr (:,:) = spval
+#endif
+
+ a_ustar (:) = spval
+ a_ustar2(:) = spval
+ a_tstar (:) = spval
+ a_qstar (:) = spval
+ a_zol (:) = spval
+ a_rib (:) = spval
+ a_fm (:) = spval
+ a_fh (:) = spval
+ a_fq (:) = spval
+
+ a_us10m (:) = spval
+ a_vs10m (:) = spval
+ a_fm10m (:) = spval
+
+ a_sr (:) = spval
+ a_solvd (:) = spval
+ a_solvi (:) = spval
+ a_solnd (:) = spval
+ a_solni (:) = spval
+ a_srvd (:) = spval
+ a_srvi (:) = spval
+ a_srnd (:) = spval
+ a_srni (:) = spval
+ a_solvdln (:) = spval
+ a_solviln (:) = spval
+ a_solndln (:) = spval
+ a_solniln (:) = spval
+ a_srvdln (:) = spval
+ a_srviln (:) = spval
+ a_srndln (:) = spval
+ a_srniln (:) = spval
+#ifdef HYPERSPECTRAL
+ a_sol_dir_ln_hires(:,:) = spval
+ a_sol_dif_ln_hires(:,:) = spval
+ a_sr_dir_ln_hires (:,:) = spval
+ a_sr_dif_ln_hires (:,:) = spval
+#endif
+ a_sensors(:,:) = spval
+
+ nac_ln (:) = 0
+ nac_dt (:) = 0
+ filter_dt (:) = .true.
+
+ ENDIF
+ ENDIF
+
+#ifdef EXTERNAL_LAKE
+ CALL Flush_LakeAccVars
+#endif
+
+ END SUBROUTINE FLUSH_acc_fluxes
+
+ SUBROUTINE accumulate_fluxes
+! ----------------------------------------------------------------------
+! perform the grid average mapping: average a subgrid input 1d vector
+! of length numpatch to a output 2d array of length [ghist%xcnt,ghist%ycnt]
+!
+! Created by Yongjiu Dai, 03/2014
+!---------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE mod_forcing, only: forcmask_pch
+ USE MOD_Mesh, only: numelm
+ USE MOD_LandElm
+ USE MOD_LandPatch, only: numpatch, elm_patch
+ USE MOD_LandUrban, only: numurban
+ USE MOD_Const_Physical, only: vonkar, stefnc, cpair, rgas, grav
+ USE MOD_Vars_TimeInvariants
+ USE MOD_Vars_TimeVariables
+ USE MOD_Vars_1DForcing
+ USE MOD_Vars_1DFluxes
+ USE MOD_FrictionVelocity
+ USE MOD_Namelist, only: DEF_USE_CBL_HEIGHT, DEF_USE_OZONESTRESS, DEF_USE_PLANTHYDRAULICS, DEF_USE_NITRIF
+ USE MOD_TurbulenceLEddy
+ USE MOD_Vars_Global
+#ifdef CatchLateralFlow
+ USE MOD_Catch_Vars_1DFluxes
+ USE MOD_Catch_Hist, only: accumulate_fluxes_basin
+#endif
+
+ IMPLICIT NONE
+
+ ! Local Variables
+
+ real(r8), allocatable :: r_trad (:)
+ real(r8), allocatable :: r_ustar (:)
+ real(r8), allocatable :: r_ustar2 (:) !define a temporary for estimating us10m only, output should be r_ustar. Shaofeng, 2023.05.20
+ real(r8), allocatable :: r_tstar (:)
+ real(r8), allocatable :: r_qstar (:)
+ real(r8), allocatable :: r_zol (:)
+ real(r8), allocatable :: r_rib (:)
+ real(r8), allocatable :: r_fm (:)
+ real(r8), allocatable :: r_fh (:)
+ real(r8), allocatable :: r_fq (:)
+
+ real(r8), allocatable :: r_us10m (:)
+ real(r8), allocatable :: r_vs10m (:)
+ real(r8), allocatable :: r_fm10m (:)
+
+ logical, allocatable :: filter (:)
+
+ !---------------------------------------------------------------------
+ integer ib, jb, i, j, ielm, istt, iend
+ real(r8) sumwt
+ real(r8) rhoair,thm,th,thv,ur,displa_av,zldis,hgt_u,hgt_t,hgt_q
+ real(r8) hpbl ! atmospheric boundary layer height [m]
+ real(r8) z0m_av,z0h_av,z0q_av,us,vs,tm,qm,psrf,taux_e,tauy_e,fsena_e,fevpa_e
+ real(r8) r_ustar_e, r_tstar_e, r_qstar_e, r_zol_e, r_ustar2_e, r_fm10m_e
+ real(r8) r_fm_e, r_fh_e, r_fq_e, r_rib_e, r_us10m_e, r_vs10m_e
+ real(r8) obu,fh2m,fq2m
+ real(r8) um,thvstar,beta,zii,wc,wc2
+
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+
+ ! count for time steps
+ nac = nac + 1
+
+ ! count for local noon time steps
+ DO i = 1, numpatch
+ IF (solvdln(i) /= spval) THEN
+ nac_ln(i) = nac_ln(i) + 1
+ ENDIF
+ ENDDO
+
+ ! set daytime filter
+ filter_dt(:) = coszen(:) > 0
+
+ ! count for daytime time steps
+ WHERE ( filter_dt(:) ) nac_dt(:) = nac_dt(:) + 1
+
+ CALL acc1d (forc_us , a_us )
+ CALL acc1d (forc_vs , a_vs )
+ CALL acc1d (forc_t , a_t )
+ CALL acc1d (forc_q , a_q )
+ CALL acc1d (forc_prc , a_prc )
+ CALL acc1d (forc_prl , a_prl )
+ CALL acc1d (forc_pbot , a_pbot )
+ CALL acc1d (forc_frl , a_frl )
+
+ CALL acc1d (forc_sols , a_solarin )
+ CALL acc1d (forc_soll , a_solarin )
+ CALL acc1d (forc_solsd , a_solarin )
+ CALL acc1d (forc_solld , a_solarin )
+
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ CALL acc1d (forc_hpbl , a_hpbl)
+ ENDIF
+
+ CALL acc1d (taux , a_taux )
+ CALL acc1d (tauy , a_tauy )
+ CALL acc1d (fsena , a_fsena )
+ CALL acc1d (lfevpa , a_lfevpa )
+ CALL acc1d (fevpa , a_fevpa )
+ CALL acc1d (fsenl , a_fsenl )
+ CALL acc1d (fevpl , a_fevpl )
+ CALL acc1d (etr , a_etr )
+ CALL acc1d (fseng , a_fseng )
+ CALL acc1d (fevpg , a_fevpg )
+ CALL acc1d (fgrnd , a_fgrnd )
+ CALL acc1d (sabvsun , a_sabvsun )
+ CALL acc1d (sabvsha , a_sabvsha )
+ CALL acc1d (sabg , a_sabg )
+ CALL acc1d (olrg , a_olrg )
+
+ IF (DEF_forcing%has_missing_value) THEN
+ WHERE (forcmask_pch)
+ rnet = sabg + sabvsun + sabvsha - olrg + forc_frl
+ END WHERE
+ ELSE
+ WHERE(patchmask)
+ rnet = sabg + sabvsun + sabvsha - olrg + forc_frl
+ END WHERE
+ ENDIF
+ CALL acc1d (rnet , a_rnet )
+
+ CALL acc1d (xerr , a_xerr )
+ CALL acc1d (zerr , a_zerr )
+ CALL acc1d (rsur , a_rsur )
+#ifndef CatchLateralFlow
+ CALL acc1d (rsur_se , a_rsur_se )
+ CALL acc1d (rsur_ie , a_rsur_ie )
+#endif
+ CALL acc1d (rsub , a_rsub )
+ CALL acc1d (rnof , a_rnof )
+#ifdef CatchLateralFlow
+ CALL acc1d (xwsur , a_xwsur )
+ CALL acc1d (xwsub , a_xwsub )
+ CALL acc1d (fldarea , a_fldarea )
+#endif
+ CALL acc1d (qintr , a_qintr )
+ CALL acc1d (qinfl , a_qinfl )
+ CALL acc1d (qdrip , a_qdrip )
+
+ CALL acc1d (rstfacsun_out , a_rstfacsun )
+ CALL acc1d (rstfacsha_out , a_rstfacsha )
+
+ CALL acc1d (gssun_out , a_gssun )
+ CALL acc1d (gssha_out , a_gssha )
+
+ CALL acc1d (rss , a_rss )
+ CALL acc1d (wdsrf , a_wdsrf )
+ CALL acc1d (zwt , a_zwt )
+ CALL acc1d (wa , a_wa )
+ CALL acc1d (wat , a_wat )
+ CALL acc1d (wetwat , a_wetwat )
+ CALL acc1d (assim , a_assim )
+ CALL acc1d (respc , a_respc )
+ CALL acc1d (assimsun_out , a_assimsun )
+ CALL acc1d (assimsha_out , a_assimsha )
+ CALL acc1d (etrsun_out , a_etrsun )
+ CALL acc1d (etrsha_out , a_etrsha )
+
+ CALL acc1d (qcharge , a_qcharge )
+
+ CALL acc1d (t_grnd , a_t_grnd )
+ CALL acc1d (tleaf , a_tleaf )
+ CALL acc1d (ldew_rain , a_ldew_rain )
+ CALL acc1d (ldew_snow , a_ldew_snow )
+ CALL acc1d (ldew , a_ldew )
+ CALL acc1d (scv , a_scv )
+ CALL acc1d (snowdp , a_snowdp )
+ CALL acc1d (fsno , a_fsno )
+ CALL acc1d (frcsat , a_frcsat )
+ CALL acc1d (sigf , a_sigf )
+ CALL acc1d (green , a_green )
+ CALL acc1d (lai , a_lai )
+ CALL acc1d (laisun , a_laisun )
+ CALL acc1d (laisha , a_laisha )
+ CALL acc1d (sai , a_sai )
+
+ ! only acc for daytime for albedo
+ CALL acc3d (alb , a_alb, filter_dt )
+#ifdef HYPERSPECTRAL
+ CALL acc3d (alb_hires , a_alb_hires, filter_dt )
+#endif
+
+ CALL acc1d (emis , a_emis )
+ CALL acc1d (z0m , a_z0m )
+
+ allocate (r_trad (numpatch)) ; r_trad(:) = spval
+ DO i = 1, numpatch
+ IF (DEF_forcing%has_missing_value) THEN
+ IF (.not. forcmask_pch(i)) CYCLE
+ ENDIF
+
+ IF (.not. patchmask(i)) CYCLE
+ r_trad(i) = (olrg(i)/stefnc)**0.25
+ ENDDO
+ CALL acc1d (r_trad , a_trad )
+ deallocate (r_trad )
+
+ CALL acc1d (tref , a_tref )
+ CALL acc1d (qref , a_qref )
+
+ ! set 2m WMO temperature
+ DO ielm = 1, numelm
+
+ istt = elm_patch%substt(ielm)
+ iend = elm_patch%subend(ielm)
+
+ ! landelm%settyp=1 means 2m WMO patch exist,
+ ! which is the last end patch in a element.
+ IF (landelm%settyp(ielm)==1 .and. forcmask_pch(iend)) THEN
+ ! all set to the 2m WMO patch tref
+ t2m_wmo(istt:iend) = tref(iend)
+ ELSE
+ ! if no 2m WMO patch, keep t2m_wmo to tref
+ t2m_wmo(istt:iend) = tref(istt:iend)
+ ENDIF
+ ENDDO
+
+ CALL acc1d (t2m_wmo, a_t2m_wmo)
+
+ CALL acc1d (forc_rain, a_rain )
+ CALL acc1d (forc_snow, a_snow )
+
+ IF (DEF_USE_OZONESTRESS)THEN
+ CALL acc1d(o3uptakesun,a_o3uptakesun)
+ CALL acc1d(o3uptakesha,a_o3uptakesha)
+ ENDIF
+
+#ifdef DataAssimilation
+ CALL acc3d (h2osoi_ens , a_h2osoi_ens )
+ CALL acc3d (t_brt_smap_ens , a_t_brt_smap_ens )
+ CALL acc2d (t_brt_smap , a_t_brt_smap )
+ CALL acc3d (t_brt_fy3d_ens , a_t_brt_fy3d_ens )
+ CALL acc2d (t_brt_fy3d , a_t_brt_fy3d )
+ CALL acc3d (wliq_soisno_ens, a_wliq_soisno_ens)
+ CALL acc3d (wice_soisno_ens, a_wice_soisno_ens)
+ CALL acc3d (t_soisno_ens , a_t_soisno_ens )
+#endif
+
+#ifdef URBAN_MODEL
+ IF (numurban > 0) THEN
+ CALL acc1d(t_room , a_t_room )
+ CALL acc1d(tafu , a_tafu )
+ CALL acc1d(fhac , a_fhac )
+ CALL acc1d(fwst , a_fwst )
+ CALL acc1d(fach , a_fach )
+ CALL acc1d(fahe , a_fahe )
+ CALL acc1d(fhah , a_fhah )
+ CALL acc1d(vehc , a_vehc )
+ CALL acc1d(meta , a_meta )
+
+ CALL acc1d(fsen_roof , a_senroof )
+ CALL acc1d(fsen_wsun , a_senwsun )
+ CALL acc1d(fsen_wsha , a_senwsha )
+ CALL acc1d(fsen_gimp , a_sengimp )
+ CALL acc1d(fsen_gper , a_sengper )
+ CALL acc1d(fsen_urbl , a_senurbl )
+
+ CALL acc1d(lfevp_roof , a_lfevproof )
+ CALL acc1d(lfevp_gimp , a_lfevpgimp )
+ CALL acc1d(lfevp_gper , a_lfevpgper )
+ CALL acc1d(lfevp_urbl , a_lfevpurbl )
+
+ CALL acc1d(t_roof , a_troof )
+ CALL acc1d(t_wall , a_twall )
+ ENDIF
+#endif
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ CALL acc1d (lai_enftemp , a_lai_enftemp )
+ CALL acc1d (lai_enfboreal , a_lai_enfboreal )
+ CALL acc1d (lai_dnfboreal , a_lai_dnfboreal )
+ CALL acc1d (lai_ebftrop , a_lai_ebftrop )
+ CALL acc1d (lai_ebftemp , a_lai_ebftemp )
+ CALL acc1d (lai_dbftrop , a_lai_dbftrop )
+ CALL acc1d (lai_dbftemp , a_lai_dbftemp )
+ CALL acc1d (lai_dbfboreal , a_lai_dbfboreal )
+ CALL acc1d (lai_ebstemp , a_lai_ebstemp )
+ CALL acc1d (lai_dbstemp , a_lai_dbstemp )
+ CALL acc1d (lai_dbsboreal , a_lai_dbsboreal )
+ CALL acc1d (lai_c3arcgrass , a_lai_c3arcgrass )
+ CALL acc1d (lai_c3grass , a_lai_c3grass )
+ CALL acc1d (lai_c4grass , a_lai_c4grass )
+#endif
+#ifdef BGC
+ CALL acc1d (leafc , a_leafc )
+ CALL acc1d (leafc_storage , a_leafc_storage )
+ CALL acc1d (leafc_xfer , a_leafc_xfer )
+ CALL acc1d (frootc , a_frootc )
+ CALL acc1d (frootc_storage , a_frootc_storage )
+ CALL acc1d (frootc_xfer , a_frootc_xfer )
+ CALL acc1d (livestemc , a_livestemc )
+ CALL acc1d (livestemc_storage , a_livestemc_storage )
+ CALL acc1d (livestemc_xfer , a_livestemc_xfer )
+ CALL acc1d (deadstemc , a_deadstemc )
+ CALL acc1d (deadstemc_storage , a_deadstemc_storage )
+ CALL acc1d (deadstemc_xfer , a_deadstemc_xfer )
+ CALL acc1d (livecrootc , a_livecrootc )
+ CALL acc1d (livecrootc_storage , a_livecrootc_storage )
+ CALL acc1d (livecrootc_xfer , a_livecrootc_xfer )
+ CALL acc1d (deadcrootc , a_deadcrootc )
+ CALL acc1d (deadcrootc_storage , a_deadcrootc_storage )
+ CALL acc1d (deadcrootc_xfer , a_deadcrootc_xfer )
+ CALL acc1d (grainc , a_grainc )
+ CALL acc1d (grainc_storage , a_grainc_storage )
+ CALL acc1d (grainc_xfer , a_grainc_xfer )
+ CALL acc1d (leafn , a_leafn )
+ CALL acc1d (leafn_storage , a_leafn_storage )
+ CALL acc1d (leafn_xfer , a_leafn_xfer )
+ CALL acc1d (frootn , a_frootn )
+ CALL acc1d (frootn_storage , a_frootn_storage )
+ CALL acc1d (frootn_xfer , a_frootn_xfer )
+ CALL acc1d (livestemn , a_livestemn )
+ CALL acc1d (livestemn_storage , a_livestemn_storage )
+ CALL acc1d (livestemn_xfer , a_livestemn_xfer )
+ CALL acc1d (deadstemn , a_deadstemn )
+ CALL acc1d (deadstemn_storage , a_deadstemn_storage )
+ CALL acc1d (deadstemn_xfer , a_deadstemn_xfer )
+ CALL acc1d (livecrootn , a_livecrootn )
+ CALL acc1d (livecrootn_storage , a_livecrootn_storage )
+ CALL acc1d (livecrootn_xfer , a_livecrootn_xfer )
+ CALL acc1d (deadcrootn , a_deadcrootn )
+ CALL acc1d (deadcrootn_storage , a_deadcrootn_storage )
+ CALL acc1d (deadcrootn_xfer , a_deadcrootn_xfer )
+ CALL acc1d (grainn , a_grainn )
+ CALL acc1d (grainn_storage , a_grainn_storage )
+ CALL acc1d (grainn_xfer , a_grainn_xfer )
+ CALL acc1d (retransn , a_retransn )
+ CALL acc1d (gpp , a_gpp )
+ CALL acc1d (downreg , a_downreg )
+ CALL acc1d (ar , a_ar )
+ CALL acc1d (cwdprod , a_cwdprod )
+ CALL acc1d (cwddecomp , a_cwddecomp )
+ CALL acc1d (decomp_hr , a_hr )
+ CALL acc1d (fpg , a_fpg )
+ CALL acc1d (fpi , a_fpi )
+ CALL acc1d (totvegc , a_totvegc )
+ CALL acc1d (totlitc , a_totlitc )
+ CALL acc1d (totcwdc , a_totcwdc )
+ CALL acc1d (totsomc , a_totsomc )
+ CALL acc1d (totcolc , a_totcolc )
+ CALL acc1d (totvegn , a_totvegn )
+ CALL acc1d (totlitn , a_totlitn )
+ CALL acc1d (totcwdn , a_totcwdn )
+ CALL acc1d (totsomn , a_totsomn )
+ CALL acc1d (totcoln , a_totcoln )
+ CALL acc1d (gpp_enftemp , a_gpp_enftemp )
+ CALL acc1d (gpp_enfboreal , a_gpp_enfboreal )
+ CALL acc1d (gpp_dnfboreal , a_gpp_dnfboreal )
+ CALL acc1d (gpp_ebftrop , a_gpp_ebftrop )
+ CALL acc1d (gpp_ebftemp , a_gpp_ebftemp )
+ CALL acc1d (gpp_dbftrop , a_gpp_dbftrop )
+ CALL acc1d (gpp_dbftemp , a_gpp_dbftemp )
+ CALL acc1d (gpp_dbfboreal , a_gpp_dbfboreal )
+ CALL acc1d (gpp_ebstemp , a_gpp_ebstemp )
+ CALL acc1d (gpp_dbstemp , a_gpp_dbstemp )
+ CALL acc1d (gpp_dbsboreal , a_gpp_dbsboreal )
+ CALL acc1d (gpp_c3arcgrass , a_gpp_c3arcgrass )
+ CALL acc1d (gpp_c3grass , a_gpp_c3grass )
+ CALL acc1d (gpp_c4grass , a_gpp_c4grass )
+ CALL acc1d (npp_enftemp , a_npp_enftemp )
+ CALL acc1d (npp_enfboreal , a_npp_enfboreal )
+ CALL acc1d (npp_dnfboreal , a_npp_dnfboreal )
+ CALL acc1d (npp_ebftrop , a_npp_ebftrop )
+ CALL acc1d (npp_ebftemp , a_npp_ebftemp )
+ CALL acc1d (npp_dbftrop , a_npp_dbftrop )
+ CALL acc1d (npp_dbftemp , a_npp_dbftemp )
+ CALL acc1d (npp_dbfboreal , a_npp_dbfboreal )
+ CALL acc1d (npp_ebstemp , a_npp_ebstemp )
+ CALL acc1d (npp_dbstemp , a_npp_dbstemp )
+ CALL acc1d (npp_dbsboreal , a_npp_dbsboreal )
+ CALL acc1d (npp_c3arcgrass , a_npp_c3arcgrass )
+ CALL acc1d (npp_c3grass , a_npp_c3grass )
+ CALL acc1d (npp_c4grass , a_npp_c4grass )
+ CALL acc1d (npptoleafc_enftemp , a_npptoleafc_enftemp )
+ CALL acc1d (npptoleafc_enfboreal , a_npptoleafc_enfboreal )
+ CALL acc1d (npptoleafc_dnfboreal , a_npptoleafc_dnfboreal )
+ CALL acc1d (npptoleafc_ebftrop , a_npptoleafc_ebftrop )
+ CALL acc1d (npptoleafc_ebftemp , a_npptoleafc_ebftemp )
+ CALL acc1d (npptoleafc_dbftrop , a_npptoleafc_dbftrop )
+ CALL acc1d (npptoleafc_dbftemp , a_npptoleafc_dbftemp )
+ CALL acc1d (npptoleafc_dbfboreal , a_npptoleafc_dbfboreal )
+ CALL acc1d (npptoleafc_ebstemp , a_npptoleafc_ebstemp )
+ CALL acc1d (npptoleafc_dbstemp , a_npptoleafc_dbstemp )
+ CALL acc1d (npptoleafc_dbsboreal , a_npptoleafc_dbsboreal )
+ CALL acc1d (npptoleafc_c3arcgrass , a_npptoleafc_c3arcgrass )
+ CALL acc1d (npptoleafc_c3grass , a_npptoleafc_c3grass )
+ CALL acc1d (npptoleafc_c4grass , a_npptoleafc_c4grass )
+ CALL acc1d (leafc_enftemp , a_leafc_enftemp )
+ CALL acc1d (leafc_enfboreal , a_leafc_enfboreal )
+ CALL acc1d (leafc_dnfboreal , a_leafc_dnfboreal )
+ CALL acc1d (leafc_ebftrop , a_leafc_ebftrop )
+ CALL acc1d (leafc_ebftemp , a_leafc_ebftemp )
+ CALL acc1d (leafc_dbftrop , a_leafc_dbftrop )
+ CALL acc1d (leafc_dbftemp , a_leafc_dbftemp )
+ CALL acc1d (leafc_dbfboreal , a_leafc_dbfboreal )
+ CALL acc1d (leafc_ebstemp , a_leafc_ebstemp )
+ CALL acc1d (leafc_dbstemp , a_leafc_dbstemp )
+ CALL acc1d (leafc_dbsboreal , a_leafc_dbsboreal )
+ CALL acc1d (leafc_c3arcgrass , a_leafc_c3arcgrass )
+ CALL acc1d (leafc_c3grass , a_leafc_c3grass )
+ CALL acc1d (leafc_c4grass , a_leafc_c4grass )
+ IF(DEF_USE_NITRIF)THEN
+ CALL acc2d (to2_decomp_depth_unsat, a_O2_DECOMP_DEPTH_UNSAT)
+ CALL acc2d (tconc_o2_unsat , a_CONC_O2_UNSAT )
+ ENDIF
+#ifdef CROP
+ CALL acc1d (pdcorn , a_pdcorn )
+ CALL acc1d (pdswheat , a_pdswheat )
+ CALL acc1d (pdwwheat , a_pdwwheat )
+ CALL acc1d (pdsoybean , a_pdsoybean )
+ CALL acc1d (pdcotton , a_pdcotton )
+ CALL acc1d (pdrice1 , a_pdrice1 )
+ CALL acc1d (pdrice2 , a_pdrice2 )
+ CALL acc1d (pdsugarcane , a_pdsugarcane )
+ CALL acc1d (plantdate , a_plantdate )
+ CALL acc1d (manunitro , a_manunitro )
+ CALL acc1d (fertnitro_corn , a_fertnitro_corn )
+ CALL acc1d (fertnitro_swheat , a_fertnitro_swheat )
+ CALL acc1d (fertnitro_wwheat , a_fertnitro_wwheat )
+ CALL acc1d (fertnitro_soybean , a_fertnitro_soybean )
+ CALL acc1d (fertnitro_cotton , a_fertnitro_cotton )
+ CALL acc1d (fertnitro_rice1 , a_fertnitro_rice1 )
+ CALL acc1d (fertnitro_rice2 , a_fertnitro_rice2 )
+ CALL acc1d (fertnitro_sugarcane, a_fertnitro_sugarcane)
+ CALL acc1d (real(irrig_method_corn ,r8), a_irrig_method_corn )
+ CALL acc1d (real(irrig_method_swheat ,r8), a_irrig_method_swheat )
+ CALL acc1d (real(irrig_method_wwheat ,r8), a_irrig_method_wwheat )
+ CALL acc1d (real(irrig_method_soybean ,r8), a_irrig_method_soybean )
+ CALL acc1d (real(irrig_method_cotton ,r8), a_irrig_method_cotton )
+ CALL acc1d (real(irrig_method_rice1 ,r8), a_irrig_method_rice1 )
+ CALL acc1d (real(irrig_method_rice2 ,r8), a_irrig_method_rice2 )
+ CALL acc1d (real(irrig_method_sugarcane,r8), a_irrig_method_sugarcane)
+ CALL acc1d (cphase , a_cphase )
+ CALL acc1d (hui , a_hui )
+ CALL acc1d (vf , a_vf )
+ CALL acc1d (gddmaturity , a_gddmaturity )
+ CALL acc1d (gddplant , a_gddplant )
+ CALL acc1d (cropprod1c , a_cropprod1c )
+ CALL acc1d (cropprod1c_loss , a_cropprod1c_loss )
+ CALL acc1d (cropseedc_deficit , a_cropseedc_deficit )
+ CALL acc1d (grainc_to_cropprodc, a_grainc_to_cropprodc)
+ CALL acc1d (grainc_to_seed , a_grainc_to_seed )
+ CALL acc1d (fert_to_sminn , a_fert_to_sminn )
+
+ a_sum_irrig = sum_irrig
+ a_sum_irrig_count = sum_irrig_count
+ a_waterstorage = waterstorage
+ CALL acc1d (groundwater_demand , a_groundwater_demand )
+ CALL acc1d (groundwater_supply , a_groundwater_supply )
+ CALL acc1d (reservoirriver_demand, a_reservoirriver_demand)
+ CALL acc1d (reservoirriver_supply, a_reservoirriver_supply)
+ CALL acc1d (reservoir_supply , a_reservoir_supply)
+ CALL acc1d (river_supply , a_river_supply)
+ CALL acc1d (runoff_supply , a_runoff_supply)
+#endif
+ CALL acc1d (ndep_to_sminn , a_ndep_to_sminn )
+ IF(DEF_USE_FIRE)THEN
+ CALL acc1d (abm_lf , a_abm )
+ CALL acc1d (gdp_lf , a_gdp )
+ CALL acc1d (peatf_lf , a_peatf )
+ CALL acc1d (hdm_lf , a_hdm )
+ CALL acc1d (lnfm , a_lnfm )
+ ENDIF
+ IF(DEF_USE_DiagMatrix)THEN
+ CALL acc1d (leafcCap ,a_leafcCap )
+ CALL acc1d (leafc_storageCap ,a_leafc_storageCap )
+ CALL acc1d (leafc_xferCap ,a_leafc_xferCap )
+ CALL acc1d (frootcCap ,a_frootcCap )
+ CALL acc1d (frootc_storageCap ,a_frootc_storageCap )
+ CALL acc1d (frootc_xferCap ,a_frootc_xferCap )
+ CALL acc1d (livestemcCap ,a_livestemcCap )
+ CALL acc1d (livestemc_storageCap ,a_livestemc_storageCap )
+ CALL acc1d (livestemc_xferCap ,a_livestemc_xferCap )
+ CALL acc1d (deadstemcCap ,a_deadstemcCap )
+ CALL acc1d (deadstemc_storageCap ,a_deadstemc_storageCap )
+ CALL acc1d (deadstemc_xferCap ,a_deadstemc_xferCap )
+ CALL acc1d (livecrootcCap ,a_livecrootcCap )
+ CALL acc1d (livecrootc_storageCap,a_livecrootc_storageCap)
+ CALL acc1d (livecrootc_xferCap ,a_livecrootc_xferCap )
+ CALL acc1d (deadcrootcCap ,a_deadcrootcCap )
+ CALL acc1d (deadcrootc_storageCap,a_deadcrootc_storageCap)
+ CALL acc1d (deadcrootc_xferCap ,a_deadcrootc_xferCap )
+ CALL acc1d (leafnCap ,a_leafnCap )
+ CALL acc1d (leafn_storageCap ,a_leafn_storageCap )
+ CALL acc1d (leafn_xferCap ,a_leafn_xferCap )
+ CALL acc1d (frootnCap ,a_frootnCap )
+ CALL acc1d (frootn_storageCap ,a_frootn_storageCap )
+ CALL acc1d (frootn_xferCap ,a_frootn_xferCap )
+ CALL acc1d (livestemnCap ,a_livestemnCap )
+ CALL acc1d (livestemn_storageCap ,a_livestemn_storageCap )
+ CALL acc1d (livestemn_xferCap ,a_livestemn_xferCap )
+ CALL acc1d (deadstemnCap ,a_deadstemnCap )
+ CALL acc1d (deadstemn_storageCap ,a_deadstemn_storageCap )
+ CALL acc1d (deadstemn_xferCap ,a_deadstemn_xferCap )
+ CALL acc1d (livecrootnCap ,a_livecrootnCap )
+ CALL acc1d (livecrootn_storageCap,a_livecrootn_storageCap)
+ CALL acc1d (livecrootn_xferCap ,a_livecrootn_xferCap )
+ CALL acc1d (deadcrootnCap ,a_deadcrootnCap )
+ CALL acc1d (deadcrootn_storageCap,a_deadcrootn_storageCap)
+ CALL acc1d (deadcrootn_xferCap ,a_deadcrootn_xferCap )
+ ENDIF
+#endif
+ IF(DEF_USE_OZONESTRESS)THEN
+ CALL acc1d (forc_ozone , a_ozone )
+ ENDIF
+
+ IF (.not. DEF_USE_Dynamic_Lake) THEN
+ CALL acc1d (lake_deficit, a_lake_deficit)
+ ENDIF
+
+ CALL acc2d (t_soisno , a_t_soisno )
+ CALL acc2d (wliq_soisno , a_wliq_soisno )
+ CALL acc2d (wice_soisno , a_wice_soisno )
+
+ CALL acc2d (h2osoi , a_h2osoi )
+ CALL acc2d (qlayer , a_qlayer )
+ CALL acc2d (rootr , a_rootr )
+ CALL acc2d (BD_all , a_BD_all )
+ CALL acc2d (wfc , a_wfc )
+ CALL acc2d (OM_density , a_OM_density )
+ IF(DEF_USE_PLANTHYDRAULICS)THEN
+ CALL acc2d (vegwp , a_vegwp )
+ ENDIF
+ IF (DEF_USE_Dynamic_Lake) THEN
+ CALL acc2d (dz_lake , a_dz_lake )
+ ENDIF
+ CALL acc2d (t_lake , a_t_lake )
+ CALL acc2d (lake_icefrac, a_lake_icefrac )
+#ifdef BGC
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_met_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr1c_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_cel_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr2c_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_lig_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr3c_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil1,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil1c_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil2,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil2c_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_soil3,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil3c_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr(j,i_cwd,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_cwdc_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_met_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr1n_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_cel_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr2n_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_lig_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr3n_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil1,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil1n_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil2,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil2n_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_soil3,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil3n_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr(j,i_cwd,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_cwdn_vr )
+ CALL acc2d (totsoiln_vr , a_totsoiln_vr )
+
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_met_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr1cCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_cel_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr2cCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_lig_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr3cCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_soil1,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil1cCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_soil2,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil2cCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_soil3,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil3cCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_cpools_vr_Cap(j,i_cwd,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_cwdcCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_met_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr1nCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_cel_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr2nCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_lig_lit,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_litr3nCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_soil1,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil1nCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_soil2,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil2nCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_soil3,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_soil3nCap_vr )
+ DO i = 1, numpatch
+ DO j = 1, nl_soil
+ decomp_vr_tmp(j,i) = decomp_npools_vr_Cap(j,i_cwd,i)
+ ENDDO
+ ENDDO
+ CALL acc2d (decomp_vr_tmp, a_cwdnCap_vr )
+ CALL acc2d (sminn_vr , a_sminn_vr )
+
+ CALL acc2d (t_scalar , a_t_scalar )
+ CALL acc2d (w_scalar , a_w_scalar )
+#endif
+ allocate (r_ustar (numpatch)); r_ustar (:) = spval
+ allocate (r_ustar2 (numpatch)); r_ustar2(:) = spval !Shaofeng, 2023.05.20
+ allocate (r_tstar (numpatch)); r_tstar (:) = spval
+ allocate (r_qstar (numpatch)); r_qstar (:) = spval
+ allocate (r_zol (numpatch)); r_zol (:) = spval
+ allocate (r_rib (numpatch)); r_rib (:) = spval
+ allocate (r_fm (numpatch)); r_fm (:) = spval
+ allocate (r_fh (numpatch)); r_fh (:) = spval
+ allocate (r_fq (numpatch)); r_fq (:) = spval
+ allocate (r_us10m (numpatch)); r_us10m (:) = spval
+ allocate (r_vs10m (numpatch)); r_vs10m (:) = spval
+ allocate (r_fm10m (numpatch)); r_fm10m (:) = spval
+
+ DO ielm = 1, numelm
+
+ istt = elm_patch%substt(ielm)
+ iend = elm_patch%subend(ielm)
+
+ allocate (filter (istt:iend))
+ filter(:) = .true.
+
+ filter(:) = patchmask(istt:iend)
+
+ IF (DEF_forcing%has_missing_value) THEN
+ WHERE (.not. forcmask_pch(istt:iend)) filter = .false.
+ filter = filter .and. forcmask_pch(istt:iend)
+ ENDIF
+
+ IF (.not. any(filter)) THEN
+ deallocate(filter)
+ CYCLE
+ ENDIF
+
+ sumwt = sum(elm_patch%subfrc(istt:iend), mask = filter)
+
+ ! Aggregate variables from patches to element (gridcell in latitude-longitude mesh)
+ z0m_av = sum(z0m (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ hgt_u = sum(forc_hgt_u (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ hgt_t = sum(forc_hgt_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ hgt_q = sum(forc_hgt_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ us = sum(forc_us (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ vs = sum(forc_vs (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ tm = sum(forc_t (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ qm = sum(forc_q (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ psrf = sum(forc_psrf (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ taux_e = sum(taux (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ tauy_e = sum(tauy (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ fsena_e = sum(fsena (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ fevpa_e = sum(fevpa (istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18
+ hpbl = sum(forc_hpbl(istt:iend) * elm_patch%subfrc(istt:iend), mask = filter) / sumwt
+ ENDIF
+
+ z0h_av = z0m_av
+ z0q_av = z0m_av
+
+ displa_av = 2./3.*z0m_av/0.07
+
+ hgt_u = max(hgt_u, 5.+displa_av)
+ hgt_t = max(hgt_t, 5.+displa_av)
+ hgt_q = max(hgt_q, 5.+displa_av)
+
+ zldis = hgt_u-displa_av
+
+ rhoair = (psrf - 0.378*qm*psrf/(0.622+0.378*qm)) / (rgas*tm)
+
+ r_ustar_e = sqrt(max(1.e-6,sqrt(taux_e**2+tauy_e**2))/rhoair)
+ r_tstar_e = -fsena_e/(rhoair*r_ustar_e)/cpair
+ r_qstar_e = -fevpa_e/(rhoair*r_ustar_e)
+
+ thm = tm + 0.0098*hgt_t
+ th = tm*(100000./psrf)**(rgas/cpair)
+ thv = th*(1.+0.61*qm)
+
+ r_zol_e = zldis*vonkar*grav * (r_tstar_e*(1.+0.61*qm)+0.61*th*r_qstar_e) &
+ / (r_ustar_e**2*thv)
+
+ IF(r_zol_e >= 0.)THEN !stable
+ r_zol_e = min(2.,max(r_zol_e,1.e-6))
+ ELSE !unstable
+ r_zol_e = max(-100.,min(r_zol_e,-1.e-6))
+ ENDIF
+
+ beta = 1.
+ zii = 1000.
+
+ thvstar=r_tstar_e*(1.+0.61*qm)+0.61*th*r_qstar_e
+ ur = sqrt(us*us+vs*vs)
+ IF(r_zol_e >= 0.)THEN
+ um = max(ur,0.1)
+ ELSE
+ IF (DEF_USE_CBL_HEIGHT) THEN !//TODO: Shaofeng, 2023.05.18
+ zii = max(5.*hgt_u,hpbl)
+ ENDIF !//TODO: Shaofeng, 2023.05.18
+ wc = (-grav*r_ustar_e*thvstar*zii/thv)**(1./3.)
+ wc2 = beta*beta*(wc*wc)
+ um = max(0.1,sqrt(ur*ur+wc2))
+ ENDIF
+
+ obu = zldis/r_zol_e
+ IF (DEF_USE_CBL_HEIGHT) THEN
+ CALL moninobuk_leddy(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,&
+ obu,um, hpbl, r_ustar2_e,fh2m,fq2m,r_fm10m_e,r_fm_e,r_fh_e,r_fq_e) !Shaofeng, 2023.05.20
+ ELSE
+ CALL moninobuk(hgt_u,hgt_t,hgt_q,displa_av,z0m_av,z0h_av,z0q_av,&
+ obu,um,r_ustar2_e,fh2m,fq2m,r_fm10m_e,r_fm_e,r_fh_e,r_fq_e) !Shaofeng, 2023.05.20
+ ENDIF
+
+ ! bug found by chen qiying 2013/07/01
+ r_rib_e = r_zol_e /vonkar * r_ustar2_e**2 / (vonkar/r_fh_e*um**2)
+ r_rib_e = min(5.,r_rib_e)
+
+ r_us10m_e = us/um * r_ustar2_e /vonkar * r_fm10m_e
+ r_vs10m_e = vs/um * r_ustar2_e /vonkar * r_fm10m_e
+
+ ! Assign values from element (gridcell in latitude-longitude mesh) to patches.
+ ! Notice that all values on patches in an element are equal.
+ r_ustar (istt:iend) = r_ustar_e
+ r_ustar2(istt:iend) = r_ustar2_e
+ r_tstar (istt:iend) = r_tstar_e
+ r_qstar (istt:iend) = r_qstar_e
+ r_zol (istt:iend) = r_zol_e
+ r_rib (istt:iend) = r_rib_e
+ r_fm (istt:iend) = r_fm_e
+ r_fh (istt:iend) = r_fh_e
+ r_fq (istt:iend) = r_fq_e
+ r_us10m (istt:iend) = r_us10m_e
+ r_vs10m (istt:iend) = r_vs10m_e
+ r_fm10m (istt:iend) = r_fm10m_e
+
+ deallocate(filter)
+
+ ENDDO
+
+ CALL acc1d (r_ustar , a_ustar )
+ CALL acc1d (r_ustar2 , a_ustar2 )
+ CALL acc1d (r_tstar , a_tstar )
+ CALL acc1d (r_qstar , a_qstar )
+ CALL acc1d (r_zol , a_zol )
+ CALL acc1d (r_rib , a_rib )
+ CALL acc1d (r_fm , a_fm )
+ CALL acc1d (r_fh , a_fh )
+ CALL acc1d (r_fq , a_fq )
+
+ CALL acc1d (r_us10m , a_us10m )
+ CALL acc1d (r_vs10m , a_vs10m )
+ CALL acc1d (r_fm10m , a_fm10m )
+
+ deallocate (r_ustar )
+ deallocate (r_ustar2) !Shaofeng, 2023.05.20
+ deallocate (r_tstar )
+ deallocate (r_qstar )
+ deallocate (r_zol )
+ deallocate (r_rib )
+ deallocate (r_fm )
+ deallocate (r_fh )
+ deallocate (r_fq )
+
+ deallocate (r_us10m )
+ deallocate (r_vs10m )
+ deallocate (r_fm10m )
+
+ CALL acc1d (sr , a_sr )
+ CALL acc1d (solvd , a_solvd )
+ CALL acc1d (solvi , a_solvi )
+ CALL acc1d (solnd , a_solnd )
+ CALL acc1d (solni , a_solni )
+ CALL acc1d (srvd , a_srvd )
+ CALL acc1d (srvi , a_srvi )
+ CALL acc1d (srnd , a_srnd )
+ CALL acc1d (srni , a_srni )
+ CALL acc1d (solvdln , a_solvdln )
+ CALL acc1d (solviln , a_solviln )
+ CALL acc1d (solndln , a_solndln )
+ CALL acc1d (solniln , a_solniln )
+ CALL acc1d (srvdln , a_srvdln )
+ CALL acc1d (srviln , a_srviln )
+ CALL acc1d (srndln , a_srndln )
+ CALL acc1d (srniln , a_srniln )
+
+ CALL acc2d (sensors , a_sensors )
+#ifdef HYPERSPECTRAL
+ CALL acc2d (sol_dir_ln_hires, a_sol_dir_ln_hires)
+ CALL acc2d (sol_dif_ln_hires, a_sol_dif_ln_hires)
+ CALL acc2d (sr_dir_ln_hires , a_sr_dir_ln_hires )
+ CALL acc2d (sr_dif_ln_hires , a_sr_dif_ln_hires )
+#endif
+
+ ENDIF
+ ENDIF
+
+#ifdef CatchLateralFlow
+ CALL accumulate_fluxes_basin ()
+#endif
+
+#ifdef EXTERNAL_LAKE
+ CALL accumulate_LakeTimeVars
+#endif
+
+ END SUBROUTINE accumulate_fluxes
+
+
+ !------
+ SUBROUTINE acc1d (var, s)
+
+ USE MOD_Precision
+ USE MOD_Vars_Global, only: spval
+
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: var(:)
+ real(r8), intent(inout) :: s (:)
+ ! Local variables
+ integer :: i
+
+ 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
+
+ END SUBROUTINE acc1d
+
+ !------
+ SUBROUTINE acc2d (var, s)
+
+ USE MOD_Precision
+ USE MOD_Vars_Global, only: spval
+
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: var(:,:)
+ real(r8), intent(inout) :: s (:,:)
+ ! Local variables
+ integer :: i1, i2
+
+ DO i2 = lbound(var,2), ubound(var,2)
+ DO i1 = lbound(var,1), ubound(var,1)
+ IF (var(i1,i2) /= spval) THEN
+ IF (s(i1,i2) /= spval) THEN
+ s(i1,i2) = s(i1,i2) + var(i1,i2)
+ ELSE
+ s(i1,i2) = var(i1,i2)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+
+ END SUBROUTINE acc2d
+
+ !------
+ SUBROUTINE acc3d (var, s, filter)
+
+ USE MOD_Precision
+ USE MOD_Vars_Global, only: spval
+
+ IMPLICIT NONE
+
+ real(r8), intent(in) :: var(:,:,:)
+ real(r8), intent(inout) :: s (:,:,:)
+ logical, intent(in), optional :: filter(:)
+
+ ! Local variables
+ integer :: i1, i2, i3
+
+ DO i3 = lbound(var,3), ubound(var,3)
+
+ IF ( present(filter) ) THEN
+ IF ( .not. filter(i3) ) CYCLE
+ ENDIF
+
+ DO i2 = lbound(var,2), ubound(var,2)
+ DO i1 = lbound(var,1), ubound(var,1)
+ IF (var(i1,i2,i3) /= spval) THEN
+ IF (s(i1,i2,i3) /= spval) THEN
+ s(i1,i2,i3) = s(i1,i2,i3) + var(i1,i2,i3)
+ ELSE
+ s(i1,i2,i3) = var(i1,i2,i3)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+
+ END SUBROUTINE acc3d
+
+END MODULE MOD_Vars_1DAccFluxes
+! ---------- 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..1eed919be9
--- /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_SPMD_Task
+ USE MOD_LandPatch
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPatch
+
+ IF (p_is_compute) 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..d071335bc7
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_1DForcing.F90
@@ -0,0 +1,167 @@
+#include
+
+MODULE MOD_Vars_1DForcing
+!-----------------------------------------------------------------------
+! Meteorological Forcing
+!
+! Created by Yongjiu Dai, 03/2014
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Namelist
+ IMPLICIT NONE
+ SAVE
+
+!-----------------------------------------------------------------------
+ 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 (:) ! air density [kg/m3]
+#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_SPMD_Task
+ USE MOD_Mesh
+ USE MOD_LandPatch
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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) ) ! air density [kg/m3]
+
+ 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]
+
+ ENDIF
+
+ ENDIF
+
+ END SUBROUTINE allocate_1D_Forcing
+
+
+ SUBROUTINE deallocate_1D_Forcing ()
+
+ USE MOD_SPMD_Task
+ USE MOD_Mesh
+ USE MOD_LandPatch
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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 partial pressure [mol/mol]
+
+ 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..0809c19479
--- /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_SPMD_Task
+ USE MOD_LandPFT
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPFT
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPFT
+ IMPLICIT NONE
+
+ real(r8),intent(in) :: Values
+ real(r8),intent(in) :: Nan
+
+ IF (p_is_compute) 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_2DForcing.F90 b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90
new file mode 100644
index 0000000000..e0c961ef9e
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_2DForcing.F90
@@ -0,0 +1,81 @@
+#include
+
+MODULE MOD_Vars_2DForcing
+!-----------------------------------------------------------------------
+! Meteorogical Forcing
+!
+! Created by Yongjiu Dai, 03/2014
+!-----------------------------------------------------------------------
+
+ USE MOD_DataType
+ IMPLICIT NONE
+ SAVE
+
+!-----------------------------------------------------------------------
+ type(block_data_real8_2d) :: forc_xy_pco2m ! CO2 concentration in atmos. (pascals)
+ type(block_data_real8_2d) :: forc_xy_po2m ! O2 concentration in atmos. (pascals)
+ type(block_data_real8_2d) :: forc_xy_us ! wind in eastward direction [m/s]
+ type(block_data_real8_2d) :: forc_xy_vs ! wind in northward direction [m/s]
+ type(block_data_real8_2d) :: forc_xy_t ! temperature at reference height [kelvin]
+ type(block_data_real8_2d) :: forc_xy_q ! specific humidity at reference height [kg/kg]
+ type(block_data_real8_2d) :: forc_xy_prc ! convective precipitation [mm/s]
+ type(block_data_real8_2d) :: forc_xy_prl ! large scale precipitation [mm/s]
+ type(block_data_real8_2d) :: forc_xy_psrf ! atmospheric pressure at the surface [pa]
+ type(block_data_real8_2d) :: forc_xy_pbot ! atm bottom level pressure (or reference height) (pa)
+ type(block_data_real8_2d) :: forc_xy_sols ! atm vis direct beam solar rad onto srf [W/m2]
+ type(block_data_real8_2d) :: forc_xy_soll ! atm nir direct beam solar rad onto srf [W/m2]
+ type(block_data_real8_2d) :: forc_xy_solsd ! atm vis diffuse solar rad onto srf [W/m2]
+ type(block_data_real8_2d) :: forc_xy_solld ! atm nir diffuse solar rad onto srf [W/m2]
+ type(block_data_real8_2d) :: forc_xy_frl ! atmospheric infrared (longwave) radiation [W/m2]
+ type(block_data_real8_2d) :: forc_xy_hgt_u ! observational height of wind [m]
+ type(block_data_real8_2d) :: forc_xy_hgt_t ! observational height of temperature [m]
+ type(block_data_real8_2d) :: forc_xy_hgt_q ! observational height of humidity [m]
+ type(block_data_real8_2d) :: forc_xy_rhoair ! air density [kg/m3]
+ type(block_data_real8_2d) :: forc_xy_hpbl ! atmospheric boundary layer height [m]
+
+ ! PUBLIC MEMBER FUNCTIONS:
+ PUBLIC :: allocate_2D_Forcing
+
+CONTAINS
+
+!-----------------------------------------------------------------------
+
+ SUBROUTINE allocate_2D_Forcing (grid)
+ ! -------------------------------------------------------------------
+ ! Allocates memory for CoLM 2d [lon_points,lat_points] variables
+ ! -------------------------------------------------------------------
+ USE MOD_SPMD_Task
+ USE MOD_Grid
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ type(grid_type), intent(in) :: grid
+
+ IF (p_is_active) THEN
+
+ CALL allocate_block_data (grid, forc_xy_pco2m ) ! CO2 concentration in atmos. (pascals)
+ CALL allocate_block_data (grid, forc_xy_po2m ) ! O2 concentration in atmos. (pascals)
+ CALL allocate_block_data (grid, forc_xy_us ) ! wind in eastward direction [m/s]
+ CALL allocate_block_data (grid, forc_xy_vs ) ! wind in northward direction [m/s]
+ CALL allocate_block_data (grid, forc_xy_t ) ! temperature at reference height [kelvin]
+ CALL allocate_block_data (grid, forc_xy_q ) ! specific humidity at reference height [kg/kg]
+ CALL allocate_block_data (grid, forc_xy_prc ) ! convective precipitation [mm/s]
+ CALL allocate_block_data (grid, forc_xy_prl ) ! large scale precipitation [mm/s]
+ CALL allocate_block_data (grid, forc_xy_psrf ) ! atmospheric pressure at the surface [pa]
+ CALL allocate_block_data (grid, forc_xy_pbot ) ! atm bottom level pressure (or reference height) (pa)
+ CALL allocate_block_data (grid, forc_xy_sols ) ! atm vis direct beam solar rad onto srf [W/m2]
+ CALL allocate_block_data (grid, forc_xy_soll ) ! atm nir direct beam solar rad onto srf [W/m2]
+ CALL allocate_block_data (grid, forc_xy_solsd ) ! atm vis diffuse solar rad onto srf [W/m2]
+ CALL allocate_block_data (grid, forc_xy_solld ) ! atm nir diffuse solar rad onto srf [W/m2]
+ CALL allocate_block_data (grid, forc_xy_frl ) ! atmospheric infrared (longwave) radiation [W/m2]
+ CALL allocate_block_data (grid, forc_xy_hgt_u ) ! observational height of wind [m]
+ CALL allocate_block_data (grid, forc_xy_hgt_t ) ! observational height of temperature [m]
+ CALL allocate_block_data (grid, forc_xy_hgt_q ) ! observational height of humidity [m]
+ CALL allocate_block_data (grid, forc_xy_rhoair) ! air density [kg/m3]
+ CALL allocate_block_data (grid, forc_xy_hpbl ) ! atmospheric boundary layer height [m]
+ ENDIF
+
+ END SUBROUTINE allocate_2D_Forcing
+
+END MODULE MOD_Vars_2DForcing
+! ---------- 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..d7d7224079
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeInvariants.F90
@@ -0,0 +1,1143 @@
+#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_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ USE MOD_LandPFT, only: numpft
+ USE MOD_Precision
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPFT
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ 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. p_is_compute) 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 USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_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_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_NetCDFVector
+ 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 (p_is_root) THEN
+ CALL system('mkdir -p ' // trim(dir_restart)//'/const')
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#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 USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ if (p_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 USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#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_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+
+ IMPLICIT NONE
+
+ ! --------------------------------------------------
+ ! Deallocates memory for CoLM 1d [numpatch] variables
+ ! --------------------------------------------------
+
+ IF (p_is_compute) 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_SPMD_Task
+ 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 (p_is_root) THEN
+ write(*,'(/,A29)') 'Checking Time Invariants ...'
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#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 USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_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..0b6d23dc00
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/MOD_Vars_TimeVariables.F90
@@ -0,0 +1,1679 @@
+#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_SPMD_Task
+ USE MOD_LandPFT
+ USE MOD_Vars_Global
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPFT
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandPatch, only: numpatch
+ IMPLICIT NONE
+
+ !--------------------------------------------------------------------
+ ! Deallocates memory for CoLM 1d [numpatch] variables
+ !--------------------------------------------------------------------
+
+ IF (p_is_compute) 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_SPMD_Task
+ 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_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=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 (p_is_root) THEN
+ CALL system('mkdir -p ' // trim(dir_restart)//'/'//trim(cdate))
+ ENDIF
+#ifdef COLM_PARALLEL
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_'//trim(cdate)//'_lc'//trim(cyear)//'.nc'
+
+#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
+ file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc'
+ CALL WRITE_PFTimeVariables (file_restart)
+ ENDIF
+#else
+ file_restart = trim(dir_restart)// '/'//trim(cdate)//'/' // trim(site) //'_restart_pft_'//trim(cdate)//'_lc'//trim(cyear)//'.nc'
+ 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
+#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
+
+ END SUBROUTINE WRITE_TimeVariables
+
+
+ SUBROUTINE READ_TimeVariables (idate, lc_year, site, dir_restart)
+
+ !====================================================================
+ ! Original version: Yongjiu Dai, September 15, 1999, 03/2014
+ !====================================================================
+
+ USE MOD_Namelist
+ USE MOD_SPMD_Task
+ 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
+
+ ! Local variables
+ character(len=256) :: file_restart
+ character(len=14) :: cdate, cyear
+
+#ifdef COLM_PARALLEL
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_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 (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'
+ 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)
+#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 (p_is_root) THEN
+ write(*,*) 'Loading Time Variables done.'
+ ENDIF
+
+ END SUBROUTINE READ_TimeVariables
+
+
+#ifdef RangeCheck
+ SUBROUTINE check_TimeVariables ()
+
+ USE MOD_SPMD_Task
+ 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 COLM_PARALLEL
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+ IF (p_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 COLM_PARALLEL
+ CALL mpi_barrier (p_comm_glb, p_err)
+#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..ea31551991
--- /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_SPMD_Task
+ 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 (p_is_active) 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 (p_is_active) 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 (p_is_compute) 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 (p_is_compute) THEN
+ vic_b_infilt(:) = -9999
+ vic_Dsmax(:) = -9999
+ vic_Ds(:) = -9999
+ vic_Ws(:) = -9999
+ vic_c = 2
+ ENDIF
+
+ IF (p_is_compute) 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..a1d8c4b3d4
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/main/ParaOpt/MOD_Opt_Baseflow.F90
@@ -0,0 +1,212 @@
+#include
+
+MODULE MOD_Opt_Baseflow
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ 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
+ 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 (p_is_root) THEN
+ CALL system('mkdir -p ' // trim(DEF_dir_restart)//'/ParaOpt')
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (DEF_Optimize_Baseflow) THEN
+
+ IF (p_is_compute) 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
+ 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 (p_is_compute) 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 (p_is_root) THEN
+ CALL system('mkdir -p ' // trim(DEF_dir_restart)//'/ParaOpt/'//strcyc)
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#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 (p_is_compute) 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 (p_is_compute) 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..c8e307d36d
--- /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_SPMD_Task
+ 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_UserSpecifiedForcing, only: 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 (trim(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 abort
+ 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_UserSpecifiedForcing, only: 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 (trim(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 abort
+ 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..3b1de1a0b7
--- /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_SPMD_Task
+ 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 (p_is_compute) 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..1a8628a5bf
--- /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_SPMD_Task
+
+ 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..cfd72215e4
--- /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_SPMD_Task
+ 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..3e20a7c3c4
--- /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_SPMD_Task
+ USE MOD_LandUrban
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandUrban
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandUrban
+ IMPLICIT NONE
+ real(r8),intent(in) :: Values
+ real(r8),intent(in) :: Nan
+
+ IF (p_is_compute) 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..bded9f3f79
--- /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_SPMD_Task
+ USE MOD_LandUrban
+ USE MOD_Vars_Global
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandUrban
+
+ ! deallocate (urbclass )
+
+ IF (p_is_compute) 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..31234bb8c5
--- /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_SPMD_Task
+ USE MOD_LandUrban
+ USE MOD_Vars_Global
+ IMPLICIT NONE
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_LandUrban
+
+ IF (p_is_compute) 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..4a120a37e1
--- /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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_AggregationRequestData.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90
new file mode 100644
index 0000000000..c4517c21cc
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_AggregationRequestData.F90
@@ -0,0 +1,709 @@
+#include
+
+MODULE MOD_AggregationRequestData
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Aggregation Utilities.
+!
+! On IO ranks, a data daemon is running to provide data
+! at fine resolutions for rank processes.
+! On rank processes, request is sent to IO ranks and
+! data is returned from IO ranks.
+!
+! Created by Shupeng Zhang, May 2023
+!-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ PUBLIC :: aggregation_request_data
+
+#ifdef USEMPI
+ PUBLIC :: aggregation_data_daemon
+ PUBLIC :: aggregation_compute_done
+#endif
+
+! ---- subroutines ----
+CONTAINS
+
+#ifdef USEMPI
+ SUBROUTINE aggregation_data_daemon (grid_in, &
+ data_r8_2d_in1, data_r8_2d_in2, data_r8_2d_in3, data_r8_2d_in4, &
+ data_r8_2d_in5, data_r8_2d_in6, &
+ data_r8_3d_in1, n1_r8_3d_in1 , data_r8_3d_in2, n1_r8_3d_in2, &
+ data_i4_2d_in1, data_i4_2d_in2)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Grid
+ USE MOD_DataType
+
+ IMPLICIT NONE
+
+ type (grid_type), intent(in) :: grid_in
+
+ ! 2D REAL data
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in1
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in2
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in3
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in4
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in5
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in6
+
+ ! 3D REAL data
+ integer, intent(in), optional :: n1_r8_3d_in1
+ type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in1
+
+ integer, intent(in), optional :: n1_r8_3d_in2
+ type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in2
+
+ ! 2D INTEGER data
+ type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in1
+ type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in2
+
+ ! Local Variables
+ integer :: nreq, ireq, rmesg(2), isrc, idest
+ integer :: xblk, yblk, xloc, yloc
+ integer, allocatable :: ylist(:), xlist(:)
+
+ real(r8), allocatable :: sbuf_r8_1d(:), sbuf_r8_2d(:,:)
+ integer , allocatable :: sbuf_i4_1d(:)
+
+ logical, allocatable :: compute_done (:)
+
+#ifdef MPAS_EMBEDDED_COLM
+ RETURN
+#endif
+
+ IF (p_is_active) THEN
+
+ allocate (compute_done (0:p_np_compute-1))
+
+ compute_done(:) = .false.
+ DO WHILE (any(.not. compute_done))
+
+ CALL mpi_recv (rmesg, 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = rmesg(1)
+ nreq = rmesg(2)
+
+ IF (nreq > 0) THEN
+
+ allocate (xlist (nreq))
+ allocate (ylist (nreq))
+
+ CALL mpi_recv (xlist, nreq, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (ylist, nreq, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ idest = isrc
+
+ allocate (sbuf_r8_1d (nreq))
+
+ IF (present(data_r8_2d_in1)) THEN
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_r8_1d(ireq) = data_r8_2d_in1%blk(xblk,yblk)%val(xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ IF (present(data_r8_2d_in2)) THEN
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_r8_1d(ireq) = data_r8_2d_in2%blk(xblk,yblk)%val(xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ IF (present(data_r8_2d_in3)) THEN
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_r8_1d(ireq) = data_r8_2d_in3%blk(xblk,yblk)%val(xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ IF (present(data_r8_2d_in4)) THEN
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_r8_1d(ireq) = data_r8_2d_in4%blk(xblk,yblk)%val(xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ IF (present(data_r8_2d_in5)) THEN
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_r8_1d(ireq) = data_r8_2d_in5%blk(xblk,yblk)%val(xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ IF (present(data_r8_2d_in6)) THEN
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_r8_1d(ireq) = data_r8_2d_in6%blk(xblk,yblk)%val(xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_r8_1d, nreq, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+
+ deallocate (sbuf_r8_1d)
+
+ IF (present(data_r8_3d_in1) .and. present(n1_r8_3d_in1)) THEN
+
+ allocate (sbuf_r8_2d (n1_r8_3d_in1,nreq))
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_r8_2d(:,ireq) = data_r8_3d_in1%blk(xblk,yblk)%val(:,xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_r8_2d, n1_r8_3d_in1*nreq, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (sbuf_r8_2d)
+ ENDIF
+
+ IF (present(data_r8_3d_in2) .and. present(n1_r8_3d_in2)) THEN
+
+ allocate (sbuf_r8_2d (n1_r8_3d_in2,nreq))
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_r8_2d(:,ireq) = data_r8_3d_in2%blk(xblk,yblk)%val(:,xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_r8_2d, n1_r8_3d_in2*nreq, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (sbuf_r8_2d)
+ ENDIF
+
+ allocate (sbuf_i4_1d (nreq))
+
+ IF (present(data_i4_2d_in1)) THEN
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_i4_1d(ireq) = data_i4_2d_in1%blk(xblk,yblk)%val(xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_i4_1d, nreq, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ IF (present(data_i4_2d_in2)) THEN
+ DO ireq = 1, nreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ sbuf_i4_1d(ireq) = data_i4_2d_in2%blk(xblk,yblk)%val(xloc,yloc)
+ ENDDO
+
+ CALL mpi_send (sbuf_i4_1d, nreq, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+
+ deallocate (sbuf_i4_1d)
+
+ deallocate (ylist)
+ deallocate (xlist)
+
+ ELSE
+ compute_done(p_itis_compute(isrc)) = .true.
+ ENDIF
+
+ ENDDO
+
+ deallocate (compute_done)
+
+ ENDIF
+
+ END SUBROUTINE aggregation_data_daemon
+
+#endif
+
+ !----------------------------------------------------
+ SUBROUTINE aggregation_request_data ( &
+ pixelset, iset, grid_in, zip, area, &
+ data_r8_2d_in1, data_r8_2d_out1, &
+ data_r8_2d_in2, data_r8_2d_out2, &
+ data_r8_2d_in3, data_r8_2d_out3, &
+ data_r8_2d_in4, data_r8_2d_out4, &
+ data_r8_2d_in5, data_r8_2d_out5, &
+ data_r8_2d_in6, data_r8_2d_out6, &
+ data_r8_3d_in1, data_r8_3d_out1, n1_r8_3d_in1, lb1_r8_3d_in1, &
+ data_r8_3d_in2, data_r8_3d_out2, n1_r8_3d_in2, lb1_r8_3d_in2, &
+ data_i4_2d_in1, data_i4_2d_out1, &
+ data_i4_2d_in2, data_i4_2d_out2, &
+ filledvalue_i4)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Block
+ USE MOD_Pixel
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_Mesh
+ USE MOD_Pixelset
+ USE MOD_Utils
+
+ IMPLICIT NONE
+
+ type (pixelset_type), intent(in) :: pixelset
+ integer, intent(in) :: iset
+
+ type (grid_type), intent(in) :: grid_in
+ logical, intent(in) :: zip
+
+ real(r8), allocatable, intent(out), optional :: area(:)
+
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in1
+ real(r8), allocatable, intent(out), optional :: data_r8_2d_out1 (:)
+
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in2
+ real(r8), allocatable, intent(out), optional :: data_r8_2d_out2 (:)
+
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in3
+ real(r8), allocatable, intent(out), optional :: data_r8_2d_out3 (:)
+
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in4
+ real(r8), allocatable, intent(out), optional :: data_r8_2d_out4 (:)
+
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in5
+ real(r8), allocatable, intent(out), optional :: data_r8_2d_out5 (:)
+
+ type (block_data_real8_2d), intent(in), optional :: data_r8_2d_in6
+ real(r8), allocatable, intent(out), optional :: data_r8_2d_out6 (:)
+
+ integer, intent(in), optional :: n1_r8_3d_in1, lb1_r8_3d_in1
+ type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in1
+ real(r8), allocatable, intent(out), optional :: data_r8_3d_out1 (:,:)
+
+ integer, intent(in), optional :: n1_r8_3d_in2, lb1_r8_3d_in2
+ type (block_data_real8_3d), intent(in), optional :: data_r8_3d_in2
+ real(r8), allocatable, intent(out), optional :: data_r8_3d_out2 (:,:)
+
+ type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in1
+ integer, allocatable, intent(out), optional :: data_i4_2d_out1 (:)
+
+ type (block_data_int32_2d), intent(in), optional :: data_i4_2d_in2
+ integer, allocatable, intent(out), optional :: data_i4_2d_out2 (:)
+
+ integer, intent(in), optional :: filledvalue_i4
+
+ ! Local Variables
+ integer :: totalreq, ireq, nreq, smesg(2), isrc, idest, iproc
+ integer :: ilon, ilat, xblk, yblk, xloc, yloc, iloc, nx, ny, ix, iy, ig
+ integer :: ie, ipxstt, ipxend, npxl, ipxl, lb1, xgrdthis, ygrdthis
+ integer, allocatable :: ylist(:), xlist(:), ipt(:), ibuf(:), rbuf_i4_1d(:)
+ integer, allocatable :: xsorted(:), ysorted(:), xy2d(:,:)
+ real(r8), allocatable :: area2d(:,:), rbuf_r8_1d(:), rbuf_r8_2d(:,:)
+ logical, allocatable :: msk(:)
+
+
+ ie = pixelset%ielm (iset)
+ ipxstt = pixelset%ipxstt(iset)
+ ipxend = pixelset%ipxend(iset)
+ npxl = ipxend - ipxstt + 1
+
+ IF (zip) THEN
+
+ allocate (xsorted(npxl))
+ allocate (ysorted(npxl))
+
+ nx = 0; ny = 0
+ DO ipxl = ipxstt, ipxend
+ xgrdthis = grid_in%xgrd(mesh(ie)%ilon(ipxl))
+ ygrdthis = grid_in%ygrd(mesh(ie)%ilat(ipxl))
+ CALL insert_into_sorted_list1 (xgrdthis, nx, xsorted, iloc)
+ CALL insert_into_sorted_list1 (ygrdthis, ny, ysorted, iloc)
+ ENDDO
+
+ allocate (xy2d (nx,ny)); xy2d(:,:) = 0
+
+ IF (present(area)) THEN
+ allocate(area2d(nx,ny)); area2d(:,:) = 0.
+ ENDIF
+
+ DO ipxl = ipxstt, ipxend
+ xgrdthis = grid_in%xgrd(mesh(ie)%ilon(ipxl))
+ ygrdthis = grid_in%ygrd(mesh(ie)%ilat(ipxl))
+
+ ix = find_in_sorted_list1(xgrdthis, nx, xsorted)
+ iy = find_in_sorted_list1(ygrdthis, ny, ysorted)
+
+ xy2d(ix,iy) = xy2d(ix,iy) + 1
+
+ IF (present(area)) THEN
+ area2d(ix,iy) = area2d(ix,iy) + 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)) )
+ ENDIF
+ ENDDO
+
+ totalreq = count(xy2d > 0)
+
+ allocate (xlist (totalreq))
+ allocate (ylist (totalreq))
+
+ IF (present(area)) allocate(area(totalreq))
+
+ ig = 0
+ DO ix = 1, nx
+ DO iy = 1, ny
+ IF (xy2d(ix,iy) > 0) THEN
+ ig = ig + 1
+ xlist(ig) = xsorted(ix)
+ ylist(ig) = ysorted(iy)
+ IF (present(area)) area (ig) = area2d(ix,iy)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ deallocate (xsorted, ysorted, xy2d)
+ IF (present(area)) deallocate (area2d)
+
+ ELSE
+
+ allocate(xlist (npxl))
+ allocate(ylist (npxl))
+
+ IF (present(area)) allocate (area (npxl))
+
+ totalreq = npxl
+ DO ipxl = ipxstt, ipxend
+ xlist(ipxl-ipxstt+1) = grid_in%xgrd(mesh(ie)%ilon(ipxl))
+ ylist(ipxl-ipxstt+1) = grid_in%ygrd(mesh(ie)%ilat(ipxl))
+ IF (present(area)) THEN
+ area(ipxl-ipxstt+1) = 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)) )
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) allocate (data_r8_2d_out1 (totalreq))
+ IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) allocate (data_r8_2d_out2 (totalreq))
+ IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) allocate (data_r8_2d_out3 (totalreq))
+ IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) allocate (data_r8_2d_out4 (totalreq))
+ IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) allocate (data_r8_2d_out5 (totalreq))
+ IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) allocate (data_r8_2d_out6 (totalreq))
+
+ IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN
+ IF (present(lb1_r8_3d_in1)) THEN
+ lb1 = lb1_r8_3d_in1
+ ELSE
+ lb1 = 1
+ ENDIF
+ allocate (data_r8_3d_out1 (lb1:lb1-1+n1_r8_3d_in1,totalreq))
+ ENDIF
+
+ IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN
+ IF (present(lb1_r8_3d_in2)) THEN
+ lb1 = lb1_r8_3d_in2
+ ELSE
+ lb1 = 1
+ ENDIF
+ allocate (data_r8_3d_out2 (lb1:lb1-1+n1_r8_3d_in2,totalreq))
+ ENDIF
+
+ IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN
+ allocate (data_i4_2d_out1 (totalreq))
+ IF (present(filledvalue_i4)) THEN
+ data_i4_2d_out1 = filledvalue_i4
+ ENDIF
+ ENDIF
+
+ IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN
+ allocate (data_i4_2d_out2 (totalreq))
+ IF (present(filledvalue_i4)) THEN
+ data_i4_2d_out2 = filledvalue_i4
+ ENDIF
+ ENDIF
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+
+ allocate (ipt (totalreq))
+ allocate (msk (totalreq))
+
+ ipt(:) = -1
+
+ DO ireq = 1, totalreq
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ ipt(ireq) = gblock%pio(xblk,yblk)
+ ENDDO
+
+ DO iproc = 0, p_np_active-1
+ msk = (ipt == p_address_active(iproc))
+ nreq = count(msk)
+
+ IF (nreq > 0) THEN
+
+ smesg = (/p_iam_glb, nreq/)
+ idest = p_address_active(iproc)
+ CALL mpi_send (smesg, 2, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err)
+
+ allocate (ibuf (nreq))
+
+ ibuf = pack(xlist(1:totalreq), msk)
+ CALL mpi_send (ibuf, nreq, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ ibuf = pack(ylist(1:totalreq), msk)
+ CALL mpi_send (ibuf, nreq, MPI_INTEGER, idest, mpi_tag_data, p_comm_glb, p_err)
+
+ isrc = idest
+
+ allocate (rbuf_r8_1d (nreq))
+
+ IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) THEN
+ CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out1)
+ ENDIF
+
+ IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) THEN
+ CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out2)
+ ENDIF
+
+ IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) THEN
+ CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out3)
+ ENDIF
+
+ IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) THEN
+ CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out4)
+ ENDIF
+
+ IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) THEN
+ CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out5)
+ ENDIF
+
+ IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) THEN
+ CALL mpi_recv (rbuf_r8_1d, nreq, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_r8_1d, msk, data_r8_2d_out6)
+ ENDIF
+
+ deallocate (rbuf_r8_1d)
+
+ IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN
+ allocate (rbuf_r8_2d (n1_r8_3d_in1,nreq))
+ CALL mpi_recv (rbuf_r8_2d, n1_r8_3d_in1*nreq, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_r8_2d, msk, data_r8_3d_out1)
+ deallocate (rbuf_r8_2d)
+ ENDIF
+
+ IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN
+ allocate (rbuf_r8_2d (n1_r8_3d_in2,nreq))
+ CALL mpi_recv (rbuf_r8_2d, n1_r8_3d_in2*nreq, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_r8_2d, msk, data_r8_3d_out2)
+ deallocate (rbuf_r8_2d)
+ ENDIF
+
+ allocate (rbuf_i4_1d (nreq))
+ IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN
+ CALL mpi_recv (rbuf_i4_1d, nreq, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_i4_1d, msk, data_i4_2d_out1)
+ ENDIF
+
+ IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN
+ CALL mpi_recv (rbuf_i4_1d, nreq, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL unpack_inplace (rbuf_i4_1d, msk, data_i4_2d_out2)
+ ENDIF
+
+ deallocate (rbuf_i4_1d)
+
+ deallocate (ibuf)
+ ENDIF
+ ENDDO
+
+ deallocate (xlist)
+ deallocate (ylist)
+ deallocate (ipt )
+ deallocate (msk )
+
+#else
+
+ DO ireq = 1, totalreq
+
+ xblk = grid_in%xblk(xlist(ireq))
+ yblk = grid_in%yblk(ylist(ireq))
+ xloc = grid_in%xloc(xlist(ireq))
+ yloc = grid_in%yloc(ylist(ireq))
+
+ IF (present(data_r8_2d_in1) .and. present(data_r8_2d_out1)) THEN
+ data_r8_2d_out1(ireq) = data_r8_2d_in1%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+
+ IF (present(data_r8_2d_in2) .and. present(data_r8_2d_out2)) THEN
+ data_r8_2d_out2(ireq) = data_r8_2d_in2%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+
+ IF (present(data_r8_2d_in3) .and. present(data_r8_2d_out3)) THEN
+ data_r8_2d_out3(ireq) = data_r8_2d_in3%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+
+ IF (present(data_r8_2d_in4) .and. present(data_r8_2d_out4)) THEN
+ data_r8_2d_out4(ireq) = data_r8_2d_in4%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+
+ IF (present(data_r8_2d_in5) .and. present(data_r8_2d_out5)) THEN
+ data_r8_2d_out5(ireq) = data_r8_2d_in5%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+
+ IF (present(data_r8_2d_in6) .and. present(data_r8_2d_out6)) THEN
+ data_r8_2d_out6(ireq) = data_r8_2d_in6%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+
+ IF (present(data_r8_3d_in1) .and. present(data_r8_3d_out1) .and. present(n1_r8_3d_in1)) THEN
+ data_r8_3d_out1(:,ireq) = data_r8_3d_in1%blk(xblk,yblk)%val(:,xloc,yloc)
+ ENDIF
+
+ IF (present(data_r8_3d_in2) .and. present(data_r8_3d_out2) .and. present(n1_r8_3d_in2)) THEN
+ data_r8_3d_out2(:,ireq) = data_r8_3d_in2%blk(xblk,yblk)%val(:,xloc,yloc)
+ ENDIF
+
+ IF (present(data_i4_2d_in1) .and. present(data_i4_2d_out1)) THEN
+ data_i4_2d_out1(ireq) = data_i4_2d_in1%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+
+ IF (present(data_i4_2d_in2) .and. present(data_i4_2d_out2)) THEN
+ data_i4_2d_out2(ireq) = data_i4_2d_in2%blk(xblk,yblk)%val(xloc,yloc)
+ ENDIF
+
+ ENDDO
+
+#endif
+
+ END SUBROUTINE aggregation_request_data
+
+#ifdef USEMPI
+
+ SUBROUTINE aggregation_compute_done ()
+
+ USE MOD_SPMD_Task
+
+ IMPLICIT NONE
+
+ integer :: smesg(2), iproc, idest
+
+#ifdef MPAS_EMBEDDED_COLM
+ RETURN
+#endif
+
+ IF (p_is_compute) THEN
+ DO iproc = 0, p_np_active-1
+ smesg = (/p_iam_glb, -1/)
+ idest = p_address_active(iproc)
+ CALL mpi_send (smesg, 2, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err)
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE aggregation_compute_done
+
+#endif
+
+
+ SUBROUTINE fillnan (vec, fill, defval)
+
+ USE MOD_Precision
+ USE MOD_UserDefFun, only: isnan_ud
+ IMPLICIT NONE
+
+ real(r8), intent(inout) :: vec(:)
+ logical, intent(in) :: fill
+ real(r8), intent(in) :: defval
+
+ ! local variables
+ integer :: i, n
+ real(r8) :: s
+
+ n = 0
+ s = 0.
+ DO i = lbound(vec,1), ubound(vec,1)
+ IF (.not. isnan_ud(vec(i))) THEN
+ n = n + 1
+ s = s + vec(i)
+ ENDIF
+ ENDDO
+
+ IF ((n > 0) .and. (n < size(vec))) THEN
+ s = s/n
+ DO i = lbound(vec,1), ubound(vec,1)
+ IF (isnan_ud(vec(i))) vec(i) = s
+ ENDDO
+ ENDIF
+
+ IF ((n == 0) .and. fill) THEN
+ vec(:) = defval
+ ENDIF
+
+ END SUBROUTINE fillnan
+
+END MODULE MOD_AggregationRequestData
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..e46580e731
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Block.F90
@@ -0,0 +1,642 @@
+#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.
+! The (i,j) element of 2D array gblock%pio saves the global communication
+! number of process which is in charge of Input/Output of block (i,j).
+!
+! 3.
+! For Input/Output processes, "gblock%nblkme, gblock%xblkme(:), gblock%yblkme(:)"
+! SAVE the locations of blocks which are handled by themselves.
+!
+! 4.
+! Division of blocks can be generated by number of blocks globally (by set_by_size),
+! or set by predefined boundaries in files (by set_by_file).
+!
+! 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 (:)
+
+ ! IO.
+ integer, allocatable :: pio(:,:)
+
+ integer :: nblkme
+ integer, allocatable :: xblkme(:), yblkme(:)
+
+ CONTAINS
+
+ procedure, PUBLIC :: set => block_set
+
+ procedure, PUBLIC :: save_to_file => block_save_to_file
+ procedure, PUBLIC :: load_from_file => block_load_from_file
+
+ procedure, PRIVATE :: clip => block_clip
+ procedure, PRIVATE :: init_pio => block_init_pio
+ procedure, PRIVATE :: read_pio => block_read_pio
+
+ final :: block_free_mem
+
+ END type block_type
+
+ ! ---- Instance ----
+ type (block_type) :: gblock
+
+
+ ! ---- PUBLIC SUBROUTINE ----
+ PUBLIC :: get_filename_block
+
+CONTAINS
+
+ ! --------------------------------
+ SUBROUTINE block_set (this)
+
+ USE MOD_Precision
+ USE MOD_Namelist
+ USE MOD_Utils
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ IMPLICIT NONE
+
+ class (block_type) :: this
+
+ ! Local Variables
+ logical :: fexists
+ integer :: iblk, jblk
+
+ inquire(file=trim(DEF_BlockInfoFile), exist=fexists)
+
+ IF (fexists) THEN
+
+ CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lat_s', this%lat_s)
+ CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lat_n', this%lat_n)
+ CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lon_w', this%lon_w)
+ CALL ncio_read_bcast_serial (DEF_BlockInfoFile, 'lon_e', this%lon_e)
+
+ this%nyblk = size(this%lat_s)
+ this%nxblk = size(this%lon_w)
+
+ ! blocks should be from south to north
+ IF (this%lat_s(1) > this%lat_s(this%nyblk)) THEN
+ this%lat_s = this%lat_s(this%nyblk:1:-1)
+ this%lat_n = this%lat_n(this%nyblk:1:-1)
+ ENDIF
+
+ ELSE
+
+ IF (DEF_AverageElementSize > 0) THEN
+
+ this%nxblk = floor(360./(DEF_AverageElementSize/120.*50))
+ this%nxblk = min(this%nxblk,360)
+ DO WHILE ((this%nxblk < 360) .and. (mod(360,this%nxblk) /= 0))
+ this%nxblk = this%nxblk + 1
+ ENDDO
+
+ this%nyblk = floor(180./(DEF_AverageElementSize/120.*50))
+ this%nyblk = min(this%nyblk,180)
+ DO WHILE ((this%nyblk < 180) .and. (mod(180,this%nyblk) /= 0))
+ this%nyblk = this%nyblk + 1
+ ENDDO
+
+ ELSE
+
+ this%nxblk = DEF_nx_blocks
+ this%nyblk = DEf_ny_blocks
+
+ ENDIF
+
+ IF ((mod(360,this%nxblk) /= 0) .or. (mod(180,this%nyblk) /= 0)) THEN
+ IF (p_is_root) THEN
+ write(*,*) 'Number of blocks in longitude should be a factor of 360 '
+ write(*,*) ' and Number of blocks in latitude should be a factor of 180.'
+ CALL CoLM_stop ()
+ ENDIF
+ ENDIF
+
+ allocate (this%lon_w (this%nxblk))
+ allocate (this%lon_e (this%nxblk))
+
+ DO iblk = 1, this%nxblk
+ this%lon_w(iblk) = -180.0 + 360.0/this%nxblk * (iblk-1)
+ this%lon_e(iblk) = -180.0 + 360.0/this%nxblk * iblk
+
+ CALL normalize_longitude (this%lon_w(iblk))
+ CALL normalize_longitude (this%lon_e(iblk))
+ ENDDO
+
+ allocate (this%lat_s (this%nyblk))
+ allocate (this%lat_n (this%nyblk))
+
+ DO jblk = 1, this%nyblk
+ this%lat_s(jblk) = -90.0 + 180.0/this%nyblk * (jblk-1)
+ this%lat_n(jblk) = -90.0 + 180.0/this%nyblk * jblk
+ ENDDO
+
+ ENDIF
+
+#ifndef SinglePoint
+ IF (p_is_root) THEN
+ write (*,*)
+ write (*,'(A)') '----- Block information -----'
+ write (*,'(I4,A,I4,A)') this%nxblk, ' blocks in longitude,', &
+ this%nyblk, ' blocks in latitude.'
+ write (*,*)
+ ENDIF
+#else
+ write(*,'(A)') 'Blocks : Set (360 longitude x 180 latitude) blocks for Single Point.'
+#endif
+
+#ifndef SinglePoint
+ CALL this%init_pio ()
+#endif
+
+ END SUBROUTINE block_set
+
+ ! --------------------------------
+ SUBROUTINE block_save_to_file (this, dir_landdata)
+
+ USE MOD_NetCDFSerial
+ USE MOD_SPMD_Task
+ IMPLICIT NONE
+
+ class (block_type) :: this
+
+ character(len=*), intent(in) :: dir_landdata
+
+ ! Local variables
+ character(len=256) :: filename
+
+ IF (p_is_root) THEN
+
+ filename = trim(dir_landdata) // '/block.nc'
+
+ CALL ncio_create_file (filename)
+
+ CALL ncio_define_dimension (filename, 'longitude', this%nxblk)
+ CALL ncio_define_dimension (filename, 'latitude', this%nyblk)
+
+ CALL ncio_write_serial (filename, 'lat_s', this%lat_s, 'latitude' )
+ CALL ncio_write_serial (filename, 'lat_n', this%lat_n, 'latitude' )
+ CALL ncio_write_serial (filename, 'lon_w', this%lon_w, 'longitude')
+ CALL ncio_write_serial (filename, 'lon_e', this%lon_e, 'longitude')
+
+ ENDIF
+
+ END SUBROUTINE block_save_to_file
+
+ ! --------------------------------
+ SUBROUTINE block_load_from_file (this, dir_landdata)
+
+ USE MOD_NetCDFSerial
+ USE MOD_SPMD_Task
+ 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 (p_is_root) THEN
+ write (*,*) 'Block information:'
+ write (*,'(I3,A,I3,A)') this%nxblk, ' blocks in longitude,', &
+ this%nyblk, ' blocks in latitude.'
+ write (*,*)
+ ENDIF
+
+#ifdef MPAS_EMBEDDED_COLM
+ IF (allocated(this%pio)) deallocate(this%pio)
+ allocate (this%pio (this%nxblk,this%nyblk))
+ this%pio(:,:) = -1
+ this%nblkme = 0
+#else
+ CALL this%read_pio (dir_landdata)
+#endif
+
+ END SUBROUTINE block_load_from_file
+
+ ! --------------------------------
+ SUBROUTINE block_clip (this, &
+ iblk_south, iblk_north, iblk_west, iblk_east, numblocks)
+
+ USE MOD_Namelist
+ USE MOD_Utils
+ IMPLICIT NONE
+
+ class (block_type) :: this
+ integer, intent(out) :: iblk_south, iblk_north, iblk_west, iblk_east
+ integer, intent(out), optional :: numblocks
+
+ ! Local Variables
+ real(r8) :: edges, edgen, edgew, edgee
+ integer :: numblocks_x, numblocks_y
+
+ edges = DEF_domain%edges
+ edgen = DEF_domain%edgen
+ edgew = DEF_domain%edgew
+ edgee = DEF_domain%edgee
+
+ iblk_south = find_nearest_south (edges, this%nyblk, this%lat_s)
+ iblk_north = find_nearest_north (edgen, this%nyblk, this%lat_n)
+
+ CALL normalize_longitude (edgew)
+ CALL normalize_longitude (edgee)
+
+ IF (edgew == edgee) THEN
+ iblk_west = 1
+ iblk_east = this%nxblk
+ ELSE
+ iblk_west = find_nearest_west (edgew, this%nxblk, this%lon_w)
+ iblk_east = find_nearest_east (edgee, this%nxblk, this%lon_e)
+
+ IF (iblk_west == iblk_east) THEN
+ IF ((lon_between_floor(edgee,this%lon_w(iblk_west),edgew)) &
+ .and. (this%lon_w(iblk_west) /= edgew)) THEN
+ iblk_west = 1
+ iblk_east = this%nxblk
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (present(numblocks)) THEN
+
+ numblocks_y = iblk_north - iblk_south + 1
+
+ IF (iblk_east >= iblk_west) THEN
+ numblocks_x = iblk_east - iblk_west + 1
+ ELSE
+ numblocks_x = this%nxblk - iblk_west + 1 + iblk_east
+ ENDIF
+
+ numblocks = numblocks_x * numblocks_y
+
+ ENDIF
+
+ END SUBROUTINE block_clip
+
+ ! --------------------------------
+ SUBROUTINE block_init_pio (this)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Utils
+ IMPLICIT NONE
+
+ class (block_type) :: this
+
+ integer :: iblk, jblk, iproc
+ integer :: iblk_south, iblk_north, iblk_west, iblk_east
+ integer :: numblocks, ngrp
+ integer :: iblkme
+
+ IF (p_is_root) THEN
+ CALL this%clip (iblk_south, iblk_north, iblk_west, iblk_east, numblocks)
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+
+ IF ((mod(p_np_glb,DEF_PIO_groupsize) == 0) .and. (DEF_PIO_groupsize > 2)) THEN
+ ngrp = p_np_glb / DEF_PIO_groupsize
+ ELSE
+ ngrp = (p_np_glb-1) / DEF_PIO_groupsize
+ ENDIF
+ ngrp = min(max(ngrp, 1), numblocks)
+
+ CALL divide_processes_into_groups (ngrp)
+#endif
+
+ allocate (this%pio (this%nxblk,this%nyblk))
+ this%pio(:,:) = -1
+
+ IF (p_is_root) THEN
+
+ iproc = -1
+ DO jblk = iblk_south, iblk_north
+
+ iblk = iblk_west
+ DO WHILE (.true.)
+#ifdef USEMPI
+ iproc = mod(iproc+1, p_np_active)
+ this%pio(iblk,jblk) = p_address_active(iproc)
+#else
+ this%pio(iblk,jblk) = p_root
+#endif
+
+ IF (iblk /= iblk_east) THEN
+ iblk = mod(iblk,this%nxblk) + 1
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_bcast (this%pio, this%nxblk * this%nyblk, MPI_INTEGER, &
+ p_address_root, p_comm_glb, p_err)
+#endif
+
+ this%nblkme = 0
+ IF (p_is_active) THEN
+ this%nblkme = count(this%pio == p_iam_glb)
+ IF (this%nblkme > 0) THEN
+ iblkme = 0
+ allocate (this%xblkme(this%nblkme))
+ allocate (this%yblkme(this%nblkme))
+ DO iblk = 1, this%nxblk
+ DO jblk = 1, this%nyblk
+ IF (p_iam_glb == this%pio(iblk,jblk)) THEN
+ iblkme = iblkme + 1
+ this%xblkme(iblkme) = iblk
+ this%yblkme(iblkme) = jblk
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE block_init_pio
+
+ ! --------------------------------
+ SUBROUTINE block_read_pio (this, dir_landdata)
+
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_Namelist
+ IMPLICIT NONE
+
+ class (block_type) :: this
+ character(len=*), intent(in) :: dir_landdata
+
+ ! Local Variables
+ character(len=256) :: filename, cyear
+ integer, allocatable :: nelm_io(:), nelmblk(:,:)
+ integer :: iblk_south, iblk_north, iblk_west, iblk_east
+ integer :: numblocks, ngrp, iblk, jblk, iproc, jproc
+ integer :: iblkme
+
+ IF (p_is_root) THEN
+ ! Whether it varies by year???
+ write(cyear,'(i4.4)') DEF_LC_YEAR
+ filename = trim(dir_landdata) // '/mesh/' // trim(cyear) // '/mesh.nc'
+ CALL ncio_read_serial (filename, 'nelm_blk', nelmblk)
+ numblocks = count(nelmblk > 0)
+
+ CALL this%clip (iblk_south, iblk_north, iblk_west, iblk_east)
+
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_root) THEN
+
+ IF ((mod(p_np_glb,DEF_PIO_groupsize) == 0) .and. (DEF_PIO_groupsize > 2)) THEN
+ ngrp = p_np_glb / DEF_PIO_groupsize
+ ELSE
+ ngrp = (p_np_glb-1) / DEF_PIO_groupsize
+ ENDIF
+ ngrp = min(max(ngrp, 1), numblocks)
+
+ DO WHILE (.true.)
+
+ allocate (nelm_io (ngrp))
+ nelm_io(:) = 0
+
+ DO jblk = iblk_south, iblk_north
+ iblk = iblk_west
+ DO WHILE (.true.)
+
+ IF (nelmblk(iblk,jblk) > 0) THEN
+ iproc = minloc(nelm_io, dim=1)
+ nelm_io(iproc) = nelm_io(iproc) + nelmblk(iblk,jblk)
+ ENDIF
+
+ IF (iblk /= iblk_east) THEN
+ iblk = mod(iblk,this%nxblk) + 1
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+
+ IF (maxval(nelm_io) < 2 * minval(nelm_io)) THEN
+ deallocate (nelm_io)
+ EXIT
+ ELSE
+ ngrp = ngrp - 1
+ deallocate (nelm_io)
+ ENDIF
+ ENDDO
+
+ IF (DEF_nIO_eq_nBlock) THEN
+ ngrp = numblocks
+ ENDIF
+
+ IF ((p_np_glb-1)/ngrp < 2) THEN
+ CALL CoLM_stop ('CoLM called STOP: Too many groups or Too few processors for this case.')
+ ENDIF
+ ENDIF
+
+
+ CALL mpi_bcast (numblocks, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ CALL mpi_bcast (ngrp, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ CALL divide_processes_into_groups (ngrp)
+#endif
+
+ allocate (this%pio (this%nxblk,this%nyblk))
+ this%pio(:,:) = -1
+
+ IF (p_is_root) THEN
+
+#ifdef USEMPI
+ allocate (nelm_io (0:p_np_active-1))
+ nelm_io(:) = 0
+ jproc = -1
+#endif
+
+ DO jblk = iblk_south, iblk_north
+ iblk = iblk_west
+ DO WHILE (.true.)
+#ifdef USEMPI
+ IF (nelmblk(iblk,jblk) > 0) THEN
+ iproc = minloc(nelm_io, dim=1) - 1
+ this%pio(iblk,jblk) = p_address_active(iproc)
+ nelm_io(iproc) = nelm_io(iproc) + nelmblk(iblk,jblk)
+ ELSEIF (nelmblk(iblk,jblk) == 0) THEN
+ jproc = mod(jproc+1, p_np_active)
+ this%pio(iblk,jblk) = p_address_active(jproc)
+ ENDIF
+#else
+ this%pio(iblk,jblk) = p_root
+#endif
+
+ IF (iblk /= iblk_east) THEN
+ iblk = mod(iblk,this%nxblk) + 1
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+
+#ifdef USEMPI
+ deallocate (nelm_io)
+#endif
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_bcast (this%pio, this%nxblk * this%nyblk, MPI_INTEGER, &
+ p_address_root, p_comm_glb, p_err)
+#endif
+
+ this%nblkme = 0
+ IF (p_is_active) THEN
+ this%nblkme = count(this%pio == p_iam_glb)
+ IF (this%nblkme > 0) THEN
+ iblkme = 0
+ allocate (this%xblkme(this%nblkme))
+ allocate (this%yblkme(this%nblkme))
+ DO iblk = 1, this%nxblk
+ DO jblk = 1, this%nyblk
+ IF (p_iam_glb == this%pio(iblk,jblk)) THEN
+ iblkme = iblkme + 1
+ this%xblkme(iblkme) = iblk
+ this%yblkme(iblkme) = jblk
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (allocated(nelmblk)) deallocate (nelmblk)
+
+ END SUBROUTINE block_read_pio
+
+ ! --------------------------------
+ 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%pio) ) deallocate (this%pio )
+
+ 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
+ integer :: i
+
+ 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_CatchmentDataReadin.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90
new file mode 100644
index 0000000000..dcb444bc80
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_CatchmentDataReadin.F90
@@ -0,0 +1,375 @@
+#include
+
+MODULE MOD_CatchmentDataReadin
+
+!--------------------------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Reading preprocessed MERIT Hydro data and generated catchment data in netcdf files.
+!
+! 1. If "in_one_file" is false, then the data is orgnized by 5 degree blocks.
+! The file name gives the southwest corner of the block.
+! For example, file "n60e075.nc" stores data in region from 65N to 60N and 75E to 80E,
+! Subroutines loop over all 5 degree blocks in simulation region.
+!
+! 2. Data is saved in variables with types of "block_data_xxxxx_xd".
+!
+! 3. Latitude in files is from north to south.
+!
+! Created by Shupeng Zhang, May 2023
+!--------------------------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+ integer, parameter :: nxhbox = 6000
+ integer, parameter :: nyhbox = 6000
+ integer, parameter :: nxhglb = 432000
+ integer, parameter :: nyhglb = 216000
+
+ INTERFACE catchment_data_read
+ MODULE procedure catchment_data_read_int32
+ MODULE procedure catchment_data_read_real8
+ END INTERFACE catchment_data_read
+
+CONTAINS
+
+ ! -----
+ SUBROUTINE catchment_data_read_int32 (file_meshdata_in, dataname, grid, rdata_int32, spv)
+
+ USE MOD_Grid
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: file_meshdata_in
+ character (len=*), intent(in) :: dataname
+ type (grid_type), intent(in) :: grid
+
+ type (block_data_int32_2d), intent(inout) :: rdata_int32
+ integer, intent(in), optional :: spv
+
+ IF (present(spv)) THEN
+ CALL catchment_data_read_general (file_meshdata_in, dataname, grid, &
+ rdata_int32 = rdata_int32, spv_i4 = spv)
+ ELSE
+ CALL catchment_data_read_general (file_meshdata_in, dataname, grid, &
+ rdata_int32 = rdata_int32)
+ ENDIF
+
+ END SUBROUTINE catchment_data_read_int32
+
+ ! -----
+ SUBROUTINE catchment_data_read_real8 (file_meshdata_in, dataname, grid, rdata_real8, spv)
+
+ USE MOD_Grid
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: file_meshdata_in
+ character (len=*), intent(in) :: dataname
+ type (grid_type), intent(in) :: grid
+
+ type (block_data_real8_2d), intent(inout) :: rdata_real8
+ real(r8), intent(in), optional :: spv
+
+ IF (present(spv)) THEN
+ CALL catchment_data_read_general (file_meshdata_in, dataname, grid, &
+ rdata_real8 = rdata_real8, spv_r8 = spv)
+ ELSE
+ CALL catchment_data_read_general (file_meshdata_in, dataname, grid, &
+ rdata_real8 = rdata_real8)
+ ENDIF
+
+ END SUBROUTINE catchment_data_read_real8
+
+ ! -----
+ SUBROUTINE catchment_data_read_general (file_meshdata_in, dataname, grid, &
+ rdata_int32, spv_i4, rdata_real8, spv_r8)
+
+ USE MOD_SPMD_Task
+ USE MOD_Block
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_Utils
+ USE MOD_NetCDFSerial
+ IMPLICIT NONE
+
+ character (len=*), intent(in) :: file_meshdata_in
+ character (len=*), intent(in) :: dataname
+ type (grid_type), intent(in) :: grid
+
+ type (block_data_int32_2d), intent(inout), optional :: rdata_int32
+ integer, intent(in), optional :: spv_i4
+
+ type (block_data_real8_2d), intent(inout), optional :: rdata_real8
+ real(r8), intent(in), optional :: spv_r8
+
+
+ ! Local Variables
+ logical :: in_one_file
+ integer :: nlat, nlon, ilon
+ integer :: iblkme, iblk, jblk, isouth, inorth, iwest, ieast, ibox, jbox
+ integer :: xdsp, ydsp, i0, i1, j0, j1, il0, il1, jl0, jl1
+ integer :: i0min, i1max, if0, if1, jf0, jf1, i0next, i1next
+ character(len=256) :: file_mesh, path_mesh
+ character(len=3) :: pre1
+ character(len=4) :: pre2
+ integer, allocatable :: dcache_i4(:,:)
+ real(r8), allocatable :: dcache_r8(:,:)
+ real(r8), allocatable :: latitude(:), longitude(:)
+ logical :: fexists
+
+ IF (p_is_active) THEN
+
+ IF (p_iam_active == p_root) THEN
+ IF (grid%yinc == 1) THEN
+ write(*,*) 'Warning: latitude in catchment data should be from north to south.'
+ ENDIF
+ ENDIF
+
+ IF (p_iam_active == p_root) THEN
+ in_one_file = ncio_var_exist (file_meshdata_in, dataname)
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_bcast (in_one_file, 1, mpi_logical, p_root, p_comm_active, p_err)
+#endif
+
+ IF (in_one_file) THEN
+
+ file_mesh = file_meshdata_in
+
+ CALL ncio_read_serial (file_mesh, 'lat', latitude)
+ CALL ncio_read_serial (file_mesh, 'lon', longitude)
+
+ nlat = size(latitude )
+ nlon = size(longitude)
+
+ isouth = find_nearest_south (latitude(nlat), grid%nlat, grid%lat_s)
+ inorth = find_nearest_north (latitude(1), grid%nlat, grid%lat_n)
+
+ DO ilon = 1, nlon
+ CALL normalize_longitude (longitude(ilon))
+ ENDDO
+
+ iwest = find_nearest_west (longitude(1), grid%nlon, grid%lon_w)
+ ieast = find_nearest_east (longitude(nlon), grid%nlon, grid%lon_e)
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+
+ IF (present(rdata_int32)) THEN
+ IF (present(spv_i4)) THEN
+ rdata_int32%blk(iblk,jblk)%val(:,:) = spv_i4
+ ELSE
+ rdata_int32%blk(iblk,jblk)%val(:,:) = 0
+ ENDIF
+ ENDIF
+
+ IF (present(rdata_real8)) THEN
+ IF (present(spv_r8)) THEN
+ rdata_real8%blk(iblk,jblk)%val(:,:) = spv_r8
+ ELSE
+ rdata_real8%blk(iblk,jblk)%val(:,:) = -1.e36_r8
+ ENDIF
+ ENDIF
+
+ IF ((inorth > grid%ydsp(jblk)+nyhbox) .or. (isouth < grid%ydsp(jblk)+1)) THEN
+ CYCLE
+ ENDIF
+
+ j0 = max(inorth, grid%ydsp(jblk)+1)
+ j1 = min(isouth, grid%ydsp(jblk)+grid%ycnt(jblk))
+
+ jl0 = j0 - grid%ydsp(jblk)
+ jl1 = j1 - grid%ydsp(jblk)
+ jf0 = j0 - inorth + 1
+ jf1 = j1 - inorth + 1
+
+ i0min = grid%xdsp(iblk) + 1
+ i1max = grid%xdsp(iblk) + grid%xcnt(iblk)
+ IF (i1max > grid%nlon) i1max = i1max - grid%nlon
+
+ DO WHILE ((i0min /= i1max) .and. (.not. (lon_between_floor(grid%lon_w(i0min), &
+ grid%lon_w(iwest), grid%lon_e(ieast)))))
+ i0min = i0min + 1; IF (i0min > grid%nlon) i0min = 1
+ ENDDO
+
+ IF (lon_between_floor(grid%lon_w(i0min), grid%lon_w(iwest), grid%lon_e(ieast))) THEN
+ i0 = i0min
+ i1 = i0
+ i1next = i1 + 1; IF (i1next > grid%nlon) i1next = 1
+ DO WHILE ((i1 /= i1max) .and. &
+ lon_between_floor(grid%lon_w(i1next), grid%lon_w(iwest), grid%lon_e(ieast)))
+ i1 = i1next
+ i1next = i1 + 1; IF (i1next > grid%nlon) i1next = 1
+ ENDDO
+
+ if0 = i0 - iwest + 1; IF (if0 <= 0) if0 = if0 + grid%nlon
+ if1 = i1 - iwest + 1; IF (if1 <= 0) if1 = if1 + grid%nlon
+ il0 = i0 - grid%xdsp(iblk); IF (il0 <= 0) il0 = il0 + grid%nlon
+ il1 = i1 - grid%xdsp(iblk); IF (il1 <= 0) il1 = il1 + grid%nlon
+
+ IF (present(rdata_int32)) THEN
+ CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_i4)
+ dcache_i4 = transpose(dcache_i4)
+
+ rdata_int32%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_i4
+ ENDIF
+
+ IF (present(rdata_real8)) THEN
+ CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_r8)
+ dcache_r8 = transpose(dcache_r8)
+
+ rdata_real8%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_r8
+ ENDIF
+
+ ENDIF
+
+ IF (lon_between_ceil(grid%lon_e(i1max), grid%lon_w(iwest), grid%lon_e(ieast))) THEN
+ i1 = i1max
+ i0 = i1
+ i0next = i0 - 1; IF (i0next == 0) i0next = grid%nlon
+ DO WHILE ((i0 /= i0min) .and. &
+ lon_between_ceil(grid%lon_e(i0next), grid%lon_w(iwest), grid%lon_e(ieast)))
+ i0 = i0next
+ i0next = i0 - 1; IF (i0next == 0) i0next = grid%nlon
+ ENDDO
+
+ IF (i0 /= i0min) THEN
+ if0 = i0 - iwest + 1; IF (if0 <= 0) if0 = if0 + grid%nlon
+ if1 = i1 - iwest + 1; IF (if1 <= 0) if1 = if1 + grid%nlon
+ il0 = i0 - grid%xdsp(iblk); IF (il0 <= 0) il0 = il0 + grid%nlon
+ il1 = i1 - grid%xdsp(iblk); IF (il1 <= 0) il1 = il1 + grid%nlon
+
+ IF (present(rdata_int32)) THEN
+ CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_i4)
+ dcache_i4 = transpose(dcache_i4)
+
+ rdata_int32%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_i4
+ ENDIF
+
+ IF (present(rdata_real8)) THEN
+ CALL ncio_read_part_serial (file_mesh, dataname, (/jf0,if0/), (/jf1,if1/), dcache_r8)
+ dcache_r8 = transpose(dcache_r8)
+
+ rdata_real8%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_r8
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDDO
+
+ ELSE
+
+ ! remove suffix ".nc"
+ path_mesh = file_meshdata_in(1:len_trim(file_meshdata_in)-3)
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+
+ IF (present(rdata_int32)) THEN
+ IF (present(spv_i4)) THEN
+ rdata_int32%blk(iblk,jblk)%val(:,:) = spv_i4
+ ELSE
+ rdata_int32%blk(iblk,jblk)%val(:,:) = 0
+ ENDIF
+ ENDIF
+
+ IF (present(rdata_real8)) THEN
+ IF (present(spv_r8)) THEN
+ rdata_real8%blk(iblk,jblk)%val(:,:) = spv_r8
+ ELSE
+ rdata_real8%blk(iblk,jblk)%val(:,:) = -1.e36_r8
+ ENDIF
+ ENDIF
+
+ 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 > nxhglb) ieast = ieast - nxhglb
+
+ ibox = grid%xdsp(iblk)/nxhbox + 1
+ jbox = grid%ydsp(jblk)/nyhbox + 1
+
+ DO WHILE (.true.)
+
+ xdsp = (ibox-1) * nxhbox
+ ydsp = (jbox-1) * nyhbox
+
+ j0 = max(inorth-ydsp, 1)
+ j1 = min(isouth-ydsp, nyhbox)
+ jl0 = j0 + ydsp - inorth + 1
+ jl1 = j1 + ydsp - inorth + 1
+
+ IF (ieast >= iwest) THEN
+ i0 = max(iwest-xdsp, 1)
+ i1 = min(ieast-xdsp, nxhbox)
+ il0 = i0 + xdsp - iwest + 1
+ il1 = i1 + xdsp - iwest + 1
+ ELSE
+ IF (iwest <= xdsp+nxhbox) THEN
+ i0 = max(iwest-xdsp, 1)
+ i1 = nxhbox
+ il0 = i0 + xdsp - iwest + 1
+ il1 = i1 + xdsp - iwest + 1
+ ELSE
+ i0 = 1
+ i1 = min(ieast-xdsp, nxhbox)
+ il0 = i0 + xdsp + nxhglb - iwest + 1
+ il1 = i1 + xdsp + nxhglb - iwest + 1
+ ENDIF
+ ENDIF
+
+ IF (jbox <= 18) THEN
+ write (pre1,'(A1,I2.2)') 'n', (18-jbox)*5
+ ELSE
+ write (pre1,'(A1,I2.2)') 's', (jbox-18)*5
+ ENDIF
+
+ IF (ibox <= 36) THEN
+ write (pre2,'(A1,I3.3)') 'w', (37-ibox)*5
+ ELSE
+ write (pre2,'(A1,I3.3)') 'e', (ibox-37)*5
+ ENDIF
+
+ file_mesh = trim(path_mesh) // '/' // trim(pre1) // trim(pre2) // '.nc'
+
+ inquire(file=file_mesh, exist=fexists)
+ IF (fexists) THEN
+ IF (present(rdata_int32)) THEN
+ CALL ncio_read_part_serial (file_mesh, dataname, (/j0,i0/), (/j1,i1/), dcache_i4)
+ dcache_i4 = transpose(dcache_i4)
+
+ rdata_int32%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_i4
+ ENDIF
+
+ IF (present(rdata_real8)) THEN
+ CALL ncio_read_part_serial (file_mesh, dataname, (/j0,i0/), (/j1,i1/), dcache_r8)
+ dcache_r8 = transpose(dcache_r8)
+
+ rdata_real8%blk(iblk,jblk)%val(il0:il1,jl0:jl1) = dcache_r8
+ ENDIF
+ ENDIF
+
+ IF ((ieast >= xdsp + 1) .and. (ieast <= xdsp + nxhbox)) THEN
+ IF (isouth <= ydsp + nyhbox) THEN
+ EXIT
+ ELSE
+ ibox = grid%xdsp(iblk)/nxhbox + 1
+ jbox = jbox + 1
+ ENDIF
+ ELSE
+ ibox = mod(ibox, nxhglb/nxhbox) + 1
+ ENDIF
+
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE catchment_data_read_general
+
+END MODULE MOD_CatchmentDataReadin
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..d810f957f0
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ComputePushData.F90
@@ -0,0 +1,1136 @@
+#include
+
+MODULE MOD_ComputePushData
+!--------------------------------------------------------------------------------
+! DESCRIPTION:
+!--------------------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_DataType
+ USE MOD_SPMD_Task
+ USE MOD_Utils
+ 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 COLM_PARALLEL
+ ! 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_pushdata_subset
+
+ 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 COLM_PARALLEL
+ integer, allocatable :: ids(:), loc_from_me(:), loc_from_other(:)
+ integer :: request(3)
+#endif
+ integer :: i, iloc, irank, jrank, n_req_other
+
+
+ IF (p_is_compute) THEN
+
+ allocate (ids_me_sorted (num_me))
+ allocate (order_ids (num_me))
+ IF (num_me > 0) THEN
+ ids_me_sorted = ids_me
+ order_ids = (/(i, i = 1, num_me)/)
+ CALL quicksort (num_me, ids_me_sorted, order_ids)
+ 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 COLM_PARALLEL
+ CALL mpi_barrier (p_comm_compute, p_err)
+
+ allocate (pushdata%n_to_other (0:p_np_compute-1))
+ allocate (pushdata%to_other (0:p_np_compute-1))
+
+ allocate (pushdata%n_from_other (0:p_np_compute-1))
+ allocate (pushdata%other_to (0:p_np_compute-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(p_iam_compute+1, p_np_compute)
+ jrank = modulo(p_iam_compute-1, p_np_compute)
+ DO WHILE (irank /= p_iam_compute)
+
+ CALL mpi_isend (n_req_uniq, 1, MPI_INTEGER, jrank, 10, &
+ p_comm_compute, request(1), p_err)
+
+ IF (n_req_uniq > 0) THEN
+ CALL mpi_isend(ids_req_uniq, n_req_uniq, MPI_INTEGER, jrank, 11, &
+ p_comm_compute, request(2), p_err)
+ ENDIF
+
+ CALL mpi_recv (n_req_other, 1, MPI_INTEGER, irank, 10, &
+ p_comm_compute, p_stat, p_err)
+
+ IF (n_req_other > 0) THEN
+
+ allocate (ids (n_req_other))
+ CALL mpi_recv (ids, n_req_other, MPI_INTEGER, irank, 11, &
+ p_comm_compute, p_stat, p_err)
+
+ 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, &
+ p_comm_compute, request(3), p_err)
+
+ ENDIF
+
+ IF (n_req_uniq > 0) THEN
+
+ CALL mpi_recv (loc_from_other, n_req_uniq, MPI_INTEGER, &
+ jrank, 12, p_comm_compute, p_stat, p_err)
+
+ 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, p_err)
+ IF (n_req_uniq > 0) CALL mpi_wait(request(2), MPI_STATUSES_IGNORE, p_err)
+ IF (n_req_other > 0) CALL mpi_wait(request(3), MPI_STATUSES_IGNORE, p_err)
+
+ IF (allocated(ids )) deallocate(ids )
+ IF (allocated(loc_from_me)) deallocate(loc_from_me)
+
+ irank = modulo(irank+1, p_np_compute)
+ jrank = modulo(jrank-1, p_np_compute)
+ ENDDO
+
+ IF (allocated (loc_from_other)) deallocate (loc_from_other)
+
+ CALL mpi_barrier (p_comm_compute, p_err)
+#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 (p_is_compute) THEN
+
+ n_req_uniq = 0
+
+ allocate (ids_req_uniq (num_req))
+ IF (num_req > 0) THEN
+ DO i = 1, size(ids_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, size(ids_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 (p_is_compute) THEN
+
+ 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
+
+ WHERE ((area_req <= 0.) .or. (ids_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 COLM_PARALLEL
+ DO irank = 0, p_np_compute-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_pushdata_subset ( &
+ num_me, num_req, pushdata_in, subset_in, pushdata_out, subset_out, numsubset)
+
+ USE MOD_Pixelset
+ IMPLICIT NONE
+
+ integer, intent(in) :: num_me
+ integer, intent(in) :: num_req
+
+ type(compute_pushdata_type), intent(in) :: pushdata_in
+ type(subset_type), intent(in) :: subset_in
+
+ type(compute_pushdata_type), intent(inout) :: pushdata_out
+ type(subset_type), optional, intent(inout) :: subset_out
+ integer, optional, intent(inout) :: numsubset
+
+ ! Local Variables
+ integer :: i, j, ii, jj, idsp, jdsp, kdsp, nsub, irank
+ integer, allocatable :: nsub_me (:), nsub_req(:), nsub_req_uniq(:)
+ integer, allocatable :: subdsp_me(:), subdsp_req_uniq(:)
+
+ IF (p_is_compute) THEN
+
+ IF (num_me > 0) THEN
+ allocate (nsub_me (num_me))
+ nsub_me = subset_in%subend - subset_in%substt + 1
+ ENDIF
+
+ IF (num_req > 0) THEN
+ allocate (nsub_req (num_req))
+ ENDIF
+
+ CALL compute_push_data (pushdata_in, nsub_me, nsub_req, 0)
+
+ IF (present(subset_out) .and. present(numsubset)) THEN
+ IF (num_req > 0) THEN
+ allocate (subset_out%substt (num_req))
+ allocate (subset_out%subend (num_req))
+
+ idsp = 0
+ DO i = 1, num_req
+ IF (nsub_req(i) == 0) THEN
+ subset_out%substt(i) = 0
+ subset_out%subend(i) = -1
+ ELSE
+ subset_out%substt(i) = idsp + 1
+ subset_out%subend(i) = idsp + nsub_req(i)
+ ENDIF
+ idsp = idsp + nsub_req(i)
+ ENDDO
+
+ numsubset = idsp
+ ELSE
+ numsubset = 0
+ ENDIF
+ ENDIF
+
+ IF (num_me > 0) THEN
+ allocate (subdsp_me (num_me))
+ idsp = 0
+ DO i = 1, num_me
+ IF (nsub_me(i) > 0) THEN
+ subdsp_me(i) = idsp
+ idsp = idsp + nsub_me(i)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ pushdata_out%num_req_uniq = 0
+ IF (pushdata_in%num_req_uniq > 0) THEN
+
+ allocate (nsub_req_uniq (pushdata_in%num_req_uniq))
+ allocate (subdsp_req_uniq (pushdata_in%num_req_uniq))
+
+ nsub_req_uniq(:) = 0
+ DO i = 1, size(pushdata_in%addr_single)
+ nsub_req_uniq(pushdata_in%addr_single(i)) = nsub_req(i)
+ ENDDO
+
+ idsp = 0
+ DO i = 1, pushdata_in%num_req_uniq
+ IF (nsub_req_uniq(i) > 0) THEN
+ subdsp_req_uniq(i) = idsp
+ idsp = idsp + nsub_req_uniq(i)
+ ENDIF
+ ENDDO
+
+ pushdata_out%num_req_uniq = sum(nsub_req_uniq)
+ ENDIF
+
+
+ IF (pushdata_out%num_req_uniq > 0) THEN
+ allocate (pushdata_out%addr_single (sum(nsub_req)))
+
+ idsp = 0
+ DO i = 1, num_req
+ IF (nsub_req(i) > 0) THEN
+ jdsp = subdsp_req_uniq(pushdata_in%addr_single(i))
+ pushdata_out%addr_single(idsp+1:idsp+nsub_req(i)) = &
+ (/(jj, jj=jdsp+1,jdsp+nsub_req(i))/)
+ idsp = idsp + nsub_req(i)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ pushdata_out%nself = 0
+ DO i = 1, pushdata_in%nself
+ pushdata_out%nself = pushdata_out%nself + nsub_me(pushdata_in%self_from(i))
+ ENDDO
+
+ IF (pushdata_out%nself > 0) THEN
+ allocate (pushdata_out%self_from (pushdata_out%nself))
+ allocate (pushdata_out%self_to (pushdata_out%nself))
+
+ kdsp = 0
+ DO i = 1, pushdata_in%nself
+ IF (nsub_me(pushdata_in%self_from(i)) > 0) THEN
+ nsub = nsub_me(pushdata_in%self_from(i))
+ idsp = subdsp_me (pushdata_in%self_from(i))
+ jdsp = subdsp_req_uniq(pushdata_in%self_to (i))
+ pushdata_out%self_from(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/)
+ pushdata_out%self_to (kdsp+1:kdsp+nsub) = (/(jj, jj=jdsp+1,jdsp+nsub)/)
+ kdsp = kdsp + nsub
+ ENDIF
+ ENDDO
+ ENDIF
+
+#ifdef COLM_PARALLEL
+ allocate (pushdata_out%n_to_other (0:p_np_compute-1))
+ allocate (pushdata_out%to_other (0:p_np_compute-1))
+
+ DO irank = 0, p_np_compute-1
+
+ pushdata_out%n_to_other(irank) = 0
+ DO i = 1, pushdata_in%n_to_other(irank)
+ pushdata_out%n_to_other(irank) = pushdata_out%n_to_other(irank) &
+ + nsub_me(pushdata_in%to_other(irank)%val(i))
+ ENDDO
+
+ IF (pushdata_out%n_to_other(irank) > 0) THEN
+ allocate (pushdata_out%to_other(irank)%val (pushdata_out%n_to_other(irank)))
+ kdsp = 0
+ DO i = 1, pushdata_in%n_to_other(irank)
+ IF (nsub_me(pushdata_in%to_other(irank)%val(i)) > 0) THEN
+ nsub = nsub_me (pushdata_in%to_other(irank)%val(i))
+ idsp = subdsp_me(pushdata_in%to_other(irank)%val(i))
+ pushdata_out%to_other(irank)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/)
+ kdsp = kdsp + nsub
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ENDDO
+
+ allocate (pushdata_out%n_from_other (0:p_np_compute-1))
+ allocate (pushdata_out%other_to (0:p_np_compute-1))
+
+ DO irank = 0, p_np_compute-1
+ pushdata_out%n_from_other(irank) = 0
+ DO i = 1, pushdata_in%n_from_other(irank)
+ pushdata_out%n_from_other(irank) = pushdata_out%n_from_other(irank) &
+ + nsub_req_uniq(pushdata_in%other_to(irank)%val(i))
+ ENDDO
+
+ IF (pushdata_out%n_from_other(irank) > 0) THEN
+ allocate (pushdata_out%other_to(irank)%val (pushdata_out%n_from_other(irank)))
+ kdsp = 0
+ DO i = 1, pushdata_in%n_from_other(irank)
+ IF (nsub_req_uniq(pushdata_in%other_to(irank)%val(i)) > 0) THEN
+ nsub = nsub_req_uniq (pushdata_in%other_to(irank)%val(i))
+ idsp = subdsp_req_uniq(pushdata_in%other_to(irank)%val(i))
+ pushdata_out%other_to(irank)%val(kdsp+1:kdsp+nsub) = (/(ii, ii=idsp+1,idsp+nsub)/)
+ kdsp = kdsp + nsub
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+#endif
+
+ IF (allocated (nsub_me )) deallocate (nsub_me )
+ IF (allocated (nsub_req )) deallocate (nsub_req )
+ IF (allocated (nsub_req_uniq )) deallocate (nsub_req_uniq )
+ IF (allocated (subdsp_me )) deallocate (subdsp_me )
+ IF (allocated (subdsp_req_uniq)) deallocate (subdsp_req_uniq)
+
+ ENDIF
+
+ END SUBROUTINE build_compute_pushdata_subset
+
+ ! ----------
+ 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 (p_is_compute) THEN
+
+ ngrid = 0
+ DO iproc = 0, p_np_active-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, p_np_active-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
+
+ 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
+
+ DO iset = 1, remapdata%npset
+ IF (remapdata%npart(iset) > 0) THEN
+ 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)
+ 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)
+ ! from km^2 to m^2
+ remapdata%areapart(iset)%val(ipart) = mapping%areapart(iset)%val(ipart) * 1.e6
+ ENDDO
+
+ IF (remapdata%npart(iset) > 0) THEN
+ remapdata%sum_area(iset) = sum(remapdata%areapart(iset)%val)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (allocated(ilon_me)) deallocate(ilon_me)
+ IF (allocated(ilat_me)) deallocate(ilat_me)
+
+ ENDIF
+
+ END SUBROUTINE build_compute_remapdata
+
+ ! ----------
+ 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 (p_is_compute) THEN
+
+ 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 COLM_PARALLEL
+ 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, p_np_compute-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, p_comm_compute, req_send(iproc), p_err)
+
+ 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, p_np_compute-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, p_comm_compute, req_recv(iproc), p_err)
+
+ idsp = iend
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (ndatarecv > 0) THEN
+
+ CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err)
+
+ idsp = 0
+ DO irank = 0, p_np_compute-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, p_err)
+ 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 (p_is_compute) THEN
+
+ 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 COLM_PARALLEL
+ 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, p_np_compute-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, p_comm_compute, req_send(iproc), p_err)
+
+ 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, p_np_compute-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, p_comm_compute, req_recv(iproc), p_err)
+
+ idsp = iend
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (ndatarecv > 0) THEN
+
+ CALL mpi_waitall(size(req_recv), req_recv, MPI_STATUSES_IGNORE, p_err)
+
+ idsp = 0
+ DO irank = 0, p_np_compute-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, p_err)
+ 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 (p_is_compute) THEN
+
+ ! 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
+ vec_recv = 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 (p_is_compute) THEN
+
+ ! 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
+
+ vec_recv(:) = fillvalue
+
+ 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
+ vec_recv(j) = vec_recv(j) / sumarea
+ 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 (p_is_compute) THEN
+
+ 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) THEN
+ vec_recv = 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 (p_is_compute) THEN
+ 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 (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 (p_is_compute) THEN
+ 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 (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
+ vec_out(iset) = vec_out(iset) / sumarea
+ 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 COLM_PARALLEL
+ 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..54d355350e
--- /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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ 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 (p_is_active) 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_ElmVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90
new file mode 100644
index 0000000000..4f14eaf2af
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_ElmVector.F90
@@ -0,0 +1,188 @@
+#include
+
+#if (defined UNSTRUCTURED || defined CATCHMENT)
+MODULE MOD_ElmVector
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Address of Data associated with land element.
+!
+! To output a vector, Data is gathered from compute ranks directly to
+! root rank. "elm_data_address" stores information on how to reorganize data
+! gathered. The output data in vector is sorted by global element index.
+!
+! Created by Shupeng Zhang, May 2023
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ integer :: totalnumelm
+ type(pointer_int32_1d), allocatable :: elm_data_address (:)
+
+ integer*8, allocatable :: eindex_glb (:)
+
+CONTAINS
+
+ ! --------
+ SUBROUTINE elm_vector_init
+
+ USE MOD_SPMD_Task
+ USE MOD_Utils
+ USE MOD_Pixelset
+ USE MOD_Utils
+ USE MOD_UserDefFun
+ USE MOD_Mesh
+ USE MOD_LandElm
+ USE MOD_LandPatch
+#ifdef CROP
+ USE MOD_LandCrop
+#endif
+ IMPLICIT NONE
+
+ ! Local Variables
+ integer :: mesg(2), iwork, isrc, ndata
+ integer, allocatable :: numelm_rank (:)
+
+ integer :: i, idsp
+ integer, allocatable :: vec_rank_dsp (:)
+
+ integer*8, allocatable :: indexelm (:)
+ integer, allocatable :: order (:)
+
+ IF (p_is_compute) THEN
+ CALL elm_patch%build (landelm, landpatch, use_frac = .true.)
+ ENDIF
+
+ IF (p_is_compute) THEN
+#ifdef USEMPI
+ IF (numelm > 0) THEN
+ allocate (indexelm (numelm))
+ indexelm = landelm%eindex
+ ENDIF
+
+ IF (p_iam_compute == p_root) allocate (numelm_rank (0:p_np_compute-1))
+ CALL mpi_gather (numelm, 1, MPI_INTEGER, &
+ numelm_rank, 1, MPI_INTEGER, p_root, p_comm_compute, p_err)
+
+ IF (p_iam_compute == p_root) THEN
+#ifndef MPAS_EMBEDDED_COLM
+ CALL mpi_send (numelm_rank, p_np_compute, MPI_INTEGER, &
+ p_address_root, mpi_tag_size, p_comm_glb, p_err)
+#endif
+ ENDIF
+
+ mesg = (/p_iam_glb, numelm/)
+#ifdef MPAS_EMBEDDED_COLM
+ IF (.not. (p_is_root .and. p_iam_compute == p_root)) THEN
+#endif
+ CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ IF (numelm > 0) THEN
+ CALL mpi_send (indexelm, numelm, MPI_INTEGER8, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+#ifdef MPAS_EMBEDDED_COLM
+ ENDIF
+#endif
+#else
+ IF (numelm > 0) THEN
+ allocate (eindex_glb (numelm))
+ eindex_glb = landelm%eindex
+ ENDIF
+#endif
+ ENDIF
+
+ IF (p_is_root) THEN
+#ifdef USEMPI
+#ifndef MPAS_EMBEDDED_COLM
+ allocate (numelm_rank (0:p_np_compute-1))
+ CALL mpi_recv (numelm_rank, p_np_compute, MPI_INTEGER, p_address_compute(p_root), &
+ mpi_tag_size, p_comm_glb, p_stat, p_err)
+#endif
+
+ allocate (vec_rank_dsp (0:p_np_compute-1))
+ vec_rank_dsp(0) = 0
+ DO iwork = 1, p_np_compute-1
+ vec_rank_dsp(iwork) = vec_rank_dsp(iwork-1) + numelm_rank(iwork-1)
+ ENDDO
+
+ totalnumelm = sum(numelm_rank)
+
+ allocate (eindex_glb (totalnumelm))
+
+ allocate (elm_data_address(0:p_np_compute-1))
+ DO iwork = 0, p_np_compute-1
+ IF (numelm_rank(iwork) > 0) THEN
+ allocate (elm_data_address(iwork)%val (numelm_rank(iwork)))
+ ENDIF
+ ENDDO
+
+ DO iwork = 0, p_np_compute-1
+#ifdef MPAS_EMBEDDED_COLM
+ IF (iwork == p_root) THEN
+ ndata = numelm_rank(iwork)
+ IF (ndata > 0) THEN
+ idsp = vec_rank_dsp(iwork)
+ eindex_glb(idsp+1:idsp+ndata) = indexelm(1:ndata)
+ ENDIF
+ CYCLE
+ ENDIF
+#endif
+ CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = mesg(1)
+ ndata = mesg(2)
+ IF (ndata > 0) THEN
+ idsp = vec_rank_dsp(p_itis_compute(isrc))
+ CALL mpi_recv (eindex_glb(idsp+1:idsp+ndata), ndata, MPI_INTEGER8, isrc, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+ ENDDO
+#else
+ totalnumelm = numelm
+ allocate (elm_data_address(0:0))
+ allocate (elm_data_address(0)%val (totalnumelm))
+#endif
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_bcast (totalnumelm, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+#endif
+
+ IF (p_is_root) THEN
+ allocate (order (totalnumelm))
+ order = (/(i, i=1,totalnumelm)/)
+
+ CALL quicksort (totalnumelm, eindex_glb, order)
+
+#ifdef USEMPI
+ DO i = 1, totalnumelm
+ iwork = findloc_ud(order(i) > vec_rank_dsp, back=.true.) - 1
+ elm_data_address(iwork)%val(order(i)-vec_rank_dsp(iwork)) = i
+ ENDDO
+#else
+ elm_data_address(0)%val (order) = (/(i, i=1,totalnumelm)/)
+#endif
+ ENDIF
+
+ IF (allocated(numelm_rank)) deallocate(numelm_rank)
+ IF (allocated(vec_rank_dsp)) deallocate(vec_rank_dsp)
+ IF (allocated(indexelm)) deallocate(indexelm)
+ IF (allocated(order)) deallocate(order)
+
+ END SUBROUTINE elm_vector_init
+
+ ! ----------
+ SUBROUTINE elm_vector_final ()
+
+ IMPLICIT NONE
+
+ IF (allocated(elm_data_address)) deallocate (elm_data_address)
+ IF (allocated(eindex_glb)) deallocate (eindex_glb)
+
+ END SUBROUTINE elm_vector_final
+
+END MODULE MOD_ElmVector
+#endif
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..1b61638bfb
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Grid.F90
@@ -0,0 +1,1004 @@
+#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
+
+
+ ! -- PUBLIC SUBROUTINEs --
+ PUBLIC :: get_region_by_this_IO
+
+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
+
+ !-----------------------------------------------------
+ SUBROUTINE grid_define_by_copy (this, grid_in)
+
+ USE MOD_NetCDFSerial
+ IMPLICIT NONE
+ class (grid_type) :: this
+
+ type(grid_type) :: 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%pio(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
+
+ ! -------
+ SUBROUTINE get_region_by_this_IO ( grid, &
+ west, east, north, south, iwest, ieast, isouth, inorth)
+
+ USE MOD_SPMD_Task
+ USE MOD_Block
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ type(grid_type), intent(in) :: grid
+
+ real(r8), intent(out) :: west, east, north, south
+ integer, intent(out) :: iwest, ieast, inorth, isouth
+
+ ! Local Variables
+ integer :: iblk, jblk
+
+ IF (p_is_active) THEN
+
+ IF (gblock%nblkme /= 1) THEN
+ write(*,*) 'Warning: more than one block is on IO processor: ', p_iam_glb
+ west = spval; iwest = -1
+ east = spval; ieast = -1
+ north = spval; inorth = -1
+ south = spval; isouth = -1
+ RETURN
+ ENDIF
+
+ iblk = gblock%xblkme(1)
+ jblk = gblock%yblkme(1)
+
+ iwest = grid%xdsp(iblk) + 1
+ ieast = grid%xdsp(iblk) + grid%xcnt(iblk)
+
+ IF (grid%yinc == 1) THEN
+ inorth = grid%ydsp(jblk) + grid%ycnt(jblk)
+ isouth = grid%ydsp(jblk) + 1
+ ELSE
+ inorth = grid%ydsp(jblk) + 1
+ isouth = grid%ydsp(jblk) + grid%ycnt(jblk)
+ ENDIF
+
+ west = grid%lon_w(iwest )
+ east = grid%lon_e(ieast )
+ north = grid%lat_n(inorth)
+ south = grid%lat_s(isouth)
+
+ ENDIF
+
+ END SUBROUTINE get_region_by_this_IO
+
+END MODULE MOD_Grid
diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90
new file mode 100644
index 0000000000..8115d9cab3
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_HRUVector.F90
@@ -0,0 +1,215 @@
+#include
+
+#if (defined CATCHMENT)
+MODULE MOD_HRUVector
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Address of Data associated with HRU.
+!
+! To output a vector, Data is gathered from compute ranks directly to
+! root rank. "hru_data_address" stores information on how to reorganize data
+! gathered. The output data in vector is sorted by global element index
+! (i.e. catchment index)
+!
+! Created by Shupeng Zhang, May 2023
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ integer :: totalnumhru
+ type(pointer_int32_1d), allocatable :: hru_data_address (:)
+
+ integer*8, allocatable :: eindx_hru (:)
+ integer, allocatable :: htype_hru (:)
+
+CONTAINS
+
+ ! --------
+ SUBROUTINE hru_vector_init
+
+ USE MOD_SPMD_Task
+ USE MOD_Utils
+ USE MOD_Mesh
+ USE MOD_LandElm
+ USE MOD_LandHRU
+ USE MOD_LandPatch
+ USE MOD_ElmVector
+#ifdef CROP
+ USE MOD_LandCrop
+#endif
+ IMPLICIT NONE
+
+ ! Local Variables
+ integer :: mesg(2), iwork, isrc, ndata
+
+ integer, allocatable :: nhru_bsn (:)
+ integer, allocatable :: nhru_bsn_glb (:)
+ integer, allocatable :: rbuff (:)
+
+ integer, allocatable :: hru_dsp_glb (:)
+ integer :: ielm, i, ielm_glb
+
+ integer :: nhru, nelm, hru_dsp_loc
+
+ IF (p_is_compute) THEN
+
+ CALL elm_hru%build (landelm, landhru, use_frac = .true.)
+
+ CALL hru_patch%build (landhru, landpatch, use_frac = .true.)
+
+ IF (numelm > 0) THEN
+ allocate (nhru_bsn (numelm))
+ nhru_bsn = elm_hru%subend - elm_hru%substt + 1
+ ENDIF
+
+#ifdef USEMPI
+ mesg = (/p_iam_glb, numelm/)
+ CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ IF (numelm > 0) THEN
+ CALL mpi_send (nhru_bsn, numelm, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+#endif
+ ENDIF
+
+ IF (p_is_root) THEN
+
+ allocate (hru_data_address (0:p_np_compute-1))
+
+ allocate (nhru_bsn_glb (totalnumelm))
+
+#ifdef USEMPI
+ DO iwork = 0, p_np_compute-1
+ CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = mesg(1)
+ ndata = mesg(2)
+ IF (ndata > 0) THEN
+ allocate (rbuff (ndata))
+
+ CALL mpi_recv (rbuff, ndata, MPI_INTEGER, isrc, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+
+ nhru_bsn_glb(elm_data_address(p_itis_compute(isrc))%val) = rbuff
+
+ IF (sum(rbuff) > 0) THEN
+ allocate(hru_data_address(p_itis_compute(isrc))%val (sum(rbuff)))
+ ENDIF
+
+ deallocate(rbuff)
+ ENDIF
+ ENDDO
+#else
+ nhru_bsn_glb(elm_data_address(0)%val) = nhru_bsn
+ IF (sum(nhru_bsn) > 0) THEN
+ allocate(hru_data_address(0)%val (sum(nhru_bsn)))
+ ENDIF
+#endif
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_root) THEN
+
+ totalnumhru = sum(nhru_bsn_glb)
+
+ allocate (hru_dsp_glb (totalnumelm))
+ hru_dsp_glb(1) = 0
+ DO ielm = 2, totalnumelm
+ hru_dsp_glb(ielm) = hru_dsp_glb(ielm-1) + nhru_bsn_glb(ielm-1)
+ ENDDO
+
+ DO iwork = 0, p_np_compute-1
+ IF (allocated(elm_data_address(iwork)%val)) THEN
+ nelm = size(elm_data_address(iwork)%val)
+ hru_dsp_loc = 0
+ DO ielm = 1, nelm
+ ielm_glb = elm_data_address(iwork)%val(ielm)
+ nhru = nhru_bsn_glb(ielm_glb)
+ IF (nhru > 0) THEN
+ hru_data_address(iwork)%val (hru_dsp_loc+1:hru_dsp_loc+nhru) = &
+ (/ (i, i = hru_dsp_glb(ielm_glb)+1, hru_dsp_glb(ielm_glb)+nhru) /)
+ hru_dsp_loc = hru_dsp_loc + nhru
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+#endif
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ mesg = (/p_iam_glb, numhru/)
+ CALL mpi_send (mesg, 2, MPI_INTEGER, p_address_root, mpi_tag_mesg, p_comm_glb, p_err)
+ IF (numhru > 0) THEN
+ CALL mpi_send (landhru%settyp, numhru, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDIF
+#endif
+
+ IF (p_is_root) THEN
+
+ allocate (eindx_hru (totalnumhru))
+
+ DO ielm = 1, totalnumelm
+ eindx_hru(hru_dsp_glb(ielm)+1:hru_dsp_glb(ielm)+nhru_bsn_glb(ielm)) = &
+ eindex_glb(ielm)
+ ENDDO
+
+ allocate (htype_hru (totalnumhru))
+
+#ifdef USEMPI
+ DO iwork = 0, p_np_compute-1
+ CALL mpi_recv (mesg, 2, MPI_INTEGER, MPI_ANY_SOURCE, &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = mesg(1)
+ ndata = mesg(2)
+ IF (ndata > 0) THEN
+ allocate (rbuff (ndata))
+
+ CALL mpi_recv (rbuff, ndata, MPI_INTEGER, isrc, &
+ mpi_tag_data, p_comm_glb, p_stat, p_err)
+ htype_hru(hru_data_address(p_itis_compute(isrc))%val) = rbuff
+
+ deallocate(rbuff)
+ ENDIF
+ ENDDO
+#else
+ htype_hru(hru_data_address(0)%val) = landhru%settyp
+#endif
+
+ ! To distinguish between lake HRUs and hillslopes, the program sets the
+ ! type of lake HRUs as a negative number.
+ ! Set it as a positive number for output.
+ htype_hru = abs(htype_hru)
+
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_bcast (totalnumhru, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+#endif
+
+ END SUBROUTINE hru_vector_init
+
+ ! ----------
+ SUBROUTINE hru_vector_final ()
+
+ IMPLICIT NONE
+
+ IF (allocated(hru_data_address)) deallocate (hru_data_address)
+ IF (allocated(eindx_hru)) deallocate (eindx_hru)
+ IF (allocated(htype_hru)) deallocate (htype_hru)
+
+ END SUBROUTINE hru_vector_final
+
+END MODULE MOD_HRUVector
+#endif
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_Land2mWMO.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Land2mWMO.F90
new file mode 100644
index 0000000000..e646025a2b
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Land2mWMO.F90
@@ -0,0 +1,249 @@
+#include
+
+MODULE MOD_Land2mWMO
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+! Build a virtual patch "land2mWMO" for output 2 m WMO temperature.
+!
+! Created by Wenzong Dong and Hua Yuan, 2025/08
+!
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Grid
+ USE MOD_Pixelset
+ USE MOD_LandPatch
+ USE MOD_LandElm
+ USE MOD_Vars_Global
+ USE MOD_Const_LC
+ IMPLICIT NONE
+
+ ! ---- Instance ----
+ integer, allocatable :: wmo_patch (:) !2m wmo patch index
+ integer, allocatable :: wmo_source (:) !source patch of a wmo patch
+
+CONTAINS
+
+ ! -------------------------------
+ SUBROUTINE land2mwmo_build (lc_year)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Utils
+ USE MOD_UserDefFun
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_Mesh
+ USE MOD_LandElm
+ USE MOD_Namelist
+ USE MOD_NetCDFBlock
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: lc_year
+ character(len=255) :: cyear
+
+ integer :: numpatch_
+ integer :: numset
+ integer :: iset
+ integer :: spatch, epatch, ipatch, jpatch
+ integer :: ipth, numpxl, numpth
+ integer :: src_pth, pthtype, maxpxl
+ integer*8, allocatable :: eindex_(:)
+ integer, allocatable :: settyp_(:), ipxstt_(:), ipxend_(:), ielm_(:)
+ integer, allocatable :: locpth(:)
+
+ integer :: npatch_glb
+ integer :: numwmo
+
+ write(cyear,'(i4.4)') lc_year
+ IF (p_is_root) THEN
+ write(*,'(A)') 'Making land 2 m wmo patches:'
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_compute) THEN
+
+ numset = numelm
+
+ numwmo = 0
+ numpatch_ = 0
+ jpatch = 0
+
+ ! Count for 2 m WMO patches need to be set virtually
+ DO iset = 1, numset
+
+ numpth = count(landpatch%eindex==landelm%eindex(iset))
+ IF (allocated(locpth)) deallocate(locpth)
+ allocate(locpth(numpth))
+ locpth = pack([(ipth, ipth=1, numpatch)], &
+ landpatch%eindex==landelm%eindex(iset))
+
+ spatch = minval(locpth) ! elm_patch%substt(iset)
+ epatch = maxval(locpth) ! elm_patch%subend(iset)
+
+ maxpxl = 0
+ src_pth = -1
+
+ DO ipatch = spatch, epatch
+
+ pthtype = patchtypes(landpatch%settyp(ipatch))
+ numpxl = landpatch%ipxend(ipatch) - landpatch%ipxstt(ipatch) + 1
+
+ IF (numpxl>maxpxl .and. pthtype==0) THEN
+ maxpxl = numpxl
+ src_pth = ipatch
+ ENDIF
+ ENDDO
+
+ ! a new 2m WMO patch
+ IF (src_pth /= -1) THEN
+ wmo_source (iset) = src_pth
+ numwmo = numwmo + 1
+ landelm%settyp(iset) = 1
+ ELSE
+ wmo_source (iset) = -1
+ ENDIF
+
+ ENDDO
+
+ ! allocate new temporal patches memory
+ IF (numpatch > 0) THEN
+ ! a numpatch with WMO patch number
+ numpatch_ = numpatch + numwmo
+
+ allocate (eindex_ (numpatch_ ))
+ allocate (ipxstt_ (numpatch_ ))
+ allocate (ipxend_ (numpatch_ ))
+ allocate (settyp_ (numpatch_ ))
+ allocate (ielm_ (numpatch_ ))
+
+ ENDIF
+
+ numwmo = 0
+
+ ! set for new 2 m WMO patch
+ DO iset = 1, numset
+ numpth = count(landpatch%eindex==landelm%eindex(iset))
+
+ IF (allocated(locpth)) deallocate(locpth)
+ allocate(locpth(numpth))
+
+ locpth = pack([(ipth, ipth=1, numpatch)], &
+ landpatch%eindex==landelm%eindex(iset))
+
+ spatch = minval(locpth) ! elm_patch%substt(iset)
+ epatch = maxval(locpth) ! elm_patch%subend(iset)
+
+ DO ipatch = spatch, epatch
+ jpatch = jpatch + 1
+ eindex_(jpatch) = landpatch%eindex(ipatch)
+ settyp_(jpatch) = landpatch%settyp(ipatch)
+ ipxstt_(jpatch) = landpatch%ipxstt(ipatch)
+ ipxend_(jpatch) = landpatch%ipxend(ipatch)
+ ielm_ (jpatch) = landpatch%ielm (ipatch)
+ ENDDO
+
+ IF (wmo_source(iset) > 0) THEN
+ jpatch = jpatch + 1
+ eindex_(jpatch) = landpatch%eindex(epatch)
+ settyp_(jpatch) = landpatch%settyp(wmo_source(iset))
+ ipxstt_(jpatch) = -1
+ ipxend_(jpatch) = -1
+ ielm_ (jpatch) = landpatch%ielm (epatch)
+
+ ! update the newly 2m WMO source/patch index
+ wmo_patch (iset) = jpatch
+ wmo_source(iset) = wmo_source(iset) + numwmo
+ numwmo = numwmo + 1
+ ENDIF
+ ENDDO
+
+ ! 2m WMO patch number check
+ IF (jpatch .ne. numpatch_) THEN
+ write(*,'(A)') 'Count land 2 m WMO patches error! See MOD_Land2mWMO.F90.'
+ ENDIF
+
+ ! set the new patch number
+ numpatch = numpatch_
+
+ ! allocate and save the new patches info
+ IF (numpatch > 0) THEN
+ ! update landpath with new patch number
+ IF (allocated (landpatch%eindex)) deallocate (landpatch%eindex)
+ IF (allocated (landpatch%ipxstt)) deallocate (landpatch%ipxstt)
+ IF (allocated (landpatch%ipxend)) deallocate (landpatch%ipxend)
+ IF (allocated (landpatch%settyp)) deallocate (landpatch%settyp)
+ IF (allocated (landpatch%ielm )) deallocate (landpatch%ielm )
+
+ allocate (landpatch%eindex (numpatch))
+ allocate (landpatch%ipxstt (numpatch))
+ allocate (landpatch%ipxend (numpatch))
+ allocate (landpatch%settyp (numpatch))
+ allocate (landpatch%ielm (numpatch))
+
+ ! update all information of landpatch
+ landpatch%eindex = eindex_(1:numpatch)
+ landpatch%ipxstt = ipxstt_(1:numpatch)
+ landpatch%ipxend = ipxend_(1:numpatch)
+ landpatch%settyp = settyp_(1:numpatch)
+ landpatch%ielm = ielm_ (1:numpatch)
+
+ ENDIF
+ ENDIF
+
+ landpatch%nset = numpatch
+
+ CALL landpatch%set_vecgs
+
+ IF (allocated (eindex_ )) deallocate (eindex_ )
+ IF (allocated (settyp_ )) deallocate (settyp_ )
+ IF (allocated (ipxstt_ )) deallocate (ipxstt_ )
+ IF (allocated (ipxend_ )) deallocate (ipxend_ )
+ IF (allocated (ielm_ )) deallocate (ielm_ )
+ IF (allocated (locpth )) deallocate (locpth )
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err)
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.'
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.'
+#endif
+
+ CALL elm_patch%build (landelm, landpatch, use_frac = .true.)
+
+ CALL write_patchfrac (DEF_dir_landdata, lc_year)
+
+ END SUBROUTINE land2mwmo_build
+
+ SUBROUTINE land2mwmo_init
+ USE MOD_Mesh
+ IMPLICIT NONE
+
+ allocate (wmo_patch (numelm))
+ allocate (wmo_source (numelm))
+
+ wmo_patch = -1
+ wmo_source = -1
+
+ END SUBROUTINE land2mwmo_init
+
+ SUBROUTINE land2mwmo_final
+ IMPLICIT NONE
+
+ IF (allocated (wmo_patch )) deallocate (wmo_patch )
+ IF (allocated (wmo_source)) deallocate (wmo_source)
+
+ END SUBROUTINE land2mwmo_final
+
+END MODULE MOD_Land2mWMO
diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandCrop.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandCrop.F90
new file mode 100644
index 0000000000..85ed62521c
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandCrop.F90
@@ -0,0 +1,152 @@
+#include
+
+#ifdef CROP
+MODULE MOD_LandCrop
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Build crop patches.
+!
+! Created by Shupeng Zhang, Sep 2023
+! porting codes from Hua Yuan's OpenMP version to MPI parallel version.
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Grid
+ IMPLICIT NONE
+
+ ! ---- Instance ----
+ type(grid_type) :: grid_crop
+ integer, allocatable :: cropclass (:)
+ real(r8), allocatable :: cropfrac (:)
+
+CONTAINS
+
+ ! -------------------------------
+ SUBROUTINE landcrop_build (lc_year)
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ USE MOD_Block
+ USE MOD_DataType
+ USE MOD_LandElm
+#ifdef CATCHMENT
+ USE MOD_LandHRU
+#endif
+ USE MOD_LandPatch
+ USE MOD_NetCDFBlock
+ USE MOD_PixelsetShared
+ USE MOD_5x5DataReadin
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: lc_year
+
+ ! Local Variables
+ character(len=255) :: cyear, file_patch, dir_5x5, suffix
+ integer :: npatch_glb
+ type(block_data_real8_2d) :: pctcrop_xy
+ type(block_data_real8_3d) :: pctshared_xy
+ type(block_data_real8_3d) :: cropdata
+ integer :: sharedfilter(1), cropfilter(1)
+ integer :: iblkme, ib, jb
+ real(r8), allocatable :: pctshared (:)
+ integer , allocatable :: classshared(:)
+
+ write(cyear,'(i4.4)') lc_year
+ IF (p_is_root) THEN
+ write(*,'(A)') 'Making patches (crop shared):'
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_active) THEN
+
+ dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s'
+ suffix = 'MOD'//trim(cyear)
+
+ CALL allocate_block_data (grid_patch, pctcrop_xy)
+ CALL read_5x5_data (dir_5x5, suffix, grid_patch, 'PCT_CROP', pctcrop_xy)
+
+ CALL allocate_block_data (grid_patch, pctshared_xy, 2)
+ DO iblkme = 1, gblock%nblkme
+ ib = gblock%xblkme(iblkme)
+ jb = gblock%yblkme(iblkme)
+ pctshared_xy%blk(ib,jb)%val(1,:,:) = 1. - pctcrop_xy%blk(ib,jb)%val/100.
+ pctshared_xy%blk(ib,jb)%val(2,:,:) = pctcrop_xy%blk(ib,jb)%val/100.
+ ENDDO
+ ENDIF
+
+ sharedfilter = (/ 1 /)
+
+ IF (landpatch%has_shared) then
+ CALL pixelsetshared_build (landpatch, grid_patch, pctshared_xy, 2, sharedfilter, &
+ pctshared, classshared, fracin = landpatch%pctshared)
+ ELSE
+ CALL pixelsetshared_build (landpatch, grid_patch, pctshared_xy, 2, sharedfilter, &
+ pctshared, classshared)
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (landpatch%nset > 0) THEN
+ WHERE (classshared == 2) landpatch%settyp = CROPLAND
+ ENDIF
+ ENDIF
+
+ IF (p_is_active) THEN
+ file_patch = trim(DEF_dir_rawdata) // '/global_CFT_surface_data.nc'
+ CALL allocate_block_data (grid_crop, cropdata, N_CFT)
+ CALL ncio_read_block (file_patch, 'PCT_CFT', grid_crop, N_CFT, cropdata)
+ ENDIF
+
+ cropfilter = (/ CROPLAND /)
+
+ CALL pixelsetshared_build (landpatch, grid_crop, cropdata, N_CFT, cropfilter, &
+ cropfrac, cropclass, fracin = pctshared)
+
+ numpatch = landpatch%nset
+
+ landpatch%has_shared = .true.
+ IF (p_is_compute) THEN
+ IF (numpatch > 0) THEN
+ IF (allocated(landpatch%pctshared)) THEN
+ deallocate(landpatch%pctshared)
+ ENDIF
+
+ allocate(landpatch%pctshared(numpatch))
+ landpatch%pctshared = cropfrac
+ ENDIF
+ ENDIF
+
+ IF (allocated(pctshared )) deallocate(pctshared )
+ IF (allocated(classshared)) deallocate(classshared)
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err)
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches (with crop).'
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.'
+#endif
+
+IF ( .not. DEF_Output_2mWMO ) THEN
+ CALL elm_patch%build (landelm, landpatch, use_frac = .true.)
+#ifdef CATCHMENT
+ CALL hru_patch%build (landhru, landpatch, use_frac = .true.)
+#endif
+
+ CALL write_patchfrac (DEF_dir_landdata, lc_year)
+ENDIF
+
+ END SUBROUTINE landcrop_build
+
+END MODULE MOD_LandCrop
+#endif
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..69d75a4878
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandElm.F90
@@ -0,0 +1,84 @@
+#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_SPMD_Task
+ USE MOD_Mesh
+ IMPLICIT NONE
+
+ ! Local Variables
+ integer :: ielm, nelm_glb
+
+ IF (p_is_root) THEN
+ write(*,'(A)') 'Making land elements:'
+ ENDIF
+
+ IF (p_is_compute) 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 USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+ IF (p_is_compute) THEN
+ CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err)
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,I12,A)') 'Total: ', nelm_glb, ' elements.'
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#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_LandHRU.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90
new file mode 100644
index 0000000000..7e490ebf47
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandHRU.F90
@@ -0,0 +1,252 @@
+#include
+
+#ifdef CATCHMENT
+
+MODULE MOD_LandHRU
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Build pixelset "landhru".
+!
+! 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.
+!
+! "landhru" refers to pixelset HRU.
+!
+! Created by Shupeng Zhang, May 2023
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision
+ USE MOD_Pixelset
+ USE MOD_Grid
+ IMPLICIT NONE
+
+ ! ---- Instance ----
+ integer :: numhru
+ type(grid_type) :: grid_hru
+ type(pixelset_type) :: landhru
+
+ type(subset_type) :: elm_hru
+
+CONTAINS
+
+ ! -------------------------------
+ SUBROUTINE landhru_build ()
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_NetcdfSerial
+ USE MOD_Utils
+ USE MOD_Block
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_Mesh
+ USE MOD_LandElm
+ USE MOD_CatchmentDataReadin
+ USE MOD_Namelist
+ USE MOD_AggregationRequestData
+
+ IMPLICIT NONE
+
+ ! Local Variables
+ type (block_data_int32_2d) :: hrudata
+ integer :: iwork, ncat, nhru, ie, typsgn, npxl, ipxl
+ integer*8, allocatable :: catnum(:)
+ integer, allocatable :: numhru_all_g(:), lakeid(:)
+ integer, allocatable :: types(:), order(:), ibuff(:)
+ integer :: nhru_glb
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_root) THEN
+ write(*,'(A)') 'Making land hydro units:'
+ ENDIF
+
+ IF (p_is_root) THEN
+ CALL ncio_read_serial (DEF_CatchmentMesh_data, 'basin_numhru', numhru_all_g)
+ CALL ncio_read_serial (DEF_CatchmentMesh_data, 'lake_id', lakeid)
+ ENDIF
+
+#ifdef USEMPI
+#ifdef MPAS_EMBEDDED_COLM
+ IF (p_is_root) THEN
+ ncat = size(numhru_all_g)
+ ELSE
+ ncat = 0
+ ENDIF
+ CALL mpi_bcast (ncat, 1, MPI_INTEGER, p_root, p_comm_glb, p_err)
+ IF (.not. p_is_root) THEN
+ allocate (numhru_all_g(ncat))
+ allocate (lakeid(ncat))
+ ENDIF
+ CALL mpi_bcast (numhru_all_g, ncat, MPI_INTEGER, p_root, p_comm_glb, p_err)
+ CALL mpi_bcast (lakeid, ncat, MPI_INTEGER, p_root, p_comm_glb, p_err)
+
+ IF (p_is_compute) THEN
+ IF (numelm > 0) THEN
+ allocate (catnum(numelm))
+ allocate (ibuff(numelm))
+ catnum = landelm%eindex
+ numhru = sum(numhru_all_g(catnum))
+ ibuff = lakeid(catnum)
+ deallocate (lakeid)
+ allocate (lakeid(numelm))
+ lakeid = ibuff
+ deallocate (catnum)
+ deallocate (ibuff)
+ ELSE
+ numhru = 0
+ ENDIF
+ ENDIF
+#else
+ IF (p_is_root) THEN
+ DO iwork = 0, p_np_compute-1
+
+ CALL mpi_recv (ncat, 1, MPI_INTEGER, p_address_compute(iwork), mpi_tag_size, &
+ p_comm_glb, p_stat, p_err)
+
+ IF (ncat > 0) THEN
+ allocate (catnum(ncat))
+ allocate (ibuff (ncat))
+
+ CALL mpi_recv (catnum, ncat, MPI_INTEGER8, p_address_compute(iwork), mpi_tag_data, &
+ p_comm_glb, p_stat, p_err)
+
+ nhru = sum(numhru_all_g(catnum))
+ CALL mpi_send (nhru, 1, MPI_INTEGER, &
+ p_address_compute(iwork), mpi_tag_size, p_comm_glb, p_err)
+
+ ibuff = lakeid(catnum)
+ CALL mpi_send (ibuff, ncat, MPI_INTEGER, &
+ p_address_compute(iwork), mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate(catnum)
+ deallocate(ibuff )
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (p_is_compute) THEN
+ CALL mpi_send (numelm, 1, MPI_INTEGER, p_address_root, mpi_tag_size, p_comm_glb, p_err)
+ IF (numelm > 0) THEN
+ allocate (lakeid (numelm))
+ CALL mpi_send (landelm%eindex, numelm, MPI_INTEGER8, p_address_root, mpi_tag_data, p_comm_glb, p_err)
+ CALL mpi_recv (numhru, 1, MPI_INTEGER, p_address_root, mpi_tag_size, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (lakeid, numelm, MPI_INTEGER, p_address_root, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ELSE
+ numhru = 0
+ ENDIF
+ ENDIF
+#endif
+#else
+ numhru = sum(numhru_all_g)
+#endif
+
+ IF (allocated(numhru_all_g)) deallocate(numhru_all_g)
+
+ IF (p_is_active) CALL allocate_block_data (grid_hru, hrudata)
+ CALL catchment_data_read (DEF_CatchmentMesh_data, 'ihydrounit2d', grid_hru, hrudata)
+
+#ifdef USEMPI
+ IF (p_is_active) THEN
+ CALL aggregation_data_daemon (grid_hru, data_i4_2d_in1 = hrudata)
+ ENDIF
+#endif
+
+ IF (p_is_compute) THEN
+
+ IF (numhru > 0) THEN
+ allocate (landhru%eindex (numhru))
+ allocate (landhru%settyp (numhru))
+ allocate (landhru%ipxstt (numhru))
+ allocate (landhru%ipxend (numhru))
+ allocate (landhru%ielm (numhru))
+ ENDIF
+
+ numhru = 0
+
+ DO ie = 1, numelm
+
+ IF (lakeid(ie) > 0) THEN
+ typsgn = -1
+ ELSE
+ typsgn = 1
+ ENDIF
+
+ npxl = mesh(ie)%npxl
+
+ allocate (types (1:npxl))
+
+ CALL aggregation_request_data (landelm, ie, grid_hru, zip = .false., &
+ data_i4_2d_in1 = hrudata, data_i4_2d_out1 = ibuff)
+
+ types = ibuff
+
+ allocate (order (1:npxl))
+ order = (/ (ipxl, ipxl = 1, npxl) /)
+
+ CALL quicksort (npxl, types, order)
+
+ mesh(ie)%ilon(1:npxl) = mesh(ie)%ilon(order)
+ mesh(ie)%ilat(1:npxl) = mesh(ie)%ilat(order)
+
+ DO ipxl = 1, npxl
+ IF (ipxl == 1) THEN
+ numhru = numhru + 1
+ landhru%eindex (numhru) = mesh(ie)%indx
+ landhru%settyp (numhru) = types(ipxl) * typsgn
+ landhru%ipxstt (numhru) = ipxl
+ landhru%ielm (numhru) = ie
+ ELSEIF (types(ipxl) /= types(ipxl-1)) THEN
+ landhru%ipxend(numhru) = ipxl - 1
+
+ numhru = numhru + 1
+ landhru%eindex (numhru) = mesh(ie)%indx
+ landhru%settyp (numhru) = types(ipxl) * typsgn
+ landhru%ipxstt (numhru) = ipxl
+ landhru%ielm (numhru) = ie
+ ENDIF
+ ENDDO
+ landhru%ipxend(numhru) = npxl
+
+ deallocate (ibuff)
+ deallocate (types)
+ deallocate (order)
+
+ ENDDO
+
+#ifdef USEMPI
+ CALL aggregation_compute_done ()
+#endif
+ ENDIF
+
+ landhru%nset = numhru
+ CALL landhru%set_vecgs
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ CALL mpi_reduce (numhru, nhru_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err)
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,I12,A)') 'Total: ', nhru_glb, ' hydro units.'
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ write(*,'(A,I12,A)') 'Total: ', numhru, ' hydro units.'
+#endif
+
+ IF (allocated(lakeid)) deallocate(lakeid)
+
+ END SUBROUTINE landhru_build
+
+END MODULE MOD_LandHRU
+#endif
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..4c8d17e875
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPFT.F90
@@ -0,0 +1,325 @@
+#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
+
+ ! ---- PUBLIC routines ----
+ PUBLIC :: landpft_build
+
+CONTAINS
+
+ ! -------------------------------
+ SUBROUTINE landpft_build (lc_year)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_Namelist
+ USE MOD_5x5DataReadin
+ USE MOD_LandPatch
+ USE MOD_Land2mWMO
+ USE MOD_AggregationRequestData
+ USE MOD_Const_LC
+#ifdef CROP
+ USE MOD_LandCrop
+#endif
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: lc_year
+ ! Local Variables
+ character(len=256) :: dir_5x5, suffix, cyear
+ type (block_data_real8_3d) :: pctpft
+ real(r8), allocatable :: pctpft_patch(:,:), pctpft_one(:,:)
+ real(r8), allocatable :: area_one (:)
+ logical, allocatable :: patchmask (:)
+ integer :: ipatch, ipft, npatch, npft, npft_glb
+ integer :: wmo_src, ipft_grass
+ real(r8) :: sumarea, maxgrass
+
+ IF (p_is_root) THEN
+ write(*,'(A)') 'Making land plant function type tiles:'
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ landpft%has_shared = .true.
+
+ IF (p_is_active) THEN
+
+ CALL allocate_block_data (grid_patch, pctpft, N_PFT_modis, lb1 = 0)
+ CALL flush_block_data (pctpft, 1.0)
+
+ dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s'
+ ! add parameter input for time year
+ write(cyear,'(i4.4)') lc_year
+ suffix = 'MOD'//trim(cyear)
+ CALL read_5x5_data_pft (dir_5x5, suffix, grid_patch, 'PCT_PFT', pctpft)
+
+#ifdef USEMPI
+ CALL aggregation_data_daemon (grid_patch, data_r8_3d_in1 = pctpft, n1_r8_3d_in1 = N_PFT_modis)
+#endif
+ ENDIF
+
+
+ IF (p_is_compute) THEN
+
+ IF (numpatch > 0) THEN
+ allocate (pctpft_patch (0:N_PFT-1,numpatch))
+ allocate (patchmask (numpatch))
+
+ pctpft_patch(:,:) = 0
+ patchmask (:) = .true.
+ ENDIF
+
+ DO ipatch = 1, numpatch
+
+ IF (ipatch == wmo_patch(landpatch%ielm(ipatch))) THEN
+
+ wmo_src = wmo_source(landpatch%ielm(ipatch))
+ maxgrass = maxval(pctpft_patch(12:14,wmo_src))
+
+ IF (maxgrass > 0) THEN
+ ipft_grass = maxloc(pctpft_patch(12:14,wmo_src), dim=1) + 11
+ pctpft_patch(:,ipatch) = 0
+ pctpft_patch(ipft_grass,ipatch) = 1.
+ ELSE
+ pctpft_patch(0,ipatch) = 1.
+ ENDIF
+
+ CYCLE
+ ENDIF
+#ifndef CROP
+ IF (patchtypes(landpatch%settyp(ipatch)) == 0) THEN
+#else
+ IF (patchtypes(landpatch%settyp(ipatch)) == 0 .and. landpatch%settyp(ipatch)/=CROPLAND) THEN
+#endif
+ CALL aggregation_request_data (landpatch, ipatch, grid_patch, zip = .false., area = area_one, &
+ data_r8_3d_in1 = pctpft, data_r8_3d_out1 = pctpft_one, n1_r8_3d_in1 = N_PFT_modis, lb1_r8_3d_in1 = 0)
+
+ sumarea = sum(area_one * sum(pctpft_one(0:N_PFT-1,:),dim=1))
+
+ ! In case of no PFT data, set patchtype=0 to 100% bare.
+ IF (sumarea <= 0.0) THEN
+ pctpft_patch(0,ipatch) = 1.
+ ELSE
+ DO ipft = 0, N_PFT-1
+ pctpft_patch(ipft,ipatch) = sum(pctpft_one(ipft,:) * area_one) / sumarea
+ ENDDO
+ ENDIF
+
+ ENDIF
+ ENDDO
+
+#ifdef USEMPI
+ CALL aggregation_compute_done ()
+#endif
+
+ IF (numpatch > 0) THEN
+ npatch = count(patchmask)
+ numpft = count(pctpft_patch > 0.)
+#ifdef CROP
+ numpft = numpft + count(landpatch%settyp == CROPLAND)
+#endif
+ IF (npatch > 0) THEN
+ allocate (patch_pft_s (npatch))
+ allocate (patch_pft_e (npatch))
+ ENDIF
+ ELSE
+ numpft = 0
+ ENDIF
+
+ IF (numpft > 0) THEN
+
+ allocate (pft2patch (numpft))
+
+ allocate (landpft%eindex (numpft))
+ allocate (landpft%settyp (numpft))
+ allocate (landpft%ipxstt (numpft))
+ allocate (landpft%ipxend (numpft))
+ allocate (landpft%ielm (numpft))
+
+ allocate (landpft%pctshared (numpft))
+ landpft%pctshared(:) = 1.
+
+ npft = 0
+ npatch = 0
+ DO ipatch = 1, numpatch
+ IF (patchmask(ipatch)) THEN
+ npatch = npatch + 1
+
+#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(npatch) = npft + 1
+ patch_pft_e(npatch) = npft + count(pctpft_patch(:,ipatch) > 0)
+
+ DO ipft = 0, N_PFT-1
+ IF (pctpft_patch(ipft,ipatch) > 0) THEN
+ npft = npft + 1
+
+ landpft%ielm (npft) = landpatch%ielm (ipatch)
+ landpft%eindex(npft) = landpatch%eindex(ipatch)
+ landpft%ipxstt(npft) = landpatch%ipxstt(ipatch)
+ landpft%ipxend(npft) = landpatch%ipxend(ipatch)
+ landpft%settyp(npft) = ipft
+
+ landpft%pctshared(npft) = pctpft_patch(ipft,ipatch)
+
+ pft2patch(npft) = npatch
+ ENDIF
+ ENDDO
+#ifdef CROP
+ ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN
+ npft = npft + 1
+ patch_pft_s(npatch) = npft
+ patch_pft_e(npatch) = npft
+
+ landpft%ielm (npft) = landpatch%ielm (ipatch)
+ landpft%eindex(npft) = landpatch%eindex(ipatch)
+ landpft%ipxstt(npft) = landpatch%ipxstt(ipatch)
+ landpft%ipxend(npft) = landpatch%ipxend(ipatch)
+ landpft%settyp(npft) = cropclass(ipatch) + N_PFT - 1
+
+ landpft%pctshared(npft) = landpatch%pctshared(ipatch)
+
+ pft2patch(npft) = npatch
+#endif
+ ELSE
+ patch_pft_s(npatch) = -1
+ patch_pft_e(npatch) = -1
+ ENDIF
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ ENDIF
+
+ CALL landpatch%pset_pack(patchmask, numpatch)
+
+ landpft%nset = numpft
+ CALL landpft%set_vecgs
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ CALL mpi_reduce (numpft, npft_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err)
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,I12,A)') 'Total: ', npft_glb, ' plant function type tiles.'
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ write(*,'(A,I12,A)') 'Total: ', numpft, ' plant function type tiles.'
+#endif
+
+ IF (allocated(pctpft_patch)) deallocate (pctpft_patch)
+ IF (allocated(pctpft_one )) deallocate (pctpft_one )
+ IF (allocated(area_one )) deallocate (area_one )
+ IF (allocated(patchmask )) deallocate (patchmask )
+
+ END SUBROUTINE landpft_build
+
+ ! ----------------------
+ SUBROUTINE map_patch_to_pft
+
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch
+ USE MOD_Const_LC
+ IMPLICIT NONE
+
+ integer :: ipatch, ipft
+
+ IF (p_is_compute) THEN
+
+ IF ((numpatch <= 0) .or. (numpft <= 0)) RETURN
+
+ IF (allocated(patch_pft_s)) deallocate(patch_pft_s)
+ IF (allocated(patch_pft_e)) deallocate(patch_pft_e)
+ IF (allocated(pft2patch )) deallocate(pft2patch )
+
+ allocate (patch_pft_s (numpatch))
+ allocate (patch_pft_e (numpatch))
+ allocate (pft2patch (numpft ))
+
+ 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
+#ifdef CROP
+ ELSEIF (landpatch%settyp(ipatch) == CROPLAND) THEN
+ 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
+
+ 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..04c76fe18b
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandPatch.F90
@@ -0,0 +1,319 @@
+#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
+
+
+CONTAINS
+
+ ! -------------------------------
+ SUBROUTINE landpatch_build (lc_year)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Utils
+ USE MOD_UserDefFun
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_Mesh
+ USE MOD_LandElm
+#ifdef CATCHMENT
+ USE MOD_LandHRU
+#endif
+ USE MOD_Namelist
+ USE MOD_NetCDFBlock
+ USE MOD_AggregationRequestData
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: lc_year
+ ! Local Variables
+ character(len=256) :: file_patch
+ character(len=255) :: cyear
+ type (block_data_int32_2d) :: patchdata
+ integer :: iloc, npxl, ipxl, numset
+ integer :: ie, iset, ipxstt, ipxend
+ integer, allocatable :: types(:), order(:), ibuff(:)
+ integer*8, allocatable :: eindex_tmp(:)
+ integer, allocatable :: settyp_tmp(:), ipxstt_tmp(:), ipxend_tmp(:), ielm_tmp(:)
+ logical, allocatable :: msk(:)
+ integer :: npatch_glb
+ integer :: dominant_type
+ integer, allocatable :: npxl_types (:)
+
+ write(cyear,'(i4.4)') lc_year
+ IF (p_is_root) THEN
+ write(*,'(A)') 'Making land patches:'
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_active) THEN
+
+ CALL allocate_block_data (grid_patch, patchdata)
+
+#ifndef LULC_USGS
+ ! add parameter input for time year
+ file_patch = trim(DEF_dir_rawdata)//'landtypes/landtype-igbp-modis-'//trim(cyear)//'.nc'
+#else
+ !TODO: need usgs land cover type data
+ file_patch = trim(DEF_dir_rawdata) //'/landtypes/landtype-usgs-update.nc'
+#endif
+ CALL ncio_read_block (file_patch, 'landtype', grid_patch, patchdata)
+
+#ifdef USEMPI
+ CALL aggregation_data_daemon (grid_patch, data_i4_2d_in1 = patchdata)
+#endif
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+#ifdef CATCHMENT
+ numset = numhru
+#else
+ numset = numelm
+#endif
+
+ IF (numset > 0) THEN
+ allocate (eindex_tmp (numset*N_land_classification))
+ allocate (settyp_tmp (numset*N_land_classification))
+ allocate (ipxstt_tmp (numset*N_land_classification))
+ allocate (ipxend_tmp (numset*N_land_classification))
+ allocate (ielm_tmp (numset*N_land_classification))
+ ENDIF
+
+ numpatch = 0
+
+ DO iset = 1, numset
+#ifdef CATCHMENT
+ ie = landhru%ielm (iset)
+ ipxstt = landhru%ipxstt(iset)
+ ipxend = landhru%ipxend(iset)
+#else
+ ie = landelm%ielm (iset)
+ ipxstt = landelm%ipxstt(iset)
+ ipxend = landelm%ipxend(iset)
+#endif
+
+ npxl = ipxend - ipxstt + 1
+
+ allocate (types (ipxstt:ipxend))
+
+#ifdef CATCHMENT
+ CALL aggregation_request_data (landhru, iset, grid_patch, zip = .false., &
+#else
+ CALL aggregation_request_data (landelm, iset, grid_patch, zip = .false., &
+#endif
+ data_i4_2d_in1 = patchdata, data_i4_2d_out1 = ibuff)
+
+
+ types(:) = ibuff
+ deallocate (ibuff)
+
+#ifdef CATCHMENT
+ IF (landhru%settyp(iset) <= 0) THEN
+ types(ipxstt:ipxend) = WATERBODY
+ ENDIF
+ WHERE (types == 0)
+ ! set land in MERITHydro while ocean in landtype data as water body
+ types = WATERBODY
+ END WHERE
+ WHERE (types == 11)
+ types = 10
+ END WHERE
+#endif
+
+ IF ((DEF_USE_PFT .and. (.not. DEF_SOLO_PFT)) .or. DEF_FAST_PC) THEN
+ ! For classification of plant function types or fast PC,
+ ! merge all land types with soil ground
+ DO ipxl = ipxstt, ipxend
+ IF (types(ipxl) > 0) THEN
+ IF (patchtypes(types(ipxl)) == 0) THEN
+ ! Deal with cropland separately for fast PC
+ IF (DEF_FAST_PC .and. &
+ (types(ipxl)==CROPLAND .or. types(ipxl)==14)) THEN
+ types(ipxl) = CROPLAND
+ ELSE
+ types(ipxl) = 1
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+
+ allocate (order (ipxstt:ipxend))
+ order = (/ (ipxl, ipxl = ipxstt, ipxend) /)
+
+ CALL quicksort (npxl, types, order)
+
+ mesh(ie)%ilon(ipxstt:ipxend) = mesh(ie)%ilon(order)
+ mesh(ie)%ilat(ipxstt:ipxend) = mesh(ie)%ilat(order)
+
+ IF (DEF_USE_DOMINANT_PATCHTYPE) THEN
+ allocate (npxl_types (0:maxval(types)))
+ npxl_types(:) = 0
+ DO ipxl = ipxstt, ipxend
+ npxl_types(types(ipxl)) = npxl_types(types(ipxl)) + 1
+ ENDDO
+
+ IF (any(types > 0)) THEN
+ iloc = findloc_ud(types > 0) + ipxstt - 1
+ dominant_type = maxloc(npxl_types(1:), dim=1)
+ types(iloc:ipxend) = dominant_type
+ ENDIF
+
+ deallocate(npxl_types)
+ ENDIF
+
+ DO ipxl = ipxstt, ipxend
+ IF (ipxl == ipxstt) THEN
+ numpatch = numpatch + 1
+ eindex_tmp(numpatch) = mesh(ie)%indx
+ settyp_tmp(numpatch) = types(ipxl)
+ ipxstt_tmp(numpatch) = ipxl
+ ielm_tmp (numpatch) = ie
+ ELSEIF (types(ipxl) /= types(ipxl-1)) THEN
+ ipxend_tmp(numpatch) = ipxl - 1
+
+ numpatch = numpatch + 1
+ eindex_tmp(numpatch) = mesh(ie)%indx
+ settyp_tmp(numpatch) = types(ipxl)
+ ipxstt_tmp(numpatch) = ipxl
+ ielm_tmp (numpatch) = ie
+ ENDIF
+ ENDDO
+ ipxend_tmp(numpatch) = ipxend
+
+ deallocate (types)
+ deallocate (order)
+
+ ENDDO
+
+ IF (numpatch > 0) THEN
+ allocate (landpatch%eindex (numpatch))
+ allocate (landpatch%settyp (numpatch))
+ allocate (landpatch%ipxstt (numpatch))
+ allocate (landpatch%ipxend (numpatch))
+ allocate (landpatch%ielm (numpatch))
+
+ landpatch%eindex = eindex_tmp(1:numpatch)
+ landpatch%ipxstt = ipxstt_tmp(1:numpatch)
+ landpatch%ipxend = ipxend_tmp(1:numpatch)
+ landpatch%settyp = settyp_tmp(1:numpatch)
+ landpatch%ielm = ielm_tmp (1:numpatch)
+ ENDIF
+
+ IF (numset > 0) THEN
+ deallocate (eindex_tmp)
+ deallocate (ipxstt_tmp)
+ deallocate (ipxend_tmp)
+ deallocate (settyp_tmp)
+ deallocate (ielm_tmp )
+ ENDIF
+
+#ifdef USEMPI
+ CALL aggregation_compute_done ()
+#endif
+
+ ENDIF
+
+ landpatch%nset = numpatch
+
+ CALL landpatch%set_vecgs
+
+
+#if (!defined(URBAN_MODEL) && !defined(CROP))
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err)
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.'
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.'
+#endif
+
+IF ( .not. DEF_Output_2mWMO ) THEN
+ CALL elm_patch%build (landelm, landpatch, use_frac = .true.)
+#ifdef CATCHMENT
+ CALL hru_patch%build (landhru, landpatch, use_frac = .true.)
+#endif
+
+ CALL write_patchfrac (DEF_dir_landdata, lc_year)
+ENDIF
+#endif
+
+ END SUBROUTINE landpatch_build
+
+ ! -----
+ SUBROUTINE write_patchfrac (dir_landdata, lc_year)
+
+ USE MOD_Namelist
+ USE MOD_NetCDFVector
+ IMPLICIT NONE
+
+ integer, intent(in) :: lc_year
+ character(len=*), intent(in) :: dir_landdata
+ character(len=256) :: lndname, cyear
+
+ write(cyear,'(i4.4)') lc_year
+ CALL system('mkdir -p ' // trim(dir_landdata) // '/landpatch/' // trim(cyear))
+
+ lndname = trim(dir_landdata)//'/landpatch/'//trim(cyear)//'/patchfrac_elm.nc'
+ CALL ncio_create_file_vector (lndname, landpatch)
+ CALL ncio_define_dimension_vector (lndname, landpatch, 'patch')
+ CALL ncio_write_vector (lndname, 'patchfrac_elm', 'patch', landpatch, elm_patch%subfrc, DEF_Srfdata_CompressLevel)
+
+#ifdef CATCHMENT
+ lndname = trim(dir_landdata)//'/landpatch/'//trim(cyear)//'/patchfrac_hru.nc'
+ CALL ncio_create_file_vector (lndname, landpatch)
+ CALL ncio_define_dimension_vector (lndname, landpatch, 'patch')
+ CALL ncio_write_vector (lndname, 'patchfrac_hru', 'patch', landpatch, hru_patch%subfrc, DEF_Srfdata_CompressLevel)
+#endif
+
+ END SUBROUTINE write_patchfrac
+
+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..76fd7e77fe
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_LandUrban.F90
@@ -0,0 +1,409 @@
+#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 routines ----
+ PUBLIC :: landurban_build
+ PUBLIC :: map_patch_to_urban
+
+CONTAINS
+
+ ! -------------------------------
+ SUBROUTINE landurban_build (lc_year)
+
+ USE MOD_Precision
+ USE MOD_Vars_Global
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFBlock
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_Namelist
+ USE MOD_5x5DataReadin
+ USE MOD_Mesh
+ USE MOD_LandPatch
+ USE MOD_LandElm
+#ifdef CATCHMENT
+ USE MOD_LandHRU
+#endif
+ USE MOD_AggregationRequestData
+ USE MOD_Utils
+
+ IMPLICIT NONE
+
+ integer, intent(in) :: lc_year
+ ! Local Variables
+ character(len=256) :: dir_urban
+ type (block_data_int32_2d) :: data_urb_class ! urban type index
+
+ ! local vars
+ integer, allocatable :: ibuff(:), types(:), order(:)
+
+ ! index
+ integer :: ipatch, jpatch, iurban
+ integer :: ie, ipxstt, ipxend, npxl, ipxl
+ integer :: nurb_glb, npatch_glb
+
+ ! local vars for landpath and landurban
+ integer :: numpatch_
+ integer*8, allocatable :: eindex_(:)
+ integer, allocatable :: ipxstt_(:)
+ integer, allocatable :: ipxend_(:)
+ integer, allocatable :: settyp_(:)
+ integer, allocatable :: ielm_ (:)
+
+ integer :: numurban_
+ integer :: iurb, ib, imiss
+ integer :: buff_count(N_URB)
+ real(r8) :: buff_p(N_URB)
+
+ integer , allocatable :: urbclass (:)
+ real(r8), allocatable :: area_one (:)
+
+ character(len=256) :: suffix, cyear
+
+ IF (p_is_root) THEN
+ write(*,'(A)') 'Making urban type tiles:'
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ ! allocate and read the grided LCZ/NCAR urban type
+ IF (p_is_active) THEN
+
+ dir_urban = trim(DEF_dir_rawdata) // '/urban_type'
+
+ CALL allocate_block_data (grid_urban, data_urb_class)
+ CALL flush_block_data (data_urb_class, 0)
+
+ ! read urban type data
+ suffix = 'URBTYP'
+IF (DEF_URBAN_type_scheme == 1) THEN
+ CALL read_5x5_data (dir_urban, suffix, grid_urban, 'URBAN_DENSITY_CLASS', data_urb_class)
+ELSE IF (DEF_URBAN_type_scheme == 2) THEN
+ CALL read_5x5_data (dir_urban, suffix, grid_urban, 'LCZ_DOM', data_urb_class)
+ENDIF
+
+#ifdef USEMPI
+ CALL aggregation_data_daemon (grid_urban, data_i4_2d_in1 = data_urb_class)
+#endif
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ IF (numpatch > 0) THEN
+ ! a temporary numpatch with max urban patch number
+ numpatch_ = numpatch + count(landpatch%settyp == URBAN) * (N_URB-1)
+
+ allocate (eindex_ (numpatch_ ))
+ allocate (ipxstt_ (numpatch_ ))
+ allocate (ipxend_ (numpatch_ ))
+ allocate (settyp_ (numpatch_ ))
+ allocate (ielm_ (numpatch_ ))
+
+ ! max urban patch number (temporary)
+ numurban_ = count(landpatch%settyp == URBAN) * N_URB
+ IF (numurban_ > 0) THEN
+ allocate (urbclass(numurban_))
+ ENDIF
+ ENDIF
+
+ jpatch = 0
+ iurban = 0
+
+ ! loop for temporary numpatch to filter duplicate urban patch
+ DO ipatch = 1, numpatch
+ IF (landpatch%settyp(ipatch) == URBAN) THEN
+
+ ie = landpatch%ielm (ipatch)
+ ipxstt = landpatch%ipxstt(ipatch)
+ ipxend = landpatch%ipxend(ipatch)
+
+ CALL aggregation_request_data (landpatch, ipatch, grid_urban, zip = .false., area = area_one, &
+ data_i4_2d_in1 = data_urb_class, data_i4_2d_out1 = ibuff)
+
+ ! when there is missing urban types
+ !NOTE@tungwz: need double check below and add appropriate annotations
+ ! check if there is urban pixel without URBAN ID
+ imiss = count(ibuff<1 .or. ibuff>N_URB)
+ IF (imiss > 0) THEN
+ ! Calculate the relative ratio of each urban types by excluding urban pixels without URBAN ID
+ WHERE (ibuff<1 .or. ibuff>N_URB)
+ area_one = 0
+ END WHERE
+
+ buff_p = 0
+ IF (sum(area_one) > 0) THEN
+ DO ib = 1, size(area_one)
+ IF (ibuff(ib)>1 .and. ibuff(ib)N_URB) THEN
+ type_loop: DO iurb = 1, N_URB
+ IF (buff_count(iurb) > 0) THEN
+ ibuff(ib) = iurb
+ buff_count(iurb) = buff_count(iurb) - 1
+ EXIT type_loop
+ ENDIF
+ ENDDO type_loop
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+
+ npxl = ipxend - ipxstt + 1
+
+ allocate (types (ipxstt:ipxend))
+
+ types(:) = ibuff
+
+ deallocate (ibuff)
+
+ allocate (order (ipxstt:ipxend))
+ order = (/ (ipxl, ipxl = ipxstt, ipxend) /)
+
+ ! change order vars, types->regid ? still types below
+ ! add region information, because urban type may be same,
+ ! but from different region in this urban patch
+ ! relative code is changed
+ CALL quicksort (npxl, types, order)
+
+ mesh(ie)%ilon(ipxstt:ipxend) = mesh(ie)%ilon(order)
+ mesh(ie)%ilat(ipxstt:ipxend) = mesh(ie)%ilat(order)
+
+ DO ipxl = ipxstt, ipxend
+ IF (ipxl /= ipxstt) THEN
+ IF (types(ipxl) /= types(ipxl-1)) THEN
+ ipxend_(jpatch) = ipxl - 1
+ ELSE
+ CYCLE
+ ENDIF
+ ENDIF
+
+ jpatch = jpatch + 1
+ eindex_(jpatch) = mesh(ie)%indx
+ settyp_(jpatch) = URBAN
+ ipxstt_(jpatch) = ipxl
+ ielm_ (jpatch) = ie
+
+ iurban = iurban + 1
+ urbclass(iurban) = types(ipxl)
+ ENDDO
+
+ ipxend_(jpatch) = ipxend
+
+ deallocate (types)
+ deallocate (order)
+
+ ELSE
+ jpatch = jpatch + 1
+ eindex_(jpatch) = landpatch%eindex(ipatch)
+ ipxstt_(jpatch) = landpatch%ipxstt(ipatch)
+ ipxend_(jpatch) = landpatch%ipxend(ipatch)
+ settyp_(jpatch) = landpatch%settyp(ipatch)
+ ielm_ (jpatch) = landpatch%ielm (ipatch)
+ ENDIF
+ ENDDO
+
+#ifdef USEMPI
+ CALL aggregation_compute_done ()
+#endif
+
+ numpatch = jpatch
+
+ IF (numpatch > 0) THEN
+ ! update landpath with new patch number
+ ! all urban type patch are included
+ IF (allocated (landpatch%eindex)) deallocate (landpatch%eindex)
+ IF (allocated (landpatch%ipxstt)) deallocate (landpatch%ipxstt)
+ IF (allocated (landpatch%ipxend)) deallocate (landpatch%ipxend)
+ IF (allocated (landpatch%settyp)) deallocate (landpatch%settyp)
+ IF (allocated (landpatch%ielm )) deallocate (landpatch%ielm )
+
+ allocate (landpatch%eindex (numpatch))
+ allocate (landpatch%ipxstt (numpatch))
+ allocate (landpatch%ipxend (numpatch))
+ allocate (landpatch%settyp (numpatch))
+ allocate (landpatch%ielm (numpatch))
+
+ ! update all information of landpatch
+ landpatch%eindex = eindex_(1:jpatch)
+ landpatch%ipxstt = ipxstt_(1:jpatch)
+ landpatch%ipxend = ipxend_(1:jpatch)
+ landpatch%settyp = settyp_(1:jpatch)
+ landpatch%ielm = ielm_ (1:jpatch)
+ ENDIF
+
+ ! update urban patch number
+ IF (numpatch > 0) THEN
+ numurban = count(landpatch%settyp == URBAN)
+ ELSE
+ numurban = 0
+ ENDIF
+
+ IF (numurban > 0) THEN
+ allocate (landurban%eindex (numurban))
+ allocate (landurban%settyp (numurban))
+ allocate (landurban%ipxstt (numurban))
+ allocate (landurban%ipxend (numurban))
+ allocate (landurban%ielm (numurban))
+
+ ! copy urban path information from landpatch for landurban
+ landurban%eindex = pack(landpatch%eindex, landpatch%settyp == URBAN)
+ landurban%ipxstt = pack(landpatch%ipxstt, landpatch%settyp == URBAN)
+ landurban%ipxend = pack(landpatch%ipxend, landpatch%settyp == URBAN)
+ landurban%ielm = pack(landpatch%ielm , landpatch%settyp == URBAN)
+
+ ! assign urban region id and type for each urban patch
+ landurban%settyp = urbclass(1:numurban)
+ ENDIF
+
+ ! update land patch with urban type patch
+ ! set numurban
+ landurban%nset = numurban
+ landpatch%nset = numpatch
+ ENDIF
+
+ CALL landpatch%set_vecgs
+ CALL landurban%set_vecgs
+
+ CALL map_patch_to_urban
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ CALL mpi_reduce (numurban, nurb_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err)
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,I12,A)') 'Total: ', nurb_glb, ' urban tiles.'
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ write(*,'(A,I12,A)') 'Total: ', numurban, ' urban tiles.'
+#endif
+
+#ifndef CROP
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ CALL mpi_reduce (numpatch, npatch_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err)
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,I12,A)') 'Total: ', npatch_glb, ' patches.'
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ write(*,'(A,I12,A)') 'Total: ', numpatch, ' patches.'
+#endif
+
+IF ( .not. DEF_Output_2mWMO ) THEN
+ CALL elm_patch%build (landelm, landpatch, use_frac = .true.)
+#ifdef CATCHMENT
+ CALL hru_patch%build (landhru, landpatch, use_frac = .true.)
+#endif
+ CALL write_patchfrac (DEF_dir_landdata, lc_year)
+ENDIF
+#endif
+
+ IF (allocated (ibuff )) deallocate (ibuff )
+ IF (allocated (types )) deallocate (types )
+ IF (allocated (order )) deallocate (order )
+
+ IF (allocated (eindex_ )) deallocate (eindex_ )
+ IF (allocated (ipxstt_ )) deallocate (ipxstt_ )
+ IF (allocated (ipxend_ )) deallocate (ipxend_ )
+ IF (allocated (settyp_ )) deallocate (settyp_ )
+ IF (allocated (ielm_ )) deallocate (ielm_ )
+
+ IF (allocated (urbclass)) deallocate (urbclass )
+ IF (allocated (area_one)) deallocate (area_one )
+
+ END SUBROUTINE landurban_build
+
+ ! ----------------------
+ SUBROUTINE map_patch_to_urban
+
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch
+ IMPLICIT NONE
+
+ integer :: ipatch, iurban
+
+ IF (p_is_compute) 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_Mesh.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90
new file mode 100644
index 0000000000..24bfc019c8
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Mesh.F90
@@ -0,0 +1,1051 @@
+#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_SPMD_Task
+ USE MOD_Namelist
+ IMPLICIT NONE
+
+ IF (p_is_root) THEN
+ inquire (file=trim(DEF_file_mesh), exist=read_mesh_from_file)
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_bcast (read_mesh_from_file, 1, MPI_LOGICAL, p_address_root, p_comm_glb, p_err)
+#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_build ()
+
+ USE MOD_Precision
+ USE MOD_Namelist
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFBlock
+ USE MOD_Block
+ USE MOD_Pixel
+ USE MOD_Grid
+ USE MOD_Utils
+ USE MOD_DataType
+ USE MOD_CatchmentDataReadin
+
+ IMPLICIT NONE
+
+ ! Local Variables
+ type(block_data_int32_2d) :: datamesh
+
+ integer :: nelm, ie, je, dsp
+ integer :: iblkme, iblk, jblk, xloc, yloc, xg, yg, ixloc, iyloc
+ integer :: xp, yp, xblk, yblk, npxl, ipxl, ix, iy
+ integer :: irank, iproc, idest, isrc, iloc, iloc_max(2)
+ integer :: ylg, yug, ysp, ynp, nyp
+ integer :: xlg, xug, xwp, xep, nxp
+ real(r8) :: dlatp, dlonp
+ logical :: is_new
+ integer :: smesg(6), rmesg(6), blktag, nsend, nrecv, irecv
+ integer :: iblk_p, jblk_p, nelm_max_blk, nelm_glb
+
+ integer, allocatable :: nelm_rank(:)
+ type(pointer_int64_1d), allocatable :: elist_rank(:)
+
+ integer*8 :: elmid
+ integer*8, allocatable :: elist(:), elist2(:,:), sbuf64(:), elist_recv(:)
+
+ integer, allocatable :: iaddr(:), elmindx (:), order(:)
+ integer, allocatable :: xlist(:), ylist (:), npxl_(:), xlist_recv(:), ylist_recv(:), sbuf(:)
+ logical, allocatable :: msk (:), work_done(:)
+
+ integer, allocatable :: xlist2(:,:), ylist2(:,:), ipt2(:,:), npxl_blk(:,:), blkdsp(:,:), blkcnt(:,:)
+ logical, allocatable :: msk2 (:,:)
+
+ type(irregular_elm_type), allocatable :: meshtmp (:)
+
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (gridmesh, datamesh)
+ ENDIF
+
+#ifdef GRIDBASED
+ IF (read_mesh_from_file) THEN
+ CALL ncio_read_block (DEF_file_mesh, 'landmask', gridmesh, datamesh)
+ ELSE
+ CALL flush_block_data (datamesh, 1)
+ ENDIF
+#endif
+
+#ifdef CATCHMENT
+ CALL catchment_data_read (DEF_CatchmentMesh_data, 'icatchment2d', gridmesh, datamesh, spv = -1)
+#endif
+
+#ifdef UNSTRUCTURED
+ CALL ncio_read_block (DEF_file_mesh, 'elmindex', gridmesh, datamesh)
+#endif
+
+ ! Step 1: How many elms in each block?
+ IF (p_is_active) THEN
+
+ nelm = 0
+
+ allocate (nelm_rank (0:p_np_compute-1))
+ nelm_rank(:) = 0
+
+ allocate (elist_rank (0:p_np_compute-1))
+ DO irank = 0, p_np_compute-1
+ allocate (elist_rank(irank)%val (1000))
+ ENDDO
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+
+ DO yloc = 1, gridmesh%ycnt(jblk)
+ DO xloc = 1, gridmesh%xcnt(iblk)
+
+#ifdef GRIDBASED
+ IF (datamesh%blk(iblk,jblk)%val(xloc,yloc) > 0) THEN
+ xg = gridmesh%xdsp(iblk) + xloc
+ IF (xg > gridmesh%nlon) xg = xg - gridmesh%nlon
+
+ yg = gridmesh%ydsp(jblk) + yloc
+
+ elmid = int(gridmesh%nlon,8) * (yg-1) + xg
+ ELSE
+ elmid = 0
+ ENDIF
+#endif
+#ifdef CATCHMENT
+ elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc)
+#endif
+#ifdef UNSTRUCTURED
+ elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc)
+#endif
+
+ IF (elmid > 0) THEN
+
+ irank = mod(elmid, p_np_compute)
+ CALL insert_into_sorted_list1 ( &
+ elmid, nelm_rank(irank), elist_rank(irank)%val, iloc)
+
+ IF (nelm_rank(irank) == size(elist_rank(irank)%val)) THEN
+ CALL expand_list (elist_rank(irank)%val, 0.2_r8)
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+#ifdef USEMPI
+ DO irank = 0, p_np_compute-1
+ IF (nelm_rank(irank) > 0) THEN
+ idest = p_address_compute(irank)
+ smesg(1:2) = (/p_iam_glb, nelm_rank(irank)/)
+ ! send(01)
+ CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, &
+ idest, mpi_tag_size, p_comm_glb, p_err)
+ ENDIF
+ ENDDO
+#endif
+
+ nelm = nelm + sum(nelm_rank)
+ nelm_rank(:) = 0
+ ENDDO
+
+#ifdef USEMPI
+ DO irank = 0, p_np_compute-1
+ idest = p_address_compute(irank)
+ ! send(02)
+ smesg(1:2) = (/p_iam_glb, 0/)
+ CALL mpi_send (smesg(1:2), 2, MPI_INTEGER, &
+ idest, mpi_tag_size, p_comm_glb, p_err)
+ ENDDO
+#endif
+
+ deallocate (nelm_rank)
+ DO irank = 0, p_np_compute-1
+ deallocate (elist_rank(irank)%val)
+ ENDDO
+ deallocate (elist_rank)
+
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ nelm = 0
+ allocate(work_done(0:p_np_active-1))
+ work_done(:) = .false.
+ DO WHILE (.not. all(work_done))
+ ! recv(01,02)
+ CALL mpi_recv (rmesg(1:2), 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_size, p_comm_glb, p_stat, p_err)
+
+ isrc = rmesg(1)
+ nrecv = rmesg(2)
+
+ IF (nrecv > 0) THEN
+ nelm = nelm + nrecv
+ ELSE
+ work_done(p_itis_active(isrc)) = .true.
+ ENDIF
+ ENDDO
+
+ deallocate(work_done)
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ ! Step 2: Build pixel list for each elm.
+ IF (p_is_compute) THEN
+ IF (nelm > 0) THEN
+ allocate (meshtmp (nelm))
+ allocate (elist (nelm))
+ allocate (iaddr (nelm))
+ ENDIF
+ nelm = 0
+ ENDIF
+
+ IF (p_is_active) THEN
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+ IF (gridmesh%xcnt(iblk) <= 0) CYCLE
+ IF (gridmesh%ycnt(jblk) <= 0) CYCLE
+
+ ylg = gridmesh%ydsp(jblk) + 1
+ yug = gridmesh%ydsp(jblk) + gridmesh%ycnt(jblk)
+ IF (gridmesh%yinc == 1) THEN
+ ysp = find_nearest_south (gridmesh%lat_s(ylg), pixel%nlat, pixel%lat_s)
+ ynp = find_nearest_north (gridmesh%lat_n(yug), pixel%nlat, pixel%lat_n)
+ ELSE
+ ysp = find_nearest_south (gridmesh%lat_s(yug), pixel%nlat, pixel%lat_s)
+ ynp = find_nearest_north (gridmesh%lat_n(ylg), pixel%nlat, pixel%lat_n)
+ ENDIF
+
+ nyp = ynp - ysp + 1
+
+ xlg = gridmesh%xdsp(iblk) + 1
+ xug = gridmesh%xdsp(iblk) + gridmesh%xcnt(iblk)
+ IF (xug > gridmesh%nlon) xug = xug - gridmesh%nlon
+
+ xwp = find_nearest_west (gridmesh%lon_w(xlg), pixel%nlon, pixel%lon_w)
+ IF (.not. lon_between_floor(pixel%lon_w(xwp), gridmesh%lon_w(xlg), gridmesh%lon_e(xlg))) THEN
+ xwp = mod(xwp,pixel%nlon) + 1
+ ENDIF
+
+ xep = find_nearest_east (gridmesh%lon_e(xug), pixel%nlon, pixel%lon_e)
+ IF (.not. lon_between_ceil(pixel%lon_e(xep), gridmesh%lon_w(xug), gridmesh%lon_e(xug))) THEN
+ xep = xep - 1
+ IF (xep == 0) xep = pixel%nlon
+ ENDIF
+
+ nxp = xep - xwp + 1
+ IF (nxp <= 0) nxp = nxp + pixel%nlon
+
+ allocate (elist2 (nxp,nyp))
+ allocate (xlist2 (nxp,nyp))
+ allocate (ylist2 (nxp,nyp))
+ allocate (msk2 (nxp,nyp))
+
+ DO iy = ysp, ynp
+ yg = gridmesh%ygrd(iy)
+ yloc = gridmesh%yloc(yg)
+
+ iyloc = iy - ysp + 1
+ dlatp = pixel%lat_n(iy) - pixel%lat_s(iy)
+ IF (dlatp < 1.0e-6_r8) THEN
+ elist2(:,iyloc) = 0
+ CYCLE
+ ENDIF
+
+ ix = xwp
+ ixloc = 0
+ DO WHILE (.true.)
+ ixloc = ixloc + 1
+ dlonp = pixel%lon_e(ix) - pixel%lon_w(ix)
+ IF (dlonp < 0) dlonp = dlonp + 360.0_r8
+
+ xg = gridmesh%xgrd(ix)
+ xloc = gridmesh%xloc(xg)
+
+#ifdef GRIDBASED
+ IF (datamesh%blk(iblk,jblk)%val(xloc,yloc) > 0) THEN
+ elmid = int(gridmesh%nlon,8) * (yg-1) + xg
+ ELSE
+ elmid = 0
+ ENDIF
+#endif
+#ifdef CATCHMENT
+ elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc)
+#endif
+#ifdef UNSTRUCTURED
+ elmid = datamesh%blk(iblk,jblk)%val(xloc,yloc)
+#endif
+
+ xlist2(ixloc,iyloc) = ix
+ ylist2(ixloc,iyloc) = iy
+ elist2(ixloc,iyloc) = elmid
+
+ IF (dlonp < 1.0e-6_r8) THEN
+ elist2(ixloc,iyloc) = 0
+ ENDIF
+
+ IF (ix == xep) EXIT
+ ix = mod(ix,pixel%nlon) + 1
+ ENDDO
+ ENDDO
+
+#ifdef USEMPI
+ allocate (sbuf (nxp*nyp))
+ allocate (ipt2 (nxp,nyp))
+
+ allocate (sbuf64 (nxp*nyp))
+
+ blktag = iblkme
+ ipt2 = mod(elist2, p_np_compute)
+ DO iproc = 0, p_np_compute-1
+ msk2 = (ipt2 == iproc) .and. (elist2 > 0)
+ nsend = count(msk2)
+ IF (nsend > 0) THEN
+
+ idest = p_address_compute(iproc)
+
+ smesg(1:3) = (/p_iam_glb, nsend, blktag/)
+ ! send(03)
+ CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, &
+ idest, mpi_tag_mesg, p_comm_glb, p_err)
+
+ sbuf64(1:nsend) = pack(elist2, msk2)
+ ! send(04)
+ CALL mpi_send (sbuf64(1:nsend), nsend, MPI_INTEGER8, &
+ idest, blktag, p_comm_glb, p_err)
+
+ sbuf(1:nsend) = pack(xlist2, msk2)
+ ! send(05)
+ CALL mpi_send (sbuf(1:nsend), nsend, MPI_INTEGER, &
+ idest, blktag, p_comm_glb, p_err)
+
+ sbuf(1:nsend) = pack(ylist2, msk2)
+ ! send(06)
+ CALL mpi_send (sbuf(1:nsend), nsend, MPI_INTEGER, &
+ idest, blktag, p_comm_glb, p_err)
+
+ ENDIF
+ ENDDO
+
+ deallocate (sbuf )
+ deallocate (ipt2 )
+ deallocate (sbuf64)
+#else
+
+ DO iy = 1, nyp
+ DO ix = 1, nxp
+
+ elmid = elist2(ix,iy)
+ IF (elmid > 0) THEN
+
+ CALL insert_into_sorted_list1 (elmid, nelm, elist, iloc, is_new)
+
+ msk2 = (elist2 == elmid)
+ npxl = count(msk2)
+
+ IF (is_new) THEN
+ IF (iloc < nelm) THEN
+ iaddr(iloc+1:nelm) = iaddr(iloc:nelm-1)
+ ENDIF
+ iaddr(iloc) = nelm
+
+ meshtmp(iaddr(iloc))%indx = elmid
+ meshtmp(iaddr(iloc))%npxl = npxl
+ ELSE
+ meshtmp(iaddr(iloc))%npxl = meshtmp(iaddr(iloc))%npxl + npxl
+ ENDIF
+
+ allocate (xlist(npxl))
+ allocate (ylist(npxl))
+ xlist = pack(xlist2, msk2)
+ ylist = pack(ylist2, msk2)
+
+ CALL append_to_list (meshtmp(iaddr(iloc))%ilon, xlist)
+ CALL append_to_list (meshtmp(iaddr(iloc))%ilat, ylist)
+
+ WHERE(msk2) elist2 = -1
+
+ deallocate (xlist)
+ deallocate (ylist)
+ ENDIF
+
+ ENDDO
+ ENDDO
+#endif
+
+ deallocate (elist2)
+ deallocate (xlist2)
+ deallocate (ylist2)
+ deallocate (msk2 )
+
+ ENDDO
+
+#ifdef USEMPI
+ DO irank = 0, p_np_compute-1
+ idest = p_address_compute(irank)
+ ! send(07)
+ smesg(1:3) = (/p_iam_glb, 0, 0/)
+ CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, &
+ idest, mpi_tag_mesg, p_comm_glb, p_err)
+ ENDDO
+#endif
+
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+
+ allocate(work_done(0:p_np_active-1))
+ work_done(:) = .false.
+ DO WHILE (.not. all(work_done))
+ ! recv(03,07)
+ CALL mpi_recv (rmesg(1:3), 3, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = rmesg(1)
+ nrecv = rmesg(2)
+ blktag = rmesg(3)
+ IF (nrecv > 0) THEN
+
+ allocate (elist_recv (nrecv))
+ ! recv(04)
+ CALL mpi_recv (elist_recv, nrecv, MPI_INTEGER8, &
+ isrc, blktag, p_comm_glb, p_stat, p_err)
+
+ allocate (xlist_recv (nrecv))
+ ! recv(05)
+ CALL mpi_recv (xlist_recv, nrecv, MPI_INTEGER, &
+ isrc, blktag, p_comm_glb, p_stat, p_err)
+
+ allocate (ylist_recv (nrecv))
+ ! recv(06)
+ CALL mpi_recv (ylist_recv, nrecv, MPI_INTEGER, &
+ isrc, blktag, p_comm_glb, p_stat, p_err)
+
+ allocate (msk(nrecv))
+
+ DO irecv = 1, nrecv
+
+ elmid = elist_recv(irecv)
+
+ IF (elmid > 0) THEN
+
+ CALL insert_into_sorted_list1 (elmid, nelm, elist, iloc, is_new)
+
+ msk = (elist_recv == elmid)
+ npxl = count(msk)
+
+ IF (is_new) THEN
+ IF (iloc < nelm) THEN
+ iaddr(iloc+1:nelm) = iaddr(iloc:nelm-1)
+ ENDIF
+ iaddr(iloc) = nelm
+
+ meshtmp(iaddr(iloc))%indx = elmid
+ meshtmp(iaddr(iloc))%npxl = npxl
+ ELSE
+ meshtmp(iaddr(iloc))%npxl = meshtmp(iaddr(iloc))%npxl + npxl
+ ENDIF
+
+ allocate (xlist(npxl))
+ allocate (ylist(npxl))
+ xlist = pack(xlist_recv, msk)
+ ylist = pack(ylist_recv, msk)
+
+ CALL append_to_list (meshtmp(iaddr(iloc))%ilon, xlist)
+ CALL append_to_list (meshtmp(iaddr(iloc))%ilat, ylist)
+
+ WHERE(msk) elist_recv = -1
+ deallocate (xlist)
+ deallocate (ylist)
+ ENDIF
+
+ ENDDO
+
+ deallocate (msk)
+ deallocate (elist_recv)
+ deallocate (xlist_recv)
+ deallocate (ylist_recv)
+ ELSE
+ work_done(p_itis_active(isrc)) = .true.
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (allocated(elist)) deallocate (elist)
+ IF (allocated(iaddr)) deallocate (iaddr)
+
+ ! Step 3: Which block each elm locates at.
+ IF (p_is_compute) THEN
+
+ allocate (npxl_blk (gblock%nxblk,gblock%nyblk))
+ allocate (nelm_blk (gblock%nxblk,gblock%nyblk))
+
+ nelm_blk(:,:) = 0
+
+ DO ie = 1, nelm
+
+ npxl_blk (:,:) = 0
+
+ DO ipxl = 1, meshtmp(ie)%npxl
+ xp = meshtmp(ie)%ilon(ipxl)
+ yp = meshtmp(ie)%ilat(ipxl)
+
+ xg = gridmesh%xgrd(xp)
+ yg = gridmesh%ygrd(yp)
+
+ xblk = gridmesh%xblk(xg)
+ yblk = gridmesh%yblk(yg)
+
+ npxl_blk(xblk,yblk) = npxl_blk(xblk,yblk) + 1
+ ENDDO
+
+ iloc_max = maxloc(npxl_blk)
+ meshtmp(ie)%xblk = iloc_max(1)
+ meshtmp(ie)%yblk = iloc_max(2)
+
+ nelm_blk(iloc_max(1), iloc_max(2)) = &
+ nelm_blk(iloc_max(1), iloc_max(2)) + 1
+
+ ENDDO
+
+ deallocate (npxl_blk)
+ ENDIF
+
+#ifdef USEMPI
+ IF (.not. p_is_compute) THEN
+ allocate (nelm_blk (gblock%nxblk,gblock%nyblk))
+ nelm_blk(:,:) = 0
+ ENDIF
+
+ CALL mpi_allreduce (MPI_IN_PLACE, nelm_blk, gblock%nxblk*gblock%nyblk, &
+ MPI_INTEGER, MPI_SUM, p_comm_glb, p_err)
+#endif
+
+ ! Step 4: IF MPI is used, sending elms from rank to their IO processes.
+
+ IF (p_is_active) THEN
+
+ allocate (blkdsp (gblock%nxblk, gblock%nyblk))
+ blkdsp(1,1) = 0
+ DO iblk = 1, gblock%nxblk
+ DO jblk = 1, gblock%nyblk
+ IF ((iblk /= 1) .or. (jblk /= 1)) THEN
+ IF (jblk == 1) THEN
+ iblk_p = iblk - 1
+ jblk_p = gblock%nyblk
+ ELSE
+ iblk_p = iblk
+ jblk_p = jblk - 1
+ ENDIF
+
+ IF (gblock%pio(iblk_p,jblk_p) == p_iam_glb) THEN
+ blkdsp(iblk,jblk) = blkdsp(iblk_p,jblk_p) + nelm_blk(iblk_p,jblk_p)
+ ELSE
+ blkdsp(iblk,jblk) = blkdsp(iblk_p,jblk_p)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ DO iblk = 1, gblock%nxblk
+ DO jblk = 1, gblock%nyblk
+
+ idest = gblock%pio(iblk,jblk)
+
+ nsend = 0
+ npxl = 0
+ DO ie = 1, nelm
+ IF ((meshtmp(ie)%xblk == iblk) .and. (meshtmp(ie)%yblk == jblk)) THEN
+ nsend = nsend + 1
+ npxl = npxl + meshtmp(ie)%npxl
+ ENDIF
+ ENDDO
+
+ IF (nsend > 0) THEN
+
+ allocate (elist (nsend))
+ allocate (npxl_ (nsend))
+ allocate (xlist (npxl ))
+ allocate (ylist (npxl ))
+
+ nsend = 0
+ npxl = 0
+ DO ie = 1, nelm
+ IF ((meshtmp(ie)%xblk == iblk) .and. (meshtmp(ie)%yblk == jblk)) THEN
+
+ nsend = nsend + 1
+
+ elist(nsend) = meshtmp(ie)%indx
+ npxl_(nsend) = meshtmp(ie)%npxl
+
+ xlist(npxl+1:npxl+meshtmp(ie)%npxl) = meshtmp(ie)%ilon
+ ylist(npxl+1:npxl+meshtmp(ie)%npxl) = meshtmp(ie)%ilat
+
+ npxl = npxl + meshtmp(ie)%npxl
+ ENDIF
+ ENDDO
+
+ blktag = p_iam_glb + 1000
+
+ ! send(09)
+ smesg(1:6) = (/p_iam_glb, blktag, iblk, jblk, nsend, npxl/)
+ CALL mpi_send (smesg(1:6), 6, MPI_INTEGER, idest, mpi_tag_mesg, p_comm_glb, p_err)
+
+ ! send(10)
+ CALL mpi_send (elist, nsend, MPI_INTEGER8, idest, blktag, p_comm_glb, p_err)
+ CALL mpi_send (npxl_, nsend, MPI_INTEGER, idest, blktag, p_comm_glb, p_err)
+
+ ! send(11)
+ CALL mpi_send (xlist, npxl, MPI_INTEGER, idest, blktag, p_comm_glb, p_err)
+ CALL mpi_send (ylist, npxl, MPI_INTEGER, idest, blktag, p_comm_glb, p_err)
+
+ deallocate (elist)
+ deallocate (npxl_)
+ deallocate (xlist)
+ deallocate (ylist)
+
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF (p_is_active) THEN
+
+ numelm = sum(nelm_blk, mask = gblock%pio == p_iam_glb)
+
+ IF (numelm > 0) THEN
+
+ allocate (mesh (numelm))
+
+ allocate (blkcnt (gblock%nxblk, gblock%nyblk))
+ blkcnt(:,:) = 0
+
+ DO WHILE (sum(blkcnt) < numelm)
+
+ ! recv(09)
+ CALL mpi_recv (rmesg(1:6), 6, MPI_INTEGER, MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ isrc = rmesg(1)
+ blktag = rmesg(2)
+ xblk = rmesg(3)
+ yblk = rmesg(4)
+ nrecv = rmesg(5)
+ npxl = rmesg(6)
+
+ allocate (elist (nrecv))
+ allocate (npxl_ (nrecv))
+ allocate (xlist (npxl ))
+ allocate (ylist (npxl ))
+
+ ! recv(10)
+ CALL mpi_recv (elist, nrecv, MPI_INTEGER8, isrc, blktag, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (npxl_, nrecv, MPI_INTEGER, isrc, blktag, p_comm_glb, p_stat, p_err)
+
+ ! recv(11)
+ CALL mpi_recv (xlist, npxl, MPI_INTEGER, isrc, blktag, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (ylist, npxl, MPI_INTEGER, isrc, blktag, p_comm_glb, p_stat, p_err)
+
+ dsp = 0
+ DO ie = 1, nrecv
+
+ je = blkdsp(xblk,yblk) + blkcnt(xblk,yblk) + ie
+
+ mesh(je)%indx = elist(ie)
+ mesh(je)%xblk = xblk
+ mesh(je)%yblk = yblk
+ mesh(je)%npxl = npxl_(ie)
+
+ allocate (mesh(je)%ilon (npxl_(ie)))
+ allocate (mesh(je)%ilat (npxl_(ie)))
+
+ mesh(je)%ilon = xlist(dsp+1:dsp+npxl_(ie))
+ mesh(je)%ilat = ylist(dsp+1:dsp+npxl_(ie))
+
+ dsp = dsp + npxl_(ie)
+
+ ENDDO
+
+ blkcnt(xblk,yblk) = blkcnt(xblk,yblk) + nrecv
+
+ deallocate (elist)
+ deallocate (npxl_)
+ deallocate (xlist)
+ deallocate (ylist)
+
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+#else
+ numelm = nelm
+ IF (numelm > 0) THEN
+
+ allocate (mesh (numelm))
+
+ allocate (blkcnt (gblock%nxblk, gblock%nyblk))
+ blkcnt(:,:) = 0
+ DO ie = 1, numelm
+
+ xblk = meshtmp(ie)%xblk
+ yblk = meshtmp(ie)%yblk
+
+ blkcnt(xblk,yblk) = blkcnt(xblk,yblk) + 1
+ je = blkdsp(xblk,yblk) + blkcnt(xblk,yblk)
+
+ CALL copy_elm (meshtmp(ie), mesh(je))
+
+ ENDDO
+
+ ENDIF
+#endif
+
+ ! Step 4-2: sort elms.
+ IF (p_is_active) THEN
+ IF (allocated (meshtmp)) THEN
+ DO ie = 1, size(meshtmp)
+ IF (allocated(meshtmp(ie)%ilon)) deallocate (meshtmp(ie)%ilon)
+ IF (allocated(meshtmp(ie)%ilat)) deallocate (meshtmp(ie)%ilat)
+ ENDDO
+ deallocate (meshtmp)
+ ENDIF
+
+ IF (numelm > 0) THEN
+ allocate (meshtmp (numelm))
+ DO ie = 1, numelm
+ CALL copy_elm(mesh(ie), meshtmp(ie))
+ ENDDO
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+
+ IF (blkcnt(iblk,jblk) > 0) THEN
+ allocate (elmindx (blkcnt(iblk,jblk)))
+ allocate (order (blkcnt(iblk,jblk)))
+
+ DO ie = blkdsp(iblk,jblk)+1, blkdsp(iblk,jblk)+blkcnt(iblk,jblk)
+ elmindx(ie-blkdsp(iblk,jblk)) = mesh(ie)%indx
+ ENDDO
+
+ order = (/ (ie, ie = 1, blkcnt(iblk,jblk)) /)
+ CALL quicksort (blkcnt(iblk,jblk), elmindx, order)
+
+ DO ie = 1, blkcnt(iblk,jblk)
+ CALL copy_elm (meshtmp(blkdsp(iblk,jblk)+order(ie)), &
+ mesh(blkdsp(iblk,jblk)+ie))
+ ENDDO
+
+ deallocate (elmindx)
+ deallocate (order )
+ ENDIF
+
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF (allocated(blkdsp)) deallocate(blkdsp)
+ IF (allocated(blkcnt)) deallocate(blkcnt)
+
+ IF (allocated (meshtmp)) THEN
+ DO ie = 1, size(meshtmp)
+ IF (allocated(meshtmp(ie)%ilon)) deallocate (meshtmp(ie)%ilon)
+ IF (allocated(meshtmp(ie)%ilat)) deallocate (meshtmp(ie)%ilat)
+ ENDDO
+
+ deallocate (meshtmp )
+ ENDIF
+
+ ! Step 5: IF MPI is used, scatter elms from IO to ranks.
+#ifdef USEMPI
+#ifndef MPAS_EMBEDDED_COLM
+ CALL scatter_mesh_legacy_roles ()
+#endif
+#endif
+
+ IF (p_is_root) THEN
+ write(*,'(A)') 'Making mesh elements:'
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+ IF (p_is_active) THEN
+
+ CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_active, p_err)
+ IF (p_iam_active == p_root) THEN
+ write(*,'(A,I12,A)') 'Total : ', nelm_glb, ' elements.'
+ ENDIF
+
+ nelm_max_blk = maxval(nelm_blk, mask = gblock%pio == p_iam_glb)
+ CALL mpi_allreduce (MPI_IN_PLACE, nelm_max_blk, 1, MPI_INTEGER, MPI_MAX, p_comm_active, p_err)
+ IF (p_iam_active == p_root) THEN
+ write(*,'(A,I12,A)') 'Maximum : ', nelm_max_blk, &
+ ' elements in one block (More than 3600 is recommended).'
+ write(*,'(/,A)') ' -----------------------------------------------------------------'
+ write(*,'(A)') ' | Examples for setting of blocks and processor groupsize: |'
+ write(*,'(A)') ' | Resolution DEF_nx_blocks DEF_ny_blocks DEF_PIO_groupsize |'
+ write(*,'(A)') ' | 2x2 18 9 15 |'
+ write(*,'(A)') ' | 1x1 18 9 24 |'
+ write(*,'(A)') ' | 0.5x0.5 18 9 36 |'
+ write(*,'(A)') ' | 0.25x0.25 30 15 45 |'
+ write(*,'(A)') ' | 0.1x0.1 72 36 64 |'
+ write(*,'(A,/)') ' -----------------------------------------------------------------'
+ ENDIF
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#else
+ write(*,'(A,I12,A)') 'Total: ', numelm, ' elements.'
+#endif
+
+ END SUBROUTINE mesh_build
+
+
+#ifdef USEMPI
+#ifndef MPAS_EMBEDDED_COLM
+ ! --------------------------------
+ SUBROUTINE scatter_mesh_legacy_roles
+
+ USE MOD_SPMD_Task
+ USE MOD_Block
+ IMPLICIT NONE
+
+ ! Local variables
+ integer :: iblk, jblk, nave, nres, iproc, ndsp, nsend, idest, ie
+ integer :: smesg(4), rmesg(4)
+ integer, allocatable :: nelm_rank(:)
+ integer :: iblkme
+ character(len=20) :: wfmt
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+ IF (p_is_active) THEN
+
+ allocate (nelm_rank (1:p_np_group-1))
+ nelm_rank(:) = 0
+
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+
+ nave = nelm_blk(iblk,jblk) / (p_np_group-1)
+ nres = mod(nelm_blk(iblk,jblk), p_np_group-1)
+ DO iproc = 1, p_np_group-1
+ nelm_rank(iproc) = nelm_rank(iproc) + nave
+ IF (iproc <= nres) nelm_rank(iproc) = nelm_rank(iproc) + 1
+ ENDDO
+ ENDDO
+
+ IF (any(nelm_rank == 0)) THEN
+ write(*,'(A,/,A)') 'Warning: there are idle ranks, please use less processors ' // &
+ 'OR larger working group ', ' (set by DEF_PIO_groupsize in CoLM namelist).'
+ write(wfmt,'(A,I0,A)') '(A,I6,A,', p_np_group-1, '(X,I0))'
+ write(*,wfmt) 'Numbers of elements by ranks in group ', p_iam_glb, ' are ', nelm_rank
+ ENDIF
+
+ DO iproc = 1, p_np_group-1
+ CALL mpi_send (nelm_rank(iproc), 1, MPI_INTEGER, &
+ iproc, mpi_tag_size, p_comm_group, p_err)
+ ENDDO
+ deallocate (nelm_rank)
+
+ ndsp = 0
+ DO iblkme = 1, gblock%nblkme
+ iblk = gblock%xblkme(iblkme)
+ jblk = gblock%yblkme(iblkme)
+
+ nave = nelm_blk(iblk,jblk) / (p_np_group-1)
+ nres = mod(nelm_blk(iblk,jblk), p_np_group-1)
+ DO iproc = 1, p_np_group-1
+ nsend = nave
+ IF (iproc <= nres) nsend = nsend + 1
+
+ DO ie = ndsp+1, ndsp+nsend
+ idest = iproc
+ CALL mpi_send (mesh(ie)%indx, 1, MPI_INTEGER8, &
+ idest, mpi_tag_mesg, p_comm_group, p_err)
+ smesg(1:3) = (/mesh(ie)%xblk, mesh(ie)%yblk, mesh(ie)%npxl/)
+ CALL mpi_send (smesg(1:3), 3, MPI_INTEGER, &
+ idest, mpi_tag_mesg, p_comm_group, p_err)
+ CALL mpi_send (mesh(ie)%ilon, mesh(ie)%npxl, &
+ MPI_INTEGER, idest, mpi_tag_data, p_comm_group, p_err)
+ CALL mpi_send (mesh(ie)%ilat, mesh(ie)%npxl, &
+ MPI_INTEGER, idest, mpi_tag_data, p_comm_group, p_err)
+ ENDDO
+ ndsp = ndsp + nsend
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ CALL mpi_recv (numelm, 1, MPI_INTEGER, &
+ p_root, mpi_tag_size, p_comm_group, p_stat, p_err)
+
+ IF (numelm > 0) THEN
+ allocate (mesh (numelm))
+
+ DO ie = 1, numelm
+ CALL mpi_recv (mesh(ie)%indx, 1, MPI_INTEGER8, &
+ p_root, mpi_tag_mesg, p_comm_group, p_stat, p_err)
+ CALL mpi_recv (rmesg, 3, MPI_INTEGER, &
+ p_root, mpi_tag_mesg, p_comm_group, p_stat, p_err)
+
+ mesh(ie)%xblk = rmesg(1)
+ mesh(ie)%yblk = rmesg(2)
+ mesh(ie)%npxl = rmesg(3)
+
+ allocate (mesh(ie)%ilon (mesh(ie)%npxl))
+ allocate (mesh(ie)%ilat (mesh(ie)%npxl))
+
+ CALL mpi_recv (mesh(ie)%ilon, mesh(ie)%npxl, MPI_INTEGER, &
+ p_root, mpi_tag_data, p_comm_group, p_stat, p_err)
+ CALL mpi_recv (mesh(ie)%ilat, mesh(ie)%npxl, MPI_INTEGER, &
+ p_root, mpi_tag_data, p_comm_group, p_stat, p_err)
+ ENDDO
+
+ ENDIF
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+
+ END SUBROUTINE scatter_mesh_legacy_roles
+
+#endif
+#endif
+
+ ! --------------------------------
+ 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
+
+ numelm = 0
+
+ END SUBROUTINE mesh_free_mem
+
+END MODULE MOD_Mesh
diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_MeshFilter.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_MeshFilter.F90
new file mode 100644
index 0000000000..d4796ff885
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_MeshFilter.F90
@@ -0,0 +1,181 @@
+#include
+
+MODULE MOD_MeshFilter
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Mesh filter.
+! Mesh filter can be used to mask part of region or globe as needed.
+!
+! Created by Shupeng Zhang, May 2023
+!-----------------------------------------------------------------------
+
+ USE MOD_Grid
+ IMPLICIT NONE
+
+ logical :: has_mesh_filter
+ type(grid_type) :: grid_filter
+
+CONTAINS
+
+ logical FUNCTION inquire_mesh_filter ()
+
+ USE MOD_SPMD_Task
+ USE MOD_Namelist
+ IMPLICIT NONE
+ logical :: fexists
+
+ IF (p_is_root) THEN
+
+ inquire (file=trim(DEF_file_mesh_filter), exist=fexists)
+
+ IF (.not. fexists) THEN
+ write(*,'(/, 2A)') 'Note: Mesh Filter not used: file ', trim(DEF_file_mesh_filter)
+ ELSE
+ write(*,'(/, 2A)') 'Note: Mesh Filter from file ', trim(DEF_file_mesh_filter)
+ ENDIF
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_bcast (fexists, 1, MPI_LOGICAL, p_address_root, p_comm_glb, p_err)
+#endif
+
+ inquire_mesh_filter = fexists
+
+ END FUNCTION inquire_mesh_filter
+
+ ! -------------
+ SUBROUTINE mesh_filter (gridf, ffilter, fvname)
+
+ USE MOD_Precision
+ USE MOD_Namelist
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFBlock
+ USE MOD_DataType
+ USE MOD_LandElm
+ USE MOD_Mesh
+ USE MOD_AggregationRequestData
+ USE MOD_Block
+ IMPLICIT NONE
+
+ type(grid_type), intent(in) :: gridf
+ character(len=*), intent(in) :: ffilter
+ character(len=*), intent(in) :: fvname
+
+ ! local variables:
+ ! ---------------------------------------------------------------
+ type (block_data_int32_2d) :: datafilter
+ integer, allocatable :: ifilter(:), xtemp(:), ytemp(:)
+ logical, allocatable :: filter(:)
+ integer :: ielm, jelm, npxl, nelm_glb
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+ IF (p_is_root) THEN
+ write(*,'(/, A)') 'Filtering pixels ...'
+ ENDIF
+
+ IF (p_is_active) THEN
+ CALL allocate_block_data (gridf, datafilter)
+ CALL ncio_read_block (trim(ffilter), trim(fvname), gridf, datafilter)
+
+#ifdef USEMPI
+ CALL aggregation_data_daemon (gridf, data_i4_2d_in1 = datafilter)
+#endif
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ jelm = 0
+ DO ielm = 1, numelm
+ CALL aggregation_request_data (landelm, ielm, gridf, zip = .false., &
+ data_i4_2d_in1 = datafilter, data_i4_2d_out1 = ifilter, &
+ filledvalue_i4 = -1)
+
+ allocate (filter (mesh(ielm)%npxl))
+ filter = ifilter > 0
+
+ IF (any(filter)) THEN
+ jelm = jelm + 1
+ IF (.not. all(filter)) THEN
+
+ npxl = count(filter)
+
+ allocate (xtemp(npxl))
+ allocate (ytemp(npxl))
+ xtemp = pack(mesh(ielm)%ilon, filter)
+ ytemp = pack(mesh(ielm)%ilat, filter)
+
+ deallocate(mesh(ielm)%ilon)
+ deallocate(mesh(ielm)%ilat)
+
+ mesh(ielm)%npxl = npxl
+
+ allocate(mesh(ielm)%ilon(npxl))
+ allocate(mesh(ielm)%ilat(npxl))
+ mesh(ielm)%ilon = xtemp
+ mesh(ielm)%ilat = ytemp
+
+ deallocate (xtemp)
+ deallocate (ytemp)
+ ENDIF
+
+ IF (jelm /= ielm) THEN
+ CALL copy_elm (mesh(ielm), mesh(jelm))
+ ENDIF
+
+ ENDIF
+
+ deallocate (filter)
+ ENDDO
+
+ numelm = jelm
+
+#ifdef USEMPI
+ CALL aggregation_compute_done ()
+#endif
+ ENDIF
+
+ IF (p_is_compute) THEN
+ IF (allocated(landelm%eindex)) deallocate (landelm%eindex)
+ IF (allocated(landelm%ipxstt)) deallocate (landelm%ipxstt)
+ IF (allocated(landelm%ipxend)) deallocate (landelm%ipxend)
+ IF (allocated(landelm%settyp)) deallocate (landelm%settyp)
+ IF (allocated(landelm%ielm )) deallocate (landelm%ielm )
+ ENDIF
+
+ CALL landelm_build ()
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ CALL mpi_reduce (numelm, nelm_glb, 1, MPI_INTEGER, MPI_SUM, p_root, p_comm_compute, p_err)
+ IF (p_iam_compute == 0) THEN
+ write(*,'(A,I12,A)') 'Total: ', nelm_glb, ' elements after mesh filtering.'
+ ENDIF
+ ENDIF
+#else
+ write(*,'(A,I12,A)') 'Total: ', numelm, ' elements after mesh filtering.'
+#endif
+
+ ! Update nelm_blk
+ nelm_blk(:,:) = 0
+ IF (p_is_compute) THEN
+ DO ielm = 1, numelm
+ nelm_blk(mesh(ielm)%xblk,mesh(ielm)%yblk) = &
+ nelm_blk(mesh(ielm)%xblk,mesh(ielm)%yblk) + 1
+ ENDDO
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, nelm_blk, gblock%nxblk*gblock%nyblk, &
+ MPI_INTEGER, MPI_SUM, p_comm_glb, p_err)
+#endif
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ END SUBROUTINE mesh_filter
+
+END MODULE MOD_MeshFilter
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..d22cdf17ed
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Namelist.F90
@@ -0,0 +1,2508 @@
+#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
+
+ ! Standalone CoLM used this to size its role-split groups.
+ ! MPAS-embedded CoLM maps all active ranks to MPAS compute ranks.
+ integer :: DEF_PIO_groupsize = 12
+ logical :: DEF_nIO_eq_nBlock = .false.
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! ----- 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'
+
+ character(len=256) :: DEF_file_mesh_filter = 'path/to/mesh/filter'
+
+ ! ----- 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
+
+ ! ----- merge data in aggregation when send data from IO to compute rank -----
+ logical :: USE_zip_for_aggregation = .true.
+
+ ! ----- compress level in writing aggregated surface data -----
+ integer :: DEF_Srfdata_CompressLevel = 1
+
+! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! ----- 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_SPMD_Task
+ 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_PIO_groupsize, &
+ DEF_nIO_eq_nBlock, &
+ 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_file_mesh_filter, &
+
+ 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, &
+ USE_zip_for_aggregation, &
+ DEF_Srfdata_CompressLevel, &
+
+ 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 (p_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)
+
+ 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
+
+ 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 system('mkdir -p ' // trim(adjustl(DEF_dir_output )))
+ CALL system('mkdir -p ' // trim(adjustl(DEF_dir_landdata)))
+ CALL system('mkdir -p ' // trim(adjustl(DEF_dir_restart )))
+ CALL system('mkdir -p ' // trim(adjustl(DEF_dir_history )))
+
+#ifdef SinglePoint
+ DEF_nx_blocks = 360
+ DEF_ny_blocks = 180
+ DEF_HIST_mode = 'one'
+#endif
+
+ IF (DEF_simulation_time%timestep > 3600.) THEN
+ write(*,*) ' ***** '
+ write(*,*) 'Warning: timestep should be less than or equal to 3600 seconds.'
+ CALL CoLM_Stop ()
+ 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 USEMPI
+ CALL mpi_bcast (DEF_Output_2mWMO ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_CASE_NAME ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_domain%edges ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_domain%edgen ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_domain%edgew ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_domain%edgee ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_BlockInfoFile ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_AverageElementSize ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_nx_blocks ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_ny_blocks ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_PIO_groupsize ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_nIO_eq_nBlock ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_simulation_time%greenwich ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_simulation_time%start_year ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%start_month ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%start_day ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%start_sec ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_simulation_time%end_year ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%end_month ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%end_day ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%end_sec ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_simulation_time%spinup_year ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%spinup_month ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%spinup_day ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%spinup_sec ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_simulation_time%spinup_repeat ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_simulation_time%timestep ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_dir_rawdata ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_dir_runtime ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_dir_output ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_dir_forcing ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_dir_landdata ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_dir_restart ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_dir_history ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+#if (defined GRIDBASED || defined UNSTRUCTURED)
+ CALL mpi_bcast (DEF_file_mesh ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_GRIDBASED_lon_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_GRIDBASED_lat_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+#endif
+
+#ifdef CATCHMENT
+ CALL mpi_bcast (DEF_CatchmentMesh_data ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+#endif
+
+ CALL mpi_bcast (DEF_file_mesh_filter ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_dir_existing_srfdata ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (USE_srfdata_from_larger_region ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (USE_srfdata_from_3D_gridded_data ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (USE_zip_for_aggregation ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_Srfdata_CompressLevel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+
+ ! 07/2023, added by yuan: subgrid setting related
+ CALL mpi_bcast (DEF_USE_LCT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_PFT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_PC ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_FAST_PC ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_PC_CROP_SPLIT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SOLO_PFT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SUBGRID_SCHEME ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_LAI_START_YEAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_LAI_END_YEAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_LAI_CHANGE_YEARLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ ! 05/2023, added by Xingjie lu
+ CALL mpi_bcast (DEF_USE_LAIFEEDBACK ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_IRRIGATION ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_IRRIGATION_ALLOCATION ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_NOSTRESSNITROGEN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_RSTFAC ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+
+ ! LULC related
+ CALL mpi_bcast (DEF_LC_YEAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_LULCC_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_URBAN_type_scheme ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_URBAN_geom_data ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ ! 05/2023, added by yuan
+ CALL mpi_bcast (DEF_URBAN_ONLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_URBAN_RUN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_URBAN_BEM ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_URBAN_TREE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_URBAN_WATER ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_URBAN_LUCY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_CANYON_HWR ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ ! 06/2023, added by weinan
+ CALL mpi_bcast (DEF_USE_SOILPAR_UPS_FIT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_THERMAL_CONDUCTIVITY_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_SUPERCOOL_WATER ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ ! 06/2023, added by hua yuan
+ CALL mpi_bcast (DEF_SOIL_REFL_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ ! 07/2023, added by zhuo liu
+ CALL mpi_bcast (DEF_RSS_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ ! 02/2024, added by Shupeng Zhang
+ CALL mpi_bcast (DEF_Runoff_SCHEME ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_VIC_OPT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_file_VIC_para ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_file_VIC_OPT ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_TOPMOD_method ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ ! 08/2023, added by hua yuan
+ CALL mpi_bcast (DEF_SPLIT_SOILSNOW ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_VEG_SNOW ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_LAI_MONTHLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_NDEP_FREQUENCY ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_Interception_scheme ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SSP ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_USE_CBL_HEIGHT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_PLANTHYDRAULICS ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_MEDLYNST ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_WUEST ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_SASU ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_DiagMatrix ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_PN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_FERT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_FERT_SOURCE ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_NITRIF ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_CNSOYFIXN ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_FIRE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_USE_Dynamic_Lake ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_Dynamic_Wetland ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_CheckEquilibrium ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_LANDONLY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_DOMINANT_PATCHTYPE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_VariablySaturatedFlow ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_BEDROCK ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_OZONESTRESS ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_OZONEDATA ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_precip_phase_discrimination_scheme ,5 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_USE_SoilInit ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_file_SoilInit ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_HighResSoil ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_HighResVeg ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_PROSPECT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_HighResUrban_albedo ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_USE_SnowInit ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_file_SnowInit ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_USE_CN_INIT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_file_cn_init ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_USE_WaterTableInit ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_file_WaterTable ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_USE_SNICAR ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_file_snowoptics ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_file_snowaging ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_ElementNeighbour_file ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_UnitCatchment_file ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_ReservoirPara_file ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_DA_obsdir ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_TWS ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_TWS_GRACE ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_SM ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_ENS_NUM ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_ENS_SM ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_SM_SMAP ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_SM_FY ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_SM_SYNOP ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_RTM_diel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DA_RTM_rough ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_Optimize_Baseflow ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_Aerosol_Readin ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_Aerosol_Clim ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_USE_EstimatedRiverDepth ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_Reservoir_Method ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_GRIDBASED_ROUTING_MAX_DT ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_USE_SEDIMENT ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_LAMBDA ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_LYRDPH ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_DENSITY ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_WATER_DENSITY ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_VISKIN ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_VONKAR ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_PSET ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_TOTLYRNUM ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_CFL_ADV ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_IGNORE_DPH ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_DT_MAX ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_DIAMETER ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_PYLD ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_PYLDC ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_PYLDPC ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_SED_DSYLUNIT ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_HISTORY_IN_VECTOR ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_HIST_lon_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_HIST_lat_res ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_HIST_grid_as_forcing ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_WRST_FREQ ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_HIST_FREQ ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_HIST_groupby ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_HIST_mode ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_HIST_WriteBack ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_REST_CompressLevel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_HIST_CompressLevel ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_Forcing_Interp_Method ,20 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_Forcing_Downscaling ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_Forcing_Downscaling_Simple ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DS_HiresTopographyDataDir ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DS_precipitation_adjust_scheme ,5 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_DS_longwave_adjust_scheme ,5 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_USE_ClimForcing_for_Spinup ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+
+ CALL mpi_bcast (DEF_forcing%dataset ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%solarin_all_band ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%HEIGHT_mode ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%HEIGHT_V ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%HEIGHT_T ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%HEIGHT_Q ,1 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%regional ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%regbnd ,4 ,mpi_real8 ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%has_missing_value ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%missing_value_name ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%NVAR ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%startyr ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%startmo ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%endyr ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%endmo ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%dtime ,8 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%offset ,8 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%nlands ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%leapyear ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%data2d ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%hightdim ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%dim2d ,1 ,mpi_logical ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%latname ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%lonname ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%groupby ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+
+ DO ivar = 1, 8
+ CALL mpi_bcast (DEF_forcing%fprefix(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%vname(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%timelog(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%tintalgo(ivar) ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ ENDDO
+ CALL mpi_bcast (DEF_forcing%CBL_fprefix ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%CBL_vname ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%CBL_tintalgo ,256 ,mpi_character ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%CBL_dtime ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+ CALL mpi_bcast (DEF_forcing%CBL_offset ,1 ,mpi_integer ,p_address_root ,p_comm_glb ,p_err)
+#endif
+
+ CALL sync_hist_vars (set_defaults = .true.)
+
+ IF (p_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.)
+
+ 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_SPMD_Task
+ IMPLICIT NONE
+
+ logical, intent(inout) :: onoff
+ logical, intent(in) :: set_defaults
+
+ IF (p_is_root) THEN
+ IF (set_defaults) THEN
+ onoff = DEF_HIST_vars_out_default
+ ENDIF
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_bcast (onoff, 1, mpi_logical, p_address_root, p_comm_glb, p_err)
+#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..68f36f0231
--- /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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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_SPMD_Task
+ 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 (p_is_active) 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..89c0b68b60
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFSerial.F90
@@ -0,0 +1,2615 @@
+#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_SPMD_Task
+ 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_SPMD_Task
+ 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_SPMD_Task
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: filename
+ character(len=*), intent(in) :: dataname
+ integer, intent(out) :: rdata
+
+#ifdef USEMPI
+ IF (p_is_root) THEN
+ CALL ncio_read_serial_int32_0d (filename, dataname, rdata)
+ ENDIF
+ CALL mpi_bcast (rdata, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+#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_SPMD_Task
+ USE MOD_Precision
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: filename
+ character(len=*), intent(in) :: dataname
+ real(r8), intent(out) :: rdata
+
+#ifdef USEMPI
+ IF (p_is_root) THEN
+ CALL ncio_read_serial_real8_0d (filename, dataname, rdata)
+ ENDIF
+ CALL mpi_bcast (rdata, 1, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+#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_SPMD_Task
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: filename
+ character(len=*), intent(in) :: dataname
+ integer, allocatable, intent(out) :: rdata (:)
+ integer :: vlen
+
+#ifdef USEMPI
+ IF (p_is_root) THEN
+ CALL ncio_read_serial_int32_1d(filename, dataname, rdata)
+ vlen = size(rdata)
+ ENDIF
+ CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ IF (.not. p_is_root) allocate (rdata (vlen))
+ CALL mpi_bcast (rdata, vlen, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+#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_SPMD_Task
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: filename
+ character(len=*), intent(in) :: dataname
+ integer, allocatable, intent(out) :: rdata (:,:)
+ integer :: vsize(2)
+
+#ifdef USEMPI
+ IF (p_is_root) THEN
+ CALL ncio_read_serial_int32_2d(filename, dataname, rdata)
+ vsize = shape(rdata)
+ ENDIF
+ CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ IF (.not. p_is_root) allocate (rdata (vsize(1), vsize(2)))
+ CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+#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_SPMD_Task
+ USE MOD_Precision
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: filename
+ character(len=*), intent(in) :: dataname
+ real(r8), allocatable, intent(out) :: rdata (:)
+ integer :: vlen
+
+#ifdef USEMPI
+ IF (p_is_root) THEN
+ CALL ncio_read_serial_real8_1d(filename, dataname, rdata)
+ vlen = size(rdata)
+ ENDIF
+ CALL mpi_bcast (vlen, 1, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ IF (.not. p_is_root) allocate (rdata (vlen))
+ CALL mpi_bcast (rdata, vlen, MPI_REAL8, p_address_root, p_comm_glb, p_err)
+#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_SPMD_Task
+ 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 USEMPI
+ IF (p_is_root) THEN
+ CALL ncio_read_serial_real8_2d(filename, dataname, rdata)
+ vsize = shape(rdata)
+ ENDIF
+ CALL mpi_bcast (vsize, 2, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2)))
+ CALL mpi_bcast (rdata, vsize(1)*vsize(2), MPI_REAL8, p_address_root, p_comm_glb, p_err)
+#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_SPMD_Task
+ 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 USEMPI
+ IF (p_is_root) THEN
+ CALL ncio_read_serial_real8_3d(filename, dataname, rdata)
+ vsize = shape(rdata)
+ ENDIF
+ CALL mpi_bcast (vsize, 3, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ IF (.not. p_is_root) allocate (rdata (vsize(1),vsize(2),vsize(3)))
+ CALL mpi_bcast (rdata, vsize(1)*vsize(2)*vsize(3), MPI_REAL8, p_address_root, p_comm_glb, p_err)
+#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_SPMD_Task
+ 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 USEMPI
+ IF (p_is_root) THEN
+ CALL ncio_read_serial_real8_4d(filename, dataname, rdata)
+ vsize = shape(rdata)
+ ENDIF
+ CALL mpi_bcast (vsize, 4, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ IF (.not. p_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, p_address_root, p_comm_glb, p_err)
+#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_SPMD_Task
+ 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 USEMPI
+ IF (p_is_root) THEN
+ CALL ncio_read_serial_real8_5d(filename, dataname, rdata)
+ vsize = shape(rdata)
+ ENDIF
+ CALL mpi_bcast (vsize, 5, MPI_INTEGER, p_address_root, p_comm_glb, p_err)
+ IF (.not. p_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, p_address_root, p_comm_glb, p_err)
+#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_SPMD_Task
+ 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 USEMPI
+ IF (p_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, p_address_root, p_comm_glb, p_err)
+ IF (.not. p_is_root) allocate (rdata (vlen))
+ CALL mpi_bcast (rdata, vlen, MPI_LOGICAL, p_address_root, p_comm_glb, p_err)
+#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 .and. index(iend+1) == index(iend) + 1)
+ 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 .and. index(iend+1) == index(iend) + 1)
+ 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 .and. index(iend+1) == index(iend) + 1)
+ 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 .and. index(iend+1) == index(iend) + 1)
+ 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..f803c3d468
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_NetCDFVector.F90
@@ -0,0 +1,2035 @@
+#include
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+#define COLM_VECTOR_MPI_IO
+#endif
+
+!----------------------------------------------------------------------------------
+! !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
+ IMPLICIT NONE
+
+ ! 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
+
+ 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
+
+CONTAINS
+
+ !---------------------------------------------------------
+ SUBROUTINE get_filename_vector_block (filename, iblk, jblk, fileblock, for_write, use_srcpos)
+
+ USE MOD_Block, only: get_filename_block
+#ifdef MPAS_EMBEDDED_COLM
+ USE MOD_SPMD_Task, only: p_iam_glb
+#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
+
+#ifdef MPAS_EMBEDDED_COLM
+ character(len=256) :: fileblock_rank
+ character(len=32) :: rank_suffix
+ integer :: idot
+ logical :: rank_local_file
+#endif
+
+ CALL get_filename_block (filename, iblk, jblk, fileblock)
+
+#ifdef MPAS_EMBEDDED_COLM
+ write(rank_suffix,'("_mpasr",I8.8)') p_iam_glb
+ 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
+
+ rank_local_file = .false.
+ IF (present(for_write)) rank_local_file = for_write
+ IF ((.not. rank_local_file) .and. present(use_srcpos)) THEN
+ inquire(file=trim(fileblock_rank), exist=rank_local_file)
+ ENDIF
+ IF (rank_local_file) THEN
+ fileblock = fileblock_rank
+ IF (present(use_srcpos)) use_srcpos = .false.
+ ENDIF
+#endif
+
+ END SUBROUTINE get_filename_vector_block
+
+ !---------------------------------------------------------
+ SUBROUTINE ncio_vector_stop_missing_block (filename, dataname, fileblock)
+
+ USE MOD_SPMD_Task, 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 ncio_read_vector_int32_1d ( &
+ filename, dataname, pixelset, rdata, defval)
+
+ USE MOD_NetCDFSerial
+ USE MOD_SPMD_Task
+ 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(:), rbuff(:)
+ logical :: any_data_exists, block_has_data, use_srcpos
+
+ IF (p_is_compute) THEN
+ IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN
+ allocate (rdata (pixelset%nset))
+ ENDIF
+ ENDIF
+
+ any_data_exists = .false.
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ use_srcpos = allocated(pixelset%srcpos)
+ CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos)
+
+ block_has_data = .false.
+ IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN
+ CALL ncio_read_serial (fileblock, dataname, sbuff)
+ any_data_exists = .true.
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_scatterv ( &
+ sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), &
+ pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, &
+ MPI_IN_PLACE, 0, MPI_INTEGER, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ IF (use_srcpos .and. block_has_data) THEN
+ DO iset = istt, iend
+ rdata(iset) = sbuff(pixelset%srcpos(iset))
+ ENDDO
+ ELSE
+ rdata(istt:iend) = sbuff
+ ENDIF
+#endif
+
+ deallocate (sbuff)
+
+ ENDDO
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+#endif
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ ELSE
+ allocate (rbuff(1))
+ ENDIF
+
+ CALL mpi_scatterv ( &
+ MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks
+ rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, &
+ p_root, p_comm_group, p_err)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rdata(istt:iend) = rbuff
+ ENDIF
+
+ IF (allocated(rbuff)) deallocate (rbuff)
+
+ ENDDO
+
+ 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_SPMD_Task
+ 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, intent(in), optional :: defval
+
+ ! Local variables
+ integer :: iblkgrp, iblk, jblk, istt, iend, iset
+ character(len=256) :: fileblock
+ integer*8, allocatable :: sbuff(:), rbuff(:)
+ logical :: any_data_exists, block_has_data, use_srcpos
+
+ IF (p_is_compute) THEN
+ IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN
+ allocate (rdata (pixelset%nset))
+ ENDIF
+ ENDIF
+
+ any_data_exists = .false.
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ use_srcpos = allocated(pixelset%srcpos)
+ CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos)
+
+ block_has_data = .false.
+ IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN
+ CALL ncio_read_serial (fileblock, dataname, sbuff)
+ any_data_exists = .true.
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_scatterv ( &
+ sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), &
+ pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, &
+ MPI_IN_PLACE, 0, MPI_INTEGER8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ IF (use_srcpos .and. block_has_data) THEN
+ DO iset = istt, iend
+ rdata(iset) = sbuff(pixelset%srcpos(iset))
+ ENDDO
+ ELSE
+ rdata(istt:iend) = sbuff
+ ENDIF
+#endif
+
+ deallocate (sbuff)
+
+ ENDDO
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+#endif
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ ELSE
+ allocate (rbuff(1))
+ ENDIF
+
+ CALL mpi_scatterv ( &
+ MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! unused on non-root ranks
+ rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, &
+ p_root, p_comm_group, p_err)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rdata(istt:iend) = rbuff
+ ENDIF
+
+ IF (allocated(rbuff)) deallocate (rbuff)
+
+ ENDDO
+
+ 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_SPMD_Task
+ 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(:), rbuff(:)
+ logical :: any_data_exists, block_has_data, use_srcpos
+
+ IF (p_is_compute) THEN
+ IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN
+ allocate (rdata (pixelset%nset))
+ ENDIF
+ ENDIF
+
+ any_data_exists = .false.
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ use_srcpos = allocated(pixelset%srcpos)
+ CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos)
+
+ block_has_data = .false.
+ IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN
+ CALL ncio_read_serial (fileblock, dataname, sbuff)
+ any_data_exists = .true.
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_scatterv ( &
+ sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), &
+ pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER1, &
+ MPI_IN_PLACE, 0, MPI_INTEGER1, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ IF (use_srcpos .and. block_has_data) THEN
+ DO iset = istt, iend
+ rdata(iset) = (sbuff(pixelset%srcpos(iset)) == 1)
+ ENDDO
+ ELSE
+ rdata(istt:iend) = (sbuff == 1)
+ ENDIF
+#endif
+
+ deallocate (sbuff)
+
+ ENDDO
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+#endif
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ ELSE
+ allocate (rbuff(1))
+ ENDIF
+
+ CALL mpi_scatterv ( &
+ MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! unused on non-root ranks
+ rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, &
+ p_root, p_comm_group, p_err)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rdata(istt:iend) = (rbuff == 1)
+ ENDIF
+
+ IF (allocated(rbuff)) deallocate (rbuff)
+
+ ENDDO
+
+ 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_SPMD_Task
+ 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(:), rbuff(:)
+ logical :: any_data_exists, block_has_data, use_srcpos
+
+ IF (p_is_compute) THEN
+ IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN
+ allocate (rdata (pixelset%nset))
+ ENDIF
+ ENDIF
+
+ any_data_exists = .false.
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ use_srcpos = allocated(pixelset%srcpos)
+ CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos)
+
+ block_has_data = .false.
+ IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN
+ CALL ncio_read_serial (fileblock, dataname, sbuff)
+ any_data_exists = .true.
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_scatterv ( &
+ sbuff, pixelset%vecgs%vcnt(:,iblk,jblk), &
+ pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ MPI_IN_PLACE, 0, MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ IF (use_srcpos .and. block_has_data) THEN
+ DO iset = istt, iend
+ rdata(iset) = sbuff(pixelset%srcpos(iset))
+ ENDDO
+ ELSE
+ rdata(istt:iend) = sbuff
+ ENDIF
+#endif
+
+ deallocate (sbuff)
+
+ ENDDO
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+#endif
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ ELSE
+ allocate (rbuff(1))
+ ENDIF
+
+ CALL mpi_scatterv ( &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ rbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rdata(istt:iend) = rbuff
+ ENDIF
+
+ IF (allocated(rbuff)) deallocate (rbuff)
+
+ ENDDO
+
+ 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_SPMD_Task
+ 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(:,:), rbuff(:,:)
+ logical :: any_data_exists, block_has_data, use_srcpos
+
+ IF (p_is_compute) THEN
+ IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN
+ allocate (rdata (ndim1, pixelset%nset))
+ ENDIF
+ ENDIF
+
+ any_data_exists = .false.
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (sbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk)))
+ use_srcpos = allocated(pixelset%srcpos)
+ CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos)
+
+ block_has_data = .false.
+ IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN
+ CALL ncio_read_serial (fileblock, dataname, sbuff)
+ any_data_exists = .true.
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_scatterv ( &
+ sbuff, ndim1 * pixelset%vecgs%vcnt(:,iblk,jblk), &
+ ndim1 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ MPI_IN_PLACE, 0, MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ IF (use_srcpos .and. block_has_data) THEN
+ DO iset = istt, iend
+ rdata(:,iset) = sbuff(:,pixelset%srcpos(iset))
+ ENDDO
+ ELSE
+ rdata(:,istt:iend) = sbuff
+ ENDIF
+#endif
+
+ deallocate (sbuff)
+
+ ENDDO
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+#endif
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (rbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk)))
+ ELSE
+ allocate (rbuff(1,1))
+ ENDIF
+
+ CALL mpi_scatterv ( &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ rbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rdata(:,istt:iend) = rbuff
+ ENDIF
+
+ IF (allocated(rbuff)) deallocate (rbuff)
+
+ ENDDO
+
+ 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_SPMD_Task
+ 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(:,:,:), rbuff(:,:,:)
+ logical :: any_data_exists, block_has_data, use_srcpos
+
+ IF (p_is_compute) THEN
+ IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN
+ allocate (rdata (ndim1,ndim2, pixelset%nset))
+ ENDIF
+ ENDIF
+
+ any_data_exists = .false.
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk)))
+ use_srcpos = allocated(pixelset%srcpos)
+ CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos)
+
+ block_has_data = .false.
+ IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN
+ CALL ncio_read_serial (fileblock, dataname, sbuff)
+ any_data_exists = .true.
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_scatterv ( &
+ sbuff, ndim1 * ndim2 * pixelset%vecgs%vcnt(:,iblk,jblk), &
+ ndim1 * ndim2 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ MPI_IN_PLACE, 0, MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ IF (use_srcpos .and. block_has_data) THEN
+ DO iset = istt, iend
+ rdata(:,:,iset) = sbuff(:,:,pixelset%srcpos(iset))
+ ENDDO
+ ELSE
+ rdata(:,:,istt:iend) = sbuff
+ ENDIF
+#endif
+
+ deallocate (sbuff)
+
+ ENDDO
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+#endif
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (rbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk)))
+ ELSE
+ allocate (rbuff(1,1,1))
+ ENDIF
+
+ CALL mpi_scatterv ( &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ rbuff, ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rdata(:,:,istt:iend) = rbuff
+ ENDIF
+
+ IF (allocated(rbuff)) deallocate (rbuff)
+
+ ENDDO
+
+ 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_SPMD_Task
+ 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(:,:,:,:), rbuff(:,:,:,:)
+ logical :: any_data_exists, block_has_data, use_srcpos
+
+ IF (p_is_compute) THEN
+ IF ((pixelset%nset > 0) .and. (.not. allocated(rdata))) THEN
+ allocate (rdata (ndim1,ndim2,ndim3, pixelset%nset))
+ ENDIF
+ ENDIF
+
+ any_data_exists = .false.
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (sbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk)))
+ use_srcpos = allocated(pixelset%srcpos)
+ CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos)
+
+ block_has_data = .false.
+ IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN
+ CALL ncio_read_serial (fileblock, dataname, sbuff)
+ any_data_exists = .true.
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_scatterv ( &
+ sbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vcnt(:,iblk,jblk), &
+ ndim1 * ndim2 * ndim3 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ MPI_IN_PLACE, 0, MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ IF (use_srcpos .and. block_has_data) THEN
+ DO iset = istt, iend
+ rdata(:,:,:,iset) = sbuff(:,:,:,pixelset%srcpos(iset))
+ ENDDO
+ ELSE
+ rdata(:,:,:,istt:iend) = sbuff
+ ENDIF
+#endif
+
+ deallocate (sbuff)
+
+ ENDDO
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+#endif
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (rbuff (ndim1,ndim2,ndim3, pixelset%vecgs%vlen(iblk,jblk)))
+ ELSE
+ allocate (rbuff(1,1,1,1))
+ ENDIF
+
+ CALL mpi_scatterv ( &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ rbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rdata(:,:,:,istt:iend) = rbuff
+ ENDIF
+
+ IF (allocated(rbuff)) deallocate (rbuff)
+
+ ENDDO
+
+ 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_SPMD_Task
+ 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(:,:,:,:,:), rbuff(:,:,:,:,:)
+ logical :: any_data_exists, block_has_data, use_srcpos
+
+ IF (p_is_compute) 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 (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (sbuff (ndim1,ndim2,ndim3,ndim4, pixelset%vecgs%vlen(iblk,jblk)))
+ use_srcpos = allocated(pixelset%srcpos)
+ CALL get_filename_vector_block (filename, iblk, jblk, fileblock, use_srcpos = use_srcpos)
+
+ block_has_data = .false.
+ IF (ncio_var_exist(fileblock,dataname,readflag=.false.)) THEN
+ CALL ncio_read_serial (fileblock, dataname, sbuff)
+ any_data_exists = .true.
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_scatterv ( &
+ sbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vcnt(:,iblk,jblk), &
+ ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ MPI_IN_PLACE, 0, MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ IF (use_srcpos .and. block_has_data) THEN
+ DO iset = istt, iend
+ rdata(:,:,:,:,iset) = sbuff(:,:,:,:,pixelset%srcpos(iset))
+ ENDDO
+ ELSE
+ rdata(:,:,:,:,istt:iend) = sbuff
+ ENDIF
+#endif
+
+ deallocate (sbuff)
+
+ ENDDO
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_allreduce (MPI_IN_PLACE, any_data_exists, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+#endif
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (rbuff (ndim1,ndim2,ndim3,ndim4, pixelset%vecgs%vlen(iblk,jblk)))
+ ELSE
+ allocate (rbuff(1,1,1,1,1))
+ ENDIF
+
+ CALL mpi_scatterv ( &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ rbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rdata(:,:,:,:,istt:iend) = rbuff
+ ENDIF
+
+ IF (allocated(rbuff)) deallocate (rbuff)
+
+ ENDDO
+
+ ENDIF
+#endif
+
+ END SUBROUTINE ncio_read_vector_real8_5d
+
+
+ !---------------------------------------------------------
+ SUBROUTINE ncio_create_file_vector (filename, pixelset)
+
+ USE MOD_NetCDFSerial
+ USE MOD_SPMD_Task
+ 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
+ character(len=256) :: fileblock
+
+ IF (p_is_active) 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)
+
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE ncio_create_file_vector
+
+ !---------------------------------------------------------
+ SUBROUTINE ncio_define_dimension_vector (filename, pixelset, dimname, dimlen)
+
+ USE MOD_NetCDFSerial
+ USE MOD_SPMD_Task
+ 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 (p_is_active) 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 ncio_write_vector_int32_1d ( &
+ filename, dataname, dimname, pixelset, wdata, compress_level)
+
+ USE MOD_NetCDFSerial
+ USE MOD_SPMD_Task
+ 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 :: sbuff(:), rbuff(:)
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk)))
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, &
+ rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), &
+ pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rbuff = wdata(istt:iend)
+#endif
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ sbuff = wdata(istt:iend)
+ ELSE
+ allocate (sbuff (1))
+ ENDIF
+
+ CALL mpi_gatherv ( &
+ sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, &
+ MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ IF (allocated(sbuff)) deallocate (sbuff)
+
+ ENDDO
+
+ ENDIF
+#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_SPMD_Task
+ 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 :: sbuff(:), rbuff(:)
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk)))
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER1, &
+ rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), &
+ pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER1, &
+ p_root, p_comm_group, p_err)
+#else
+ 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
+#endif
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (sbuff (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
+ sbuff(i-istt+1) = 1
+ ELSE
+ sbuff(i-istt+1) = 0
+ ENDIF
+ ENDDO
+ ELSE
+ allocate (sbuff (1))
+ ENDIF
+
+ CALL mpi_gatherv ( &
+ sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER1, &
+ MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER1, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ IF (allocated(sbuff)) deallocate (sbuff)
+
+ ENDDO
+
+ ENDIF
+#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_SPMD_Task
+ 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 :: sbuff(:,:,:), rbuff(:,:,:)
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (rbuff (ndim1,ndim2,pixelset%vecgs%vlen(iblk,jblk)))
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, &
+ rbuff, ndim1*ndim2*pixelset%vecgs%vcnt(:,iblk,jblk), &
+ ndim1*ndim2*pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rbuff = wdata(:,:,istt:iend)
+#endif
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (sbuff (ndim1,ndim2, pixelset%vecgs%vlen(iblk,jblk)))
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ sbuff = wdata(:,:,istt:iend)
+ ELSE
+ allocate (sbuff (1,1,1))
+ ENDIF
+
+ CALL mpi_gatherv ( &
+ sbuff, ndim1*ndim2*pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER, &
+ MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ IF (allocated(sbuff)) deallocate (sbuff)
+
+ ENDDO
+
+ ENDIF
+#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_SPMD_Task
+ 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 :: sbuff(:), rbuff(:)
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk)))
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, &
+ rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), &
+ pixelset%vecgs%vdsp(:,iblk,jblk), MPI_INTEGER8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rbuff = wdata(istt:iend)
+#endif
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ sbuff = wdata(istt:iend)
+ ELSE
+ allocate (sbuff (1))
+ ENDIF
+
+ CALL mpi_gatherv ( &
+ sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_INTEGER8, &
+ MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ IF (allocated(sbuff)) deallocate (sbuff)
+
+ ENDDO
+
+ ENDIF
+#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_SPMD_Task
+ 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 :: sbuff(:), rbuff(:)
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (rbuff (pixelset%vecgs%vlen(iblk,jblk)))
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_gatherv ( MPI_IN_PLACE, 0, MPI_REAL8, &
+ rbuff, pixelset%vecgs%vcnt(:,iblk,jblk), &
+ pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rbuff = wdata(istt:iend)
+#endif
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (sbuff (pixelset%vecgs%vlen(iblk,jblk)))
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ sbuff = wdata(istt:iend)
+ ELSE
+ allocate (sbuff (1))
+ ENDIF
+
+ CALL mpi_gatherv ( &
+ sbuff, pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ IF (allocated(sbuff)) deallocate (sbuff)
+
+ ENDDO
+
+ ENDIF
+#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_SPMD_Task
+ 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 :: sbuff(:,:), rbuff(:,:)
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (rbuff (ndim1, pixelset%vecgs%vlen(iblk,jblk)))
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, &
+ rbuff, ndim1 * pixelset%vecgs%vcnt(:,iblk,jblk), &
+ ndim1 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rbuff = wdata(:,istt:iend)
+#endif
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (sbuff (ndim1,pixelset%vecgs%vlen(iblk,jblk)))
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ sbuff = wdata(:,istt:iend)
+ ELSE
+ allocate (sbuff (1,1))
+ ENDIF
+
+ CALL mpi_gatherv ( &
+ sbuff, ndim1 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ IF (allocated(sbuff)) deallocate (sbuff)
+
+ ENDDO
+
+ ENDIF
+#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_SPMD_Task
+ 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 :: sbuff(:,:,:), rbuff(:,:,:)
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (rbuff (ndim1, ndim2, pixelset%vecgs%vlen(iblk,jblk)))
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, &
+ rbuff, ndim1 * ndim2 * pixelset%vecgs%vcnt(:,iblk,jblk), &
+ ndim1 * ndim2 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rbuff = wdata(:,:,istt:iend)
+#endif
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (sbuff (ndim1,ndim2,pixelset%vecgs%vlen(iblk,jblk)))
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ sbuff = wdata(:,:,istt:iend)
+ ELSE
+ allocate (sbuff (1,1,1))
+ ENDIF
+
+ CALL mpi_gatherv ( sbuff, &
+ ndim1 * ndim2 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ IF (allocated(sbuff)) deallocate (sbuff)
+
+ ENDDO
+
+ ENDIF
+#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_SPMD_Task
+ 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 :: sbuff(:,:,:,:), rbuff(:,:,:,:)
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (rbuff (ndim1, ndim2, ndim3, pixelset%vecgs%vlen(iblk,jblk)))
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, &
+ rbuff, ndim1 * ndim2 * ndim3 * pixelset%vecgs%vcnt(:,iblk,jblk), &
+ ndim1 * ndim2 * ndim3 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rbuff = wdata(:,:,:,istt:iend)
+#endif
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (sbuff (ndim1,ndim2,ndim3,pixelset%vecgs%vlen(iblk,jblk)))
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ sbuff = wdata(:,:,:,istt:iend)
+ ELSE
+ allocate (sbuff (1,1,1,1))
+ ENDIF
+
+ CALL mpi_gatherv ( sbuff, &
+ ndim1 * ndim2 * ndim3 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ IF (allocated(sbuff)) deallocate (sbuff)
+
+ ENDDO
+
+ ENDIF
+#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_SPMD_Task
+ 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 :: sbuff(:,:,:,:,:), rbuff(:,:,:,:,:)
+
+ IF (p_is_active) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ allocate (rbuff (ndim1, ndim2, ndim3, ndim4, pixelset%vecgs%vlen(iblk,jblk)))
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_REAL8, &
+ rbuff, ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vcnt(:,iblk,jblk), &
+ ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vdsp(:,iblk,jblk), MPI_REAL8, &
+ p_root, p_comm_group, p_err)
+#else
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ rbuff = wdata(:,:,:,:,istt:iend)
+#endif
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_compute) THEN
+
+ DO iblkgrp = 1, pixelset%nblkgrp
+ iblk = pixelset%xblkgrp(iblkgrp)
+ jblk = pixelset%yblkgrp(iblkgrp)
+
+ IF (pixelset%vecgs%vlen(iblk,jblk) > 0) THEN
+ allocate (sbuff (ndim1,ndim2,ndim3,ndim4,pixelset%vecgs%vlen(iblk,jblk)))
+ istt = pixelset%vecgs%vstt(iblk,jblk)
+ iend = pixelset%vecgs%vend(iblk,jblk)
+ sbuff = wdata(:,:,:,:,istt:iend)
+ ELSE
+ allocate (sbuff (1,1,1,1,1))
+ ENDIF
+
+ CALL mpi_gatherv ( sbuff, &
+ ndim1 * ndim2 * ndim3 * ndim4 * pixelset%vecgs%vlen(iblk,jblk), MPI_REAL8, &
+ MPI_RNULL_P, MPI_INULL_P, MPI_INULL_P, MPI_REAL8, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ IF (allocated(sbuff)) deallocate (sbuff)
+
+ ENDDO
+
+ ENDIF
+#endif
+
+ END SUBROUTINE ncio_write_vector_real8_5d
+ !------------------------------------------------
+
+ LOGICAL FUNCTION ncio_vector_report_missing(mandatory)
+
+ USE MOD_SPMD_Task, only: p_iam_active, p_root
+ IMPLICIT NONE
+
+ logical, intent(in) :: mandatory
+
+#ifdef MPAS_EMBEDDED_COLM
+ ncio_vector_report_missing = mandatory .or. (p_iam_active == p_root)
+#else
+ ncio_vector_report_missing = (p_iam_active == p_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..69f6d2bf3c
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixel.F90
@@ -0,0 +1,418 @@
+#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 :: save_to_file => pixel_save_to_file
+ 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_SPMD_Task
+ 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 (p_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_save_to_file (this, dir_landdata)
+
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ IMPLICIT NONE
+ class(pixel_type) :: this
+
+ character(len=*), intent(in) :: dir_landdata
+
+ ! Local variables
+ character(len=256) :: filename
+
+ IF (p_is_root) THEN
+
+ filename = trim(dir_landdata) // '/pixel.nc'
+
+ CALL ncio_create_file (filename)
+
+ CALL ncio_write_serial (filename, 'edges', this%edges)
+ CALL ncio_write_serial (filename, 'edgen', this%edgen)
+ CALL ncio_write_serial (filename, 'edgew', this%edgew)
+ CALL ncio_write_serial (filename, 'edgee', this%edgee)
+
+ CALL ncio_define_dimension (filename, 'latitude', this%nlat)
+ CALL ncio_define_dimension (filename, 'longitude', this%nlon)
+
+ CALL ncio_write_serial (filename, 'lat_s', this%lat_s, 'latitude' )
+ CALL ncio_write_serial (filename, 'lat_n', this%lat_n, 'latitude' )
+ CALL ncio_write_serial (filename, 'lon_w', this%lon_w, 'longitude')
+ CALL ncio_write_serial (filename, 'lon_e', this%lon_e, 'longitude')
+
+ ENDIF
+
+ END SUBROUTINE pixel_save_to_file
+
+ ! --------------------------------
+ SUBROUTINE pixel_load_from_file (this, dir_landdata)
+
+ USE MOD_NetCDFSerial
+ 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)
+
+ 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..a5276283a4
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Pixelset.F90
@@ -0,0 +1,747 @@
+#include
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+#define COLM_VECTOR_MPI_IO
+#endif
+
+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.
+!
+! Legacy vector MPI I/O may redistribute vector data between ranks for IO.
+! 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(:,:)
+
+ ! gathered vector counts/displacements
+ integer, allocatable :: vcnt(:,:,:)
+ integer, allocatable :: vdsp(:,:,:)
+
+ 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_SPMD_Task
+ USE MOD_Mesh
+ IMPLICIT NONE
+
+ class(pixelset_type) :: this
+
+ ! Local variables
+ integer :: iproc
+ integer :: iset, ie, xblk, yblk, iblk, jblk, scnt, iblkgrp, iblkall
+ logical, allocatable :: nonzero(:,:)
+
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (.not. allocated (this%vecgs%vlen)) THEN
+ allocate (this%vecgs%vlen (gblock%nxblk, gblock%nyblk))
+ this%vecgs%vlen(:,:) = 0
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ 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
+
+ ie = 1
+ xblk = 0
+ yblk = 0
+ DO iset = 1, this%nset
+ DO WHILE (this%eindex(iset) /= mesh(ie)%indx)
+ ie = ie + 1
+ ENDDO
+
+ 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
+
+#ifdef COLM_VECTOR_MPI_IO
+ DO jblk = 1, gblock%nyblk
+ DO iblk = 1, gblock%nxblk
+ IF (gblock%pio(iblk,jblk) == p_address_active(p_my_group)) THEN
+
+ scnt = this%vecgs%vlen(iblk,jblk)
+ CALL mpi_gather (scnt, 1, MPI_INTEGER, &
+ MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_group, p_err)
+
+ ENDIF
+ ENDDO
+ ENDDO
+#endif
+ ENDIF
+
+#ifdef COLM_VECTOR_MPI_IO
+ IF (p_is_active) THEN
+
+ IF (.not. allocated(this%vecgs%vcnt)) THEN
+ allocate (this%vecgs%vcnt (0:p_np_group-1,gblock%nxblk,gblock%nyblk))
+ allocate (this%vecgs%vdsp (0:p_np_group-1,gblock%nxblk,gblock%nyblk))
+ ENDIF
+
+ this%vecgs%vcnt(:,:,:) = 0
+ DO jblk = 1, gblock%nyblk
+ DO iblk = 1, gblock%nxblk
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+
+ scnt = 0
+ CALL mpi_gather (scnt, 1, MPI_INTEGER, &
+ this%vecgs%vcnt(:,iblk,jblk), 1, MPI_INTEGER, &
+ p_root, p_comm_group, p_err)
+
+ this%vecgs%vdsp(0,iblk,jblk) = 0
+ DO iproc = 1, p_np_group-1
+ this%vecgs%vdsp(iproc,iblk,jblk) = &
+ this%vecgs%vdsp(iproc-1,iblk,jblk) + this%vecgs%vcnt(iproc-1,iblk,jblk)
+ ENDDO
+
+ this%vecgs%vlen(iblk,jblk) = sum(this%vecgs%vcnt(:,iblk,jblk))
+
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+#endif
+
+ IF (p_is_active .or. p_is_compute) THEN
+ allocate (nonzero (gblock%nxblk,gblock%nyblk))
+
+ nonzero = this%vecgs%vlen > 0
+#ifdef COLM_VECTOR_MPI_IO
+ CALL mpi_allreduce (MPI_IN_PLACE, nonzero, gblock%nxblk * gblock%nyblk, &
+ MPI_LOGICAL, MPI_LOR, p_comm_group, p_err)
+#endif
+
+ 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_SPMD_Task
+ 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 (p_is_compute) 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)
+ IF (allocated(this%vcnt)) deallocate (this%vcnt)
+ IF (allocated(this%vdsp)) deallocate (this%vdsp)
+
+ END SUBROUTINE vec_gather_scatter_free_mem
+
+ ! --------------------------------
+ SUBROUTINE subset_build (this, superset, subset, use_frac)
+
+ USE MOD_Mesh
+ USE MOD_Pixel
+ USE MOD_Utils
+ 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
+
+ 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 ( (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)
+ 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)
+ this%subfrc(istt:iend) = this%subfrc(istt:iend) / sum(this%subfrc(istt:iend))
+ 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_PixelsetShared.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_PixelsetShared.F90
new file mode 100644
index 0000000000..61f5ab7bdf
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_PixelsetShared.F90
@@ -0,0 +1,213 @@
+#include
+
+MODULE MOD_PixelsetShared
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Shared pixelset refer to two or more pixelsets sharing the same geographic area.
+!
+! For example, for patch of crops, multiple crops can be planted on a piece of land.
+! When planting these crops, different irrigation schemes may be used. Thus the water
+! and energy processes have difference in crops and should be modeled independently.
+! By using shared pixelset, crop patch is splitted to two or more shared patches.
+! Each shared patch is assigned with a percentage of area and has its own states.
+!
+! Example of shared pixelsets
+! |<------------------- ELEMENT ------------------>| <-- level 1
+! | subset 1 | subset 2 | subset 3 | <-- level 2
+! | subset 2 shared 1 50% |
+! | subset 2 shared 2 20% | <-- subset 2 shares
+! | subset 2 shared 3 30% |
+!
+!
+! Created by Shupeng Zhang, May 2023
+!-----------------------------------------------------------------------
+
+ IMPLICIT NONE
+
+CONTAINS
+
+ SUBROUTINE pixelsetshared_build (pixelset, gshared, datashared, nmaxshared, typfilter, &
+ fracout, sharedclass, fracin)
+
+ USE MOD_SPMD_Task
+ USE MOD_Grid
+ USE MOD_DataType
+ USE MOD_Pixel
+ USE MOD_Pixelset
+ USE MOD_Mesh
+ USE MOD_Utils
+ USE MOD_AggregationRequestData
+ IMPLICIT NONE
+
+ type(pixelset_type), intent(inout) :: pixelset
+ type(grid_type), intent(in) :: gshared
+ type(block_data_real8_3d), intent(in) :: datashared
+ integer, intent(in) :: nmaxshared
+ integer, intent(in) :: typfilter(:)
+
+ real(r8), intent(out), allocatable :: fracout(:)
+ integer, intent(out), allocatable :: sharedclass(:)
+ real(r8), intent(in), optional :: fracin (:)
+
+ ! Local Variables
+ real(r8), allocatable :: pctshared(:,:)
+ real(r8), allocatable :: datashared1d(:,:), areapixel(:), rbuff(:,:)
+ integer :: nsetshared, ipset, jpset
+ integer :: ipxl, ie, ipxstt, ipxend, ishared
+ integer*8,allocatable :: eindex1(:)
+ integer, allocatable :: ielm1(:), ipxstt1(:), ipxend1(:), settyp1(:)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+#ifdef USEMPI
+ IF (p_is_active) THEN
+ CALL aggregation_data_daemon (gshared, data_r8_3d_in1 = datashared, n1_r8_3d_in1 = nmaxshared)
+ ENDIF
+#endif
+
+ IF (p_is_compute) THEN
+
+ nsetshared = 0
+
+ allocate (pctshared(nmaxshared,pixelset%nset))
+
+ DO ipset = 1, pixelset%nset
+ IF (any(typfilter(:) == pixelset%settyp(ipset))) THEN
+
+ ie = pixelset%ielm (ipset)
+ ipxstt = pixelset%ipxstt(ipset)
+ ipxend = pixelset%ipxend(ipset)
+
+ allocate (datashared1d (nmaxshared, ipxstt:ipxend))
+
+ CALL aggregation_request_data (pixelset, ipset, gshared, zip = .false., &
+ data_r8_3d_in1 = datashared, data_r8_3d_out1 = rbuff, n1_r8_3d_in1 = nmaxshared)
+
+ datashared1d = rbuff
+
+ allocate (areapixel(ipxstt:ipxend))
+ DO ipxl = ipxstt, ipxend
+ areapixel(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
+
+ DO ishared = 1, nmaxshared
+ pctshared(ishared,ipset) = sum(datashared1d(ishared,:) * areapixel)
+ ENDDO
+
+ IF (any(pctshared(:,ipset) > 0.)) THEN
+ nsetshared = nsetshared + count(pctshared(:,ipset) > 0.)
+ pctshared(:,ipset) = pctshared(:,ipset) / sum(pctshared(:,ipset))
+ ENDIF
+
+ deallocate (rbuff )
+ deallocate (areapixel )
+ deallocate (datashared1d)
+
+ ELSE
+ nsetshared = nsetshared + 1
+ ENDIF
+
+ ENDDO
+
+#ifdef USEMPI
+ CALL aggregation_compute_done ()
+#endif
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ IF (pixelset%nset > 0) THEN
+
+ allocate (eindex1(pixelset%nset))
+ allocate (ipxstt1(pixelset%nset))
+ allocate (ipxend1(pixelset%nset))
+ allocate (settyp1(pixelset%nset))
+ allocate (ielm1 (pixelset%nset))
+
+ eindex1 = pixelset%eindex
+ ipxstt1 = pixelset%ipxstt
+ ipxend1 = pixelset%ipxend
+ settyp1 = pixelset%settyp
+ ielm1 = pixelset%ielm
+
+ deallocate (pixelset%eindex)
+ deallocate (pixelset%ipxstt)
+ deallocate (pixelset%ipxend)
+ deallocate (pixelset%settyp)
+ deallocate (pixelset%ielm )
+
+ allocate (pixelset%eindex(nsetshared))
+ allocate (pixelset%ipxstt(nsetshared))
+ allocate (pixelset%ipxend(nsetshared))
+ allocate (pixelset%settyp(nsetshared))
+ allocate (pixelset%ielm (nsetshared))
+
+ allocate (fracout (nsetshared))
+ allocate (sharedclass(nsetshared))
+
+ fracout(:) = 1.0
+
+ jpset = 0
+ DO ipset = 1, pixelset%nset
+ IF (any(typfilter(:) == settyp1(ipset))) THEN
+ IF (any(pctshared(:,ipset) > 0.)) THEN
+ DO ishared = 1, nmaxshared
+ IF (pctshared(ishared,ipset) > 0.) THEN
+ jpset = jpset + 1
+ pixelset%eindex(jpset) = eindex1(ipset)
+ pixelset%ipxstt(jpset) = ipxstt1(ipset)
+ pixelset%ipxend(jpset) = ipxend1(ipset)
+ pixelset%settyp(jpset) = settyp1(ipset)
+ pixelset%ielm (jpset) = ielm1 (ipset)
+
+ IF (present(fracin)) THEN
+ fracout(jpset) = fracin(ipset) * pctshared(ishared,ipset)
+ ELSE
+ fracout(jpset) = pctshared(ishared,ipset)
+ ENDIF
+
+ sharedclass(jpset) = ishared
+ ENDIF
+ ENDDO
+ ENDIF
+ ELSE
+ jpset = jpset + 1
+ pixelset%eindex(jpset) = eindex1(ipset)
+ pixelset%ipxstt(jpset) = ipxstt1(ipset)
+ pixelset%ipxend(jpset) = ipxend1(ipset)
+ pixelset%settyp(jpset) = settyp1(ipset)
+ pixelset%ielm (jpset) = ielm1 (ipset)
+
+ IF (present(fracin)) THEN
+ fracout(jpset) = fracin(ipset)
+ ELSE
+ fracout(jpset) = 1.
+ ENDIF
+
+ sharedclass(jpset) = 0 ! no meaning
+ ENDIF
+ ENDDO
+
+ pixelset%nset = nsetshared
+
+ deallocate (eindex1)
+ deallocate (ipxstt1)
+ deallocate (ipxend1)
+ deallocate (settyp1)
+ deallocate (ielm1 )
+ deallocate (pctshared)
+
+ ENDIF
+
+ ENDIF
+
+ CALL pixelset%set_vecgs
+
+ END SUBROUTINE pixelsetshared_build
+
+END MODULE MOD_PixelsetShared
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_RangeCheck.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90
new file mode 100644
index 0000000000..e66c2dc779
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_RangeCheck.F90
@@ -0,0 +1,886 @@
+#include
+
+MODULE MOD_RangeCheck
+
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! Subroutines show the range of values in block data or vector data.
+!
+! Notice that:
+! 1. "check_block_data" can only be called by IO processes.
+! 2. "check_vector_data" can only be called by compute ranks.
+!
+! Created by Shupeng Zhang, May 2023
+!-----------------------------------------------------------------------
+
+#ifdef RangeCheck
+ USE MOD_UserDefFun, only: isnan_ud
+ IMPLICIT NONE
+
+ INTERFACE check_block_data
+ MODULE procedure check_block_data_real8_2d
+ END INTERFACE check_block_data
+
+ INTERFACE check_vector_data
+ MODULE procedure check_vector_data_real8_1d
+ MODULE procedure check_vector_data_real8_2d
+ MODULE procedure check_vector_data_real8_3d
+ MODULE procedure check_vector_data_real8_4d
+ MODULE procedure check_vector_data_real8_5d
+ MODULE procedure check_vector_data_int32_1d
+ END INTERFACE check_vector_data
+
+CONTAINS
+
+ ! ----------
+ SUBROUTINE check_block_data_real8_2d (varname, gdata, spv_in, limits)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Block
+ USE MOD_DataType
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: varname
+ type(block_data_real8_2d), intent(in) :: gdata
+ real(r8), intent(in), optional :: spv_in
+ real(r8), intent(in), optional :: limits(2)
+
+ ! Local variables
+ real(r8) :: gmin, gmax, spv
+ real(r8), allocatable :: gmin_all(:), gmax_all(:)
+ logical, allocatable :: msk2(:,:)
+ integer :: iblkme, ib, jb, ix, iy
+ logical :: has_nan
+ character(len=256) :: wfmt, exception, str_print
+
+ IF (p_is_active) THEN
+
+ IF (present(spv_in)) THEN
+ spv = spv_in
+ ELSE
+ spv = spval
+ ENDIF
+
+ gmin = spv
+ gmax = spv
+
+ has_nan = .false.
+ DO iblkme = 1, gblock%nblkme
+ ib = gblock%xblkme(iblkme)
+ jb = gblock%yblkme(iblkme)
+
+ IF (.not. allocated(gdata%blk(ib,jb)%val)) CYCLE
+
+ allocate(msk2 (size(gdata%blk(ib,jb)%val,1), size(gdata%blk(ib,jb)%val,2)))
+ msk2 = gdata%blk(ib,jb)%val /= spv
+
+ IF (any(msk2)) THEN
+ IF (gmin == spv) THEN
+ gmin = minval(gdata%blk(ib,jb)%val, mask = msk2)
+ ELSE
+ gmin = min(gmin, minval(gdata%blk(ib,jb)%val, mask = msk2))
+ ENDIF
+
+ IF (gmax == spv) THEN
+ gmax = maxval(gdata%blk(ib,jb)%val, mask = msk2)
+ ELSE
+ gmax = max(gmax, maxval(gdata%blk(ib,jb)%val, mask = msk2))
+ ENDIF
+ ENDIF
+
+ DO iy = 1, size(gdata%blk(ib,jb)%val,2)
+ DO ix = 1, size(gdata%blk(ib,jb)%val,1)
+ has_nan = has_nan .or. isnan_ud(gdata%blk(ib,jb)%val(ix,iy))
+ ENDDO
+ ENDDO
+
+ deallocate(msk2)
+
+ ENDDO
+
+#ifdef USEMPI
+ IF (p_iam_active == p_root) THEN
+ allocate (gmin_all (0:p_np_active-1))
+ allocate (gmax_all (0:p_np_active-1))
+ CALL mpi_gather (gmin, 1, MPI_REAL8, gmin_all, 1, MPI_REAL8, p_root, p_comm_active, p_err)
+ CALL mpi_gather (gmax, 1, MPI_REAL8, gmax_all, 1, MPI_REAL8, p_root, p_comm_active, p_err)
+ ELSE
+ CALL mpi_gather (gmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_active, p_err)
+ CALL mpi_gather (gmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_active, p_err)
+ ENDIF
+
+ CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+
+ IF (p_iam_active == p_root) THEN
+ IF (any(gmin_all /= spv)) THEN
+ gmin = minval(gmin_all, mask = (gmin_all /= spv))
+ ELSE
+ gmin = spv
+ ENDIF
+
+ IF (any(gmax_all /= spv)) THEN
+ gmax = maxval(gmax_all, mask = (gmax_all /= spv))
+ ELSE
+ gmax = spv
+ ENDIF
+
+ deallocate (gmin_all)
+ deallocate (gmax_all)
+ ENDIF
+#endif
+ IF (p_iam_active == p_root) THEN
+
+ exception = ''
+
+ IF (has_nan) THEN
+ exception = trim(exception) // ' with NAN'
+ ENDIF
+
+ IF (present(limits)) THEN
+ IF ((gmin < limits(1)) .or. (gmax > limits(2))) THEN
+ exception = trim(exception) // ' Out of Range!'
+ ENDIF
+ ENDIF
+
+ wfmt = "('Check block data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)"
+ write(str_print,wfmt) varname, gmin, gmax, trim(exception)
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+#endif
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_active(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_active(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+#endif
+
+ write(*,'(A)') trim(str_print)
+
+#if (defined CoLMDEBUG)
+ IF (len_trim(exception) > 0) THEN
+ CALL CoLM_stop ()
+ ENDIF
+#endif
+ ENDIF
+
+ END SUBROUTINE check_block_data_real8_2d
+
+
+ ! ----------
+ SUBROUTINE check_vector_data_real8_1d (varname, vdata, spv_in, limits)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: varname
+ real(r8), allocatable, intent(in) :: vdata(:)
+
+ real(r8), intent(in), optional :: spv_in
+ real(r8), intent(in), optional :: limits(2)
+
+ ! Local variables
+ real(r8) :: vmin, vmax, spv
+ real(r8), allocatable :: vmin_all(:), vmax_all(:)
+ integer :: i
+ logical :: has_nan
+ character(len=256) :: wfmt, exception, str_print
+
+ IF (p_is_compute) THEN
+
+ IF (present(spv_in)) THEN
+ spv = spv_in
+ ELSE
+ spv = spval
+ ENDIF
+
+ IF (allocated(vdata)) THEN
+ IF (any(vdata /= spv)) THEN
+ vmin = minval(vdata, mask = vdata /= spv)
+ vmax = maxval(vdata, mask = vdata /= spv)
+ ELSE
+ vmin = spv
+ vmax = spv
+ ENDIF
+
+ has_nan = .false.
+ DO i = lbound(vdata,1), ubound(vdata,1)
+ has_nan = has_nan .or. isnan_ud(vdata(i))
+ ENDDO
+ ELSE
+ vmin = spv; vmax = spv
+ has_nan = .false.
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_iam_compute == p_root) THEN
+ allocate (vmin_all (0:p_np_compute-1))
+ allocate (vmax_all (0:p_np_compute-1))
+ CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ELSE
+ CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ENDIF
+
+ CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err)
+
+ IF (p_iam_compute == p_root) THEN
+ IF (any(vmin_all /= spv)) THEN
+ vmin = minval(vmin_all, mask = (vmin_all /= spv))
+ ELSE
+ vmin = spv
+ ENDIF
+
+ IF (any(vmax_all /= spv)) THEN
+ vmax = maxval(vmax_all, mask = (vmax_all /= spv))
+ ELSE
+ vmax = spv
+ ENDIF
+
+ deallocate (vmin_all)
+ deallocate (vmax_all)
+ ENDIF
+#endif
+
+ IF (p_iam_compute == p_root) THEN
+
+ exception = ''
+
+ IF (has_nan) THEN
+ exception = trim(exception) // ' with NAN'
+ ENDIF
+
+ IF (present(limits)) THEN
+ IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN
+ exception = trim(exception) // ' Out of Range!'
+ ENDIF
+ ENDIF
+
+ wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)"
+ write(str_print,wfmt) varname, vmin, vmax, trim(exception)
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+#endif
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+#endif
+
+ write(*,'(A)') trim(str_print)
+
+#if (defined CoLMDEBUG)
+ IF (len_trim(exception) > 0) THEN
+ CALL CoLM_stop ()
+ ENDIF
+#endif
+ ENDIF
+
+ END SUBROUTINE check_vector_data_real8_1d
+
+ ! ----------
+ SUBROUTINE check_vector_data_real8_2d (varname, vdata, spv_in, limits)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: varname
+ real(r8), allocatable, intent(in) :: vdata(:,:)
+
+ real(r8), intent(in), optional :: spv_in
+ real(r8), intent(in), optional :: limits(2)
+
+ ! Local variables
+ real(r8) :: vmin, vmax, spv
+ real(r8), allocatable :: vmin_all(:), vmax_all(:)
+ integer :: i, j
+ logical :: has_nan
+ character(len=256) :: wfmt, exception, str_print
+
+ IF (p_is_compute) THEN
+
+ IF (present(spv_in)) THEN
+ spv = spv_in
+ ELSE
+ spv = spval
+ ENDIF
+
+ IF (allocated(vdata)) THEN
+ IF (any(vdata /= spv)) THEN
+ vmin = minval(vdata, mask = vdata /= spv)
+ vmax = maxval(vdata, mask = vdata /= spv)
+ ELSE
+ vmin = spv
+ vmax = spv
+ ENDIF
+
+ has_nan = .false.
+ DO j = lbound(vdata,2), ubound(vdata,2)
+ DO i = lbound(vdata,1), ubound(vdata,1)
+ has_nan = has_nan .or. isnan_ud(vdata(i,j))
+ ENDDO
+ ENDDO
+ ELSE
+ vmin = spv; vmax = spv
+ has_nan = .false.
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_iam_compute == p_root) THEN
+ allocate (vmin_all (0:p_np_compute-1))
+ allocate (vmax_all (0:p_np_compute-1))
+ CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ELSE
+ CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ENDIF
+
+ CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err)
+
+ IF (p_iam_compute == p_root) THEN
+ IF (any(vmin_all /= spv)) THEN
+ vmin = minval(vmin_all, mask = (vmin_all /= spv))
+ ELSE
+ vmin = spv
+ ENDIF
+
+ IF (any(vmax_all /= spv)) THEN
+ vmax = maxval(vmax_all, mask = (vmax_all /= spv))
+ ELSE
+ vmax = spv
+ ENDIF
+
+ deallocate (vmin_all)
+ deallocate (vmax_all)
+ ENDIF
+#endif
+
+ IF (p_iam_compute == p_root) THEN
+
+ exception = ''
+
+ IF (has_nan) THEN
+ exception = trim(exception) // ' with NAN'
+ ENDIF
+
+ IF (present(limits)) THEN
+ IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN
+ exception = trim(exception) // ' Out of Range!'
+ ENDIF
+ ENDIF
+
+ wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)"
+ write(str_print,wfmt) varname, vmin, vmax, trim(exception)
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+#endif
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+#endif
+
+ write(*,'(A)') trim(str_print)
+
+#if (defined CoLMDEBUG)
+ IF (len_trim(exception) > 0) THEN
+ CALL CoLM_stop ()
+ ENDIF
+#endif
+ ENDIF
+
+ END SUBROUTINE check_vector_data_real8_2d
+
+ ! ----------
+ SUBROUTINE check_vector_data_real8_3d (varname, vdata, spv_in, limits)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: varname
+ real(r8), allocatable, intent(in) :: vdata(:,:,:)
+
+ real(r8), intent(in), optional :: spv_in
+ real(r8), intent(in), optional :: limits(2)
+
+ ! Local variables
+ real(r8) :: vmin, vmax, spv
+ real(r8), allocatable :: vmin_all(:), vmax_all(:)
+ integer :: i, j, k
+ logical :: has_nan
+ character(len=256) :: wfmt, exception, str_print
+
+ IF (p_is_compute) THEN
+
+ IF (present(spv_in)) THEN
+ spv = spv_in
+ ELSE
+ spv = spval
+ ENDIF
+
+ IF (allocated(vdata)) THEN
+ IF (any(vdata /= spv)) THEN
+ vmin = minval(vdata, mask = vdata /= spv)
+ vmax = maxval(vdata, mask = vdata /= spv)
+ ELSE
+ vmin = spv
+ vmax = spv
+ ENDIF
+
+ has_nan = .false.
+ DO k = lbound(vdata,3), ubound(vdata,3)
+ DO j = lbound(vdata,2), ubound(vdata,2)
+ DO i = lbound(vdata,1), ubound(vdata,1)
+ has_nan = has_nan .or. isnan_ud(vdata(i,j,k))
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ vmin = spv; vmax = spv
+ has_nan = .false.
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_iam_compute == p_root) THEN
+ allocate (vmin_all (0:p_np_compute-1))
+ allocate (vmax_all (0:p_np_compute-1))
+ CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ELSE
+ CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ENDIF
+
+
+ CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err)
+
+ IF (p_iam_compute == p_root) THEN
+ IF (any(vmin_all /= spv)) THEN
+ vmin = minval(vmin_all, mask = (vmin_all /= spv))
+ ELSE
+ vmin = spv
+ ENDIF
+
+ IF (any(vmax_all /= spv)) THEN
+ vmax = maxval(vmax_all, mask = (vmax_all /= spv))
+ ELSE
+ vmax = spv
+ ENDIF
+
+ deallocate (vmin_all)
+ deallocate (vmax_all)
+ ENDIF
+#endif
+
+ IF (p_iam_compute == p_root) THEN
+
+ exception = ''
+
+ IF (has_nan) THEN
+ exception = trim(exception) // ' with NAN'
+ ENDIF
+
+ IF (present(limits)) THEN
+ IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN
+ exception = trim(exception) // ' Out of Range!'
+ ENDIF
+ ENDIF
+
+ wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)"
+ write(str_print,wfmt) varname, vmin, vmax, trim(exception)
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+#endif
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+#endif
+
+ write(*,'(A)') trim(str_print)
+
+#if (defined CoLMDEBUG)
+ IF (len_trim(exception) > 0) THEN
+ CALL CoLM_stop ()
+ ENDIF
+#endif
+ ENDIF
+
+ END SUBROUTINE check_vector_data_real8_3d
+
+ ! ----------
+ SUBROUTINE check_vector_data_real8_4d (varname, vdata, spv_in, limits)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Vars_Global, only: spval
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: varname
+ real(r8), allocatable, intent(in) :: vdata(:,:,:,:)
+
+ real(r8), intent(in), optional :: spv_in
+ real(r8), intent(in), optional :: limits(2)
+
+ ! Local variables
+ real(r8) :: vmin, vmax, spv
+ real(r8), allocatable :: vmin_all(:), vmax_all(:)
+ integer :: i, j, k, l
+ logical :: has_nan
+ character(len=256) :: wfmt, exception, str_print
+
+ IF (p_is_compute) THEN
+
+ IF (present(spv_in)) THEN
+ spv = spv_in
+ ELSE
+ spv = spval
+ ENDIF
+
+ IF (allocated(vdata)) THEN
+ IF (any(vdata /= spv)) THEN
+ vmin = minval(vdata, mask = vdata /= spv)
+ vmax = maxval(vdata, mask = vdata /= spv)
+ ELSE
+ vmin = spv
+ vmax = spv
+ ENDIF
+
+ has_nan = .false.
+ DO l = lbound(vdata,4), ubound(vdata,4)
+ DO k = lbound(vdata,3), ubound(vdata,3)
+ DO j = lbound(vdata,2), ubound(vdata,2)
+ DO i = lbound(vdata,1), ubound(vdata,1)
+ has_nan = has_nan .or. isnan_ud(vdata(i,j,k,l))
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ vmin = spv; vmax = spv
+ has_nan = .false.
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_iam_compute == p_root) THEN
+ allocate (vmin_all (0:p_np_compute-1))
+ allocate (vmax_all (0:p_np_compute-1))
+ CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ELSE
+ CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ENDIF
+
+
+ CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err)
+
+ IF (p_iam_compute == p_root) THEN
+ IF (any(vmin_all /= spv)) THEN
+ vmin = minval(vmin_all, mask = (vmin_all /= spv))
+ ELSE
+ vmin = spv
+ ENDIF
+
+ IF (any(vmax_all /= spv)) THEN
+ vmax = maxval(vmax_all, mask = (vmax_all /= spv))
+ ELSE
+ vmax = spv
+ ENDIF
+
+ deallocate (vmin_all)
+ deallocate (vmax_all)
+ ENDIF
+#endif
+
+ IF (p_iam_compute == p_root) THEN
+
+ exception = ''
+
+ IF (has_nan) THEN
+ exception = trim(exception) // ' with NAN'
+ ENDIF
+
+ IF (present(limits)) THEN
+ IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN
+ exception = trim(exception) // ' Out of Range!'
+ ENDIF
+ ENDIF
+
+ wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)"
+ write(str_print,wfmt) varname, vmin, vmax, trim(exception)
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_send (exception, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+ CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+#endif
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_recv (exception, 256, MPI_CHARACTER, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+#endif
+
+ write(*,'(A)') trim(str_print)
+
+#if (defined CoLMDEBUG)
+ IF (len_trim(exception) > 0) THEN
+ CALL CoLM_stop ()
+ ENDIF
+#endif
+ ENDIF
+
+ END SUBROUTINE check_vector_data_real8_4d
+
+
+ ! ----------
+ SUBROUTINE check_vector_data_real8_5d (varname, vdata, spv_in, limits)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ USE MOD_Vars_Global, only : spval
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: varname
+ real(r8), intent(in) :: vdata(:,:,:,:,:)
+ real(r8), intent(in), optional :: spv_in
+ real(r8), intent(in), optional :: limits(2)
+
+ ! Local variables
+ real(r8) :: vmin, vmax, spv
+ real(r8), allocatable :: vmin_all(:), vmax_all(:)
+ integer :: i, j, k, l, m
+ logical :: has_nan
+ character(len=256) :: wfmt, ss, info
+
+ IF (p_is_compute) THEN
+
+ IF (present(spv_in)) THEN
+ spv = spv_in
+ ELSE
+ spv = spval
+ ENDIF
+
+ IF (any(vdata /= spv)) THEN
+ vmin = minval(vdata, mask = vdata /= spv)
+ vmax = maxval(vdata, mask = vdata /= spv)
+ ELSE
+ vmin = spv
+ vmax = spv
+ ENDIF
+
+ has_nan = .false.
+ DO m = 1, size(vdata,5)
+ DO l = 1, size(vdata,4)
+ DO k = 1, size(vdata,3)
+ DO j = 1, size(vdata,2)
+ DO i = 1, size(vdata,1)
+ has_nan = has_nan .or. isnan_ud(vdata(i,j,k,l,m))
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+
+#ifdef USEMPI
+ IF (p_iam_compute == p_root) THEN
+ allocate (vmin_all (0:p_np_compute-1))
+ allocate (vmax_all (0:p_np_compute-1))
+ CALL mpi_gather (vmin, 1, MPI_REAL8, vmin_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, vmax_all, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ELSE
+ CALL mpi_gather (vmin, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_REAL8, MPI_RNULL_P, 1, MPI_REAL8, p_root, p_comm_compute, p_err)
+ ENDIF
+
+
+ CALL mpi_allreduce (MPI_IN_PLACE, has_nan, 1, MPI_LOGICAL, MPI_LOR, p_comm_compute, p_err)
+
+ IF (p_iam_compute == p_root) THEN
+ IF (any(vmin_all /= spv)) THEN
+ vmin = minval(vmin_all, mask = (vmin_all /= spv))
+ ELSE
+ vmin = spv
+ ENDIF
+
+ IF (any(vmax_all /= spv)) THEN
+ vmax = maxval(vmax_all, mask = (vmax_all /= spv))
+ ELSE
+ vmax = spv
+ ENDIF
+
+ deallocate (vmin_all)
+ deallocate (vmax_all)
+ ENDIF
+#endif
+
+ IF (p_iam_compute == p_root) THEN
+
+ info = ''
+
+ IF (has_nan) THEN
+ info = trim(info) // ' with NAN'
+ ENDIF
+
+ IF (present(limits)) THEN
+ IF ((vmin < limits(1)) .or. (vmax > limits(2))) THEN
+ info = trim(info) // ' Out of Range!'
+ ENDIF
+ ENDIF
+
+ wfmt = "('Check vector data:', A25, ' is in (', e20.10, ',', e20.10, ')', A)"
+ write(*,wfmt) varname, vmin, vmax, info
+
+#if(defined CoLMDEBUG)
+ IF (len_trim(info) > 0) THEN
+ CALL CoLM_stop ()
+ ENDIF
+#endif
+
+ ENDIF
+
+ ENDIF
+
+ END SUBROUTINE check_vector_data_real8_5d
+
+
+ ! ----------
+ SUBROUTINE check_vector_data_int32_1d (varname, vdata, spv_in)
+
+ USE MOD_Precision
+ USE MOD_SPMD_Task
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: varname
+ integer, allocatable, intent(in) :: vdata(:)
+
+ integer, intent(in), optional :: spv_in
+
+ ! Local variables
+ integer :: vmin, vmax
+ logical :: isnull
+ logical, allocatable :: null_all(:)
+ integer, allocatable :: vmin_all(:), vmax_all(:)
+ character(len=256) :: wfmt, str_print
+
+ IF (p_is_compute) THEN
+
+ isnull = .not. allocated(vdata)
+
+ IF (.not. isnull) THEN
+ IF (present(spv_in)) THEN
+ IF (any(vdata /= spv_in)) THEN
+ vmin = minval(vdata, mask = vdata /= spv_in)
+ vmax = maxval(vdata, mask = vdata /= spv_in)
+ ELSE
+ vmin = spv_in
+ vmax = spv_in
+ ENDIF
+ ELSE
+ vmin = minval(vdata)
+ vmax = maxval(vdata)
+ ENDIF
+ ENDIF
+
+#ifdef USEMPI
+ IF (p_iam_compute == p_root) THEN
+ allocate (null_all (0:p_np_compute-1))
+ allocate (vmin_all (0:p_np_compute-1))
+ allocate (vmax_all (0:p_np_compute-1))
+ CALL mpi_gather (isnull, 1, MPI_LOGICAL, null_all, 1, MPI_LOGICAL, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmin, 1, MPI_INTEGER, vmin_all, 1, MPI_INTEGER, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_INTEGER, vmax_all, 1, MPI_INTEGER, p_root, p_comm_compute, p_err)
+ ELSE
+ CALL mpi_gather (isnull, 1, MPI_LOGICAL, MPI_LNULL_P, 1, MPI_LOGICAL, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmin, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_compute, p_err)
+ CALL mpi_gather (vmax, 1, MPI_INTEGER, MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_compute, p_err)
+ ENDIF
+
+ IF (p_iam_compute == p_root) THEN
+ IF (present(spv_in)) THEN
+ null_all = null_all .and. (vmin_all == spv_in)
+ ENDIF
+
+ vmin = minval(vmin_all, mask = .not. null_all)
+ vmax = maxval(vmax_all, mask = .not. null_all)
+
+ deallocate (null_all)
+ deallocate (vmin_all)
+ deallocate (vmax_all)
+ ENDIF
+#endif
+
+ IF (p_iam_compute == p_root) THEN
+ wfmt = "('Check vector data:', A25, ' is in (', I20, ',', I20, ')')"
+ write(str_print,wfmt) varname, vmin, vmax
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_send (str_print, 256, MPI_CHARACTER, p_address_root, &
+ mpi_tag_mesg, p_comm_glb, p_err)
+#endif
+ ENDIF
+ ENDIF
+
+ IF (p_is_root) THEN
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ CALL mpi_recv (str_print, 256, MPI_CHARACTER, p_address_compute(p_root), &
+ mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+#endif
+ write(*,'(A)') trim(str_print)
+ ENDIF
+
+ END SUBROUTINE check_vector_data_int32_1d
+
+#endif
+
+END MODULE MOD_RangeCheck
diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90
new file mode 100644
index 0000000000..f14cd1c143
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SPMD_Task.F90
@@ -0,0 +1,212 @@
+#include
+
+MODULE MOD_SPMD_Task
+
+!-----------------------------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! SPMD refers to "Single PROGRAM/Multiple Data" parallelization.
+!
+! MPAS owns MPI initialization and decomposition. Every MPAS rank stays active
+! as a CoLM compute rank, with rank 0 used only for logging/error aggregation.
+!
+! 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 MOD_Precision
+ IMPLICIT NONE
+
+ include 'mpif.h'
+
+ integer, parameter :: p_root = 0
+
+ logical :: p_is_root = .false.
+ logical :: p_is_active = .false.
+ logical :: p_is_compute = .false.
+ logical :: p_is_history_task = .false.
+
+ integer :: p_comm_glb_plus = MPI_COMM_NULL
+ integer :: p_iam_glb_plus = -1
+
+ ! MPAS-owned communicator aliases used by legacy CoLM helper APIs.
+ integer :: p_comm_glb = MPI_COMM_NULL
+ integer :: p_iam_glb = -1
+ integer :: p_np_glb = 0
+
+ integer :: p_comm_group = MPI_COMM_NULL
+ integer :: p_iam_group = -1
+ integer :: p_np_group = 0
+
+ integer :: p_my_group = 0
+ integer :: p_address_root = p_root
+
+ integer :: p_comm_active = MPI_COMM_NULL
+ integer :: p_iam_active = -1
+ integer :: p_np_active = 0
+
+ integer, allocatable :: p_itis_active (:)
+ integer, allocatable :: p_address_active (:)
+
+ integer :: p_comm_compute = MPI_COMM_NULL
+ integer :: p_iam_compute = -1
+ integer :: p_np_compute = 0
+
+ integer, allocatable :: p_itis_compute (:)
+ integer, allocatable :: p_address_compute (:)
+
+ integer :: p_address_history_task = -1
+
+ integer :: p_stat (MPI_STATUS_SIZE)
+ integer :: p_err = 0
+
+ integer, PUBLIC, parameter :: mpi_tag_size = 1
+ integer, PUBLIC, parameter :: mpi_tag_mesg = 2
+ integer, PUBLIC, parameter :: mpi_tag_data = 3
+
+ integer :: MPI_INULL_P(1)
+ logical :: MPI_LNULL_P(1)
+ real(r8) :: MPI_RNULL_P(1)
+
+ integer, parameter :: MesgMaxSize = 4194304 ! 4MB
+
+ PUBLIC :: spmd_init
+ PUBLIC :: spmd_exit
+ PUBLIC :: divide_processes_into_groups
+ PUBLIC :: spmd_assign_history_task
+
+CONTAINS
+
+ !-----------------------------------------
+ SUBROUTINE spmd_init (MyComm_r)
+
+ IMPLICIT NONE
+ integer, intent(in), optional :: MyComm_r
+ logical mpi_inited
+ integer :: iproc
+
+ CALL MPI_INITIALIZED (mpi_inited, p_err)
+
+ IF ( .not. mpi_inited ) THEN
+ CALL mpi_init (p_err)
+ ENDIF
+
+ IF (present(MyComm_r)) THEN
+ CALL MPI_Comm_dup (MyComm_r, p_comm_glb, p_err)
+ ELSE
+ CALL MPI_Comm_dup (MPI_COMM_WORLD, p_comm_glb, p_err)
+ ENDIF
+
+ CALL mpi_comm_rank (p_comm_glb, p_iam_glb, p_err)
+ CALL mpi_comm_size (p_comm_glb, p_np_glb, p_err)
+
+ p_address_root = p_root
+ p_is_root = (p_iam_glb == p_address_root)
+ p_is_active = .true.
+ p_is_compute = .true.
+ p_is_history_task = .false.
+
+ p_comm_group = p_comm_glb
+ p_iam_group = p_iam_glb
+ p_np_group = p_np_glb
+ p_my_group = 0
+
+ p_comm_active = p_comm_glb
+ p_iam_active = p_iam_glb
+ p_np_active = p_np_glb
+
+ p_comm_compute = p_comm_glb
+ p_iam_compute = p_iam_glb
+ p_np_compute = p_np_glb
+
+ p_comm_glb_plus = MPI_COMM_NULL
+ p_iam_glb_plus = -1
+ p_address_history_task = -1
+
+ IF (allocated(p_itis_active )) deallocate (p_itis_active )
+ IF (allocated(p_address_active )) deallocate (p_address_active )
+ IF (allocated(p_itis_compute )) deallocate (p_itis_compute )
+ IF (allocated(p_address_compute)) deallocate (p_address_compute)
+
+ allocate (p_itis_active (0:p_np_glb-1))
+ allocate (p_address_active (0:p_np_glb-1))
+ allocate (p_itis_compute (0:p_np_glb-1))
+ allocate (p_address_compute (0:p_np_glb-1))
+
+ DO iproc = 0, p_np_glb-1
+ p_itis_active(iproc) = iproc
+ p_address_active(iproc) = iproc
+ p_itis_compute(iproc) = iproc
+ p_address_compute(iproc) = iproc
+ ENDDO
+
+ END SUBROUTINE spmd_init
+
+ !-----------------------------------------
+ SUBROUTINE divide_processes_into_groups (ngrp)
+
+ IMPLICIT NONE
+ integer, intent(in) :: ngrp
+
+ IF (ngrp <= 0) THEN
+ CALL mpi_abort (p_comm_glb, 1, p_err)
+ ENDIF
+
+ ! MPAS owns the process decomposition. Keep every MPAS rank active.
+ p_comm_group = p_comm_glb
+ p_iam_group = p_iam_glb
+ p_np_group = p_np_glb
+ p_my_group = 0
+
+ END SUBROUTINE divide_processes_into_groups
+
+ !-----------------------------------------
+ SUBROUTINE spmd_exit
+
+ IF (allocated(p_itis_active )) deallocate (p_itis_active )
+ IF (allocated(p_address_active )) deallocate (p_address_active )
+ IF (allocated(p_itis_compute )) deallocate (p_itis_compute )
+ IF (allocated(p_address_compute)) deallocate (p_address_compute)
+
+ IF (p_comm_glb /= MPI_COMM_NULL) THEN
+ CALL mpi_barrier (p_comm_glb, p_err)
+ CALL MPI_Comm_free (p_comm_glb, p_err)
+ ENDIF
+
+ p_comm_glb = MPI_COMM_NULL
+ p_comm_group = MPI_COMM_NULL
+ p_comm_active = MPI_COMM_NULL
+ p_comm_compute = MPI_COMM_NULL
+
+ END SUBROUTINE spmd_exit
+
+ ! ----- -----
+ SUBROUTINE spmd_assign_history_task ()
+
+ IMPLICIT NONE
+
+ CALL CoLM_stop('MPAS embedded CoLM does not support a dedicated history MPI task.')
+
+ END SUBROUTINE spmd_assign_history_task
+
+ ! -- STOP all processes --
+ SUBROUTINE CoLM_stop (mesg)
+
+ IMPLICIT NONE
+ character(len=*), optional :: mesg
+ logical :: mpi_inited
+
+ IF (present(mesg)) write(*,*) trim(mesg)
+
+ CALL MPI_INITIALIZED (mpi_inited, p_err)
+ IF (mpi_inited .and. p_comm_glb /= MPI_COMM_NULL) THEN
+ CALL mpi_abort (p_comm_glb, 1, p_err)
+ ENDIF
+
+ STOP
+
+ END SUBROUTINE CoLM_stop
+
+END MODULE MOD_SPMD_Task
diff --git a/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90 b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90
new file mode 100644
index 0000000000..80de18fdf7
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SingleSrfdata.F90
@@ -0,0 +1,3472 @@
+#include
+
+#ifdef SinglePoint
+MODULE MOD_SingleSrfdata
+!-----------------------------------------------------------------------
+! !DESCRIPTION:
+!
+! This module includes subroutines to read or write surface data for
+! "SinglePoint".
+!
+! Created by Shupeng Zhang, May 2023
+!-----------------------------------------------------------------------
+
+ USE MOD_Precision, only: r8
+ USE MOD_Vars_Global
+ USE MOD_Const_LC
+ USE MOD_Namelist
+ USE MOD_SPMD_Task
+ IMPLICIT NONE
+ SAVE
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ integer, allocatable :: SITE_pfttyp (:)
+ real(r8), allocatable :: SITE_pctpfts (:)
+#endif
+
+#ifdef CROP
+ integer, allocatable :: SITE_croptyp (:)
+ real(r8), allocatable :: SITE_pctcrop (:)
+#endif
+
+ real(r8) :: SITE_htop
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ real(r8), allocatable :: SITE_htop_pfts (:)
+#endif
+
+ real(r8), allocatable :: SITE_LAI_monthly (:,:)
+ real(r8), allocatable :: SITE_SAI_monthly (:,:)
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ real(r8), allocatable :: SITE_LAI_pfts_monthly (:,:,:)
+ real(r8), allocatable :: SITE_SAI_pfts_monthly (:,:,:)
+#endif
+
+ integer, allocatable :: SITE_LAI_year (:)
+ real(r8), allocatable :: SITE_LAI_8day (:,:)
+
+ real(r8) :: SITE_lakedepth = 1.
+
+ real(r8) :: SITE_soil_s_v_alb
+ real(r8) :: SITE_soil_d_v_alb
+ real(r8) :: SITE_soil_s_n_alb
+ real(r8) :: SITE_soil_d_n_alb
+
+ real(r8), allocatable :: SITE_soil_vf_quartz_mineral (:)
+ real(r8), allocatable :: SITE_soil_vf_gravels (:)
+ real(r8), allocatable :: SITE_soil_vf_sand (:)
+ real(r8), allocatable :: SITE_soil_vf_clay (:)
+ real(r8), allocatable :: SITE_soil_vf_om (:)
+ real(r8), allocatable :: SITE_soil_wf_gravels (:)
+ real(r8), allocatable :: SITE_soil_wf_sand (:)
+ real(r8), allocatable :: SITE_soil_wf_clay (:)
+ real(r8), allocatable :: SITE_soil_wf_om (:)
+ real(r8), allocatable :: SITE_soil_OM_density (:)
+ real(r8), allocatable :: SITE_soil_BD_all (:)
+ real(r8), allocatable :: SITE_soil_theta_s (:)
+ real(r8), allocatable :: SITE_soil_k_s (:)
+ real(r8), allocatable :: SITE_soil_csol (:)
+ real(r8), allocatable :: SITE_soil_tksatu (:)
+ real(r8), allocatable :: SITE_soil_tksatf (:)
+ real(r8), allocatable :: SITE_soil_tkdry (:)
+ real(r8), allocatable :: SITE_soil_k_solids (:)
+ real(r8), allocatable :: SITE_soil_psi_s (:)
+ real(r8), allocatable :: SITE_soil_lambda (:)
+ real(r8), allocatable :: SITE_soil_theta_r (:)
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ real(r8), allocatable :: SITE_soil_alpha_vgm (:)
+ real(r8), allocatable :: SITE_soil_L_vgm (:)
+ real(r8), allocatable :: SITE_soil_n_vgm (:)
+#endif
+ real(r8), allocatable :: SITE_soil_BA_alpha (:)
+ real(r8), allocatable :: SITE_soil_BA_beta (:)
+
+ integer :: SITE_soil_texture
+
+ real(r8) :: SITE_dbedrock = 0.
+
+ real(r8) :: SITE_elevation = 0.
+ real(r8) :: SITE_elvstd = 0.
+ real(r8) :: SITE_sloperatio = 0.
+
+ ! topography factors used for downscaling
+ real(r8) :: SITE_svf = 0.
+ real(r8) :: SITE_cur = 0.
+ real(r8), allocatable :: SITE_slp_type (:)
+ real(r8), allocatable :: SITE_asp_type (:)
+ real(r8), allocatable :: SITE_area_type(:)
+ real(r8), allocatable :: SITE_sf_lut (:,:)
+
+ logical :: u_site_landtype, u_site_crop, u_site_pfts, u_site_htop, &
+ u_site_lai, u_site_lakedepth, u_site_soil_bright, u_site_vf_quartz_mineral, &
+ u_site_vf_gravels, u_site_vf_sand, u_site_vf_clay, u_site_vf_om, &
+ u_site_wf_gravels, u_site_wf_sand, u_site_wf_clay, u_site_wf_om, &
+ u_site_OM_density, u_site_BD_all, u_site_theta_s, u_site_k_s, &
+ u_site_csol, u_site_tksatu, u_site_tksatf, u_site_tkdry, &
+ u_site_k_solids, u_site_psi_s, u_site_lambda, u_site_theta_r, &
+ u_site_alpha_vgm, u_site_L_vgm, u_site_n_vgm, u_site_BA_alpha, &
+ u_site_BA_beta, u_site_soil_texture, u_site_dbedrock, u_site_elevation, &
+ u_site_elvstd, u_site_svf, u_site_cur, u_site_slp_type, &
+ u_site_asp_type, u_site_area_type, u_site_sf_lut, u_site_sloperatio
+
+
+ integer :: SITE_ncar_rid
+ integer :: SITE_urbtyp
+
+ real(r8) :: SITE_lucyid
+
+ real(r8) :: SITE_fveg_urb
+ real(r8) :: SITE_htop_urb
+ real(r8) :: SITE_flake_urb
+ real(r8) :: SITE_froof
+ real(r8) :: SITE_hroof
+ real(r8) :: SITE_fgimp
+ real(r8) :: SITE_fgper
+ real(r8) :: SITE_hlr
+ real(r8) :: SITE_lambdaw
+ real(r8) :: SITE_popden
+
+ real(r8) :: SITE_em_roof
+ real(r8) :: SITE_em_wall
+ real(r8) :: SITE_em_gimp
+ real(r8) :: SITE_em_gper
+ real(r8) :: SITE_t_roommax
+ real(r8) :: SITE_t_roommin
+
+ real(r8) :: SITE_thickroof
+ real(r8) :: SITE_thickwall
+
+ real(r8), allocatable :: SITE_cv_roof (:)
+ real(r8), allocatable :: SITE_cv_wall (:)
+ real(r8), allocatable :: SITE_cv_gimp (:)
+ real(r8), allocatable :: SITE_tk_roof (:)
+ real(r8), allocatable :: SITE_tk_wall (:)
+ real(r8), allocatable :: SITE_tk_gimp (:)
+
+ real(r8), allocatable :: SITE_alb_roof (:,:)
+ real(r8), allocatable :: SITE_alb_wall (:,:)
+ real(r8), allocatable :: SITE_alb_gimp (:,:)
+ real(r8), allocatable :: SITE_alb_gper (:,:)
+
+ logical :: u_site_froof, u_site_hroof, u_site_fgper , u_site_hlr , &
+ u_site_fveg , u_site_htopu, u_site_urblai , u_site_urbsai , &
+ u_site_flake, u_site_utype, &
+ u_site_albr , u_site_albw , u_site_albgimp, u_site_albgper, &
+ u_site_emr , u_site_emw , u_site_emgimp , u_site_emgper , &
+ u_site_cvr , u_site_cvw , u_site_cvgimp , &
+ u_site_tkr , u_site_tkw , u_site_tkgimp , &
+ u_site_tbmax, u_site_tbmin, u_site_thickr , u_site_thickw , &
+ u_site_pop , u_site_lucy
+
+ ! -----------------------------------------------------------------------------------
+ ! The soil color and reflectance is from the work:
+ ! Peter J. Lawrence and Thomas N. Chase, 2007:
+ ! Representing a MODIS consistent land surface in the Community Land Model (CLM 3.0):
+ ! Part 1 generating MODIS consistent land surface parameters
+ ! -----------------------------------------------------------------------------------
+ real(r8), parameter :: soil_s_v_refl(20) = & ! Saturated visible soil reflectance
+ (/ 0.26, 0.24, 0.22, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15, 0.14, &
+ 0.13, 0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.04 /)
+ real(r8), parameter :: soil_d_v_refl(20) = & ! Dry visible soil reflectance
+ (/ 0.37, 0.35, 0.33, 0.31, 0.30, 0.29, 0.28, 0.27, 0.26, 0.25, &
+ 0.24, 0.23, 0.22, 0.21, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15 /)
+ real(r8), parameter :: soil_s_n_refl(20) = & ! Saturated near infrared soil reflectance
+ (/ 0.52, 0.48, 0.44, 0.40, 0.38, 0.36, 0.34, 0.32, 0.30, 0.28, &
+ 0.26, 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.08 /)
+ real(r8), parameter :: soil_d_n_refl(20) = & ! Dry near infrared soil reflectance
+ (/ 0.63, 0.59, 0.55, 0.51, 0.49, 0.47, 0.45, 0.43, 0.41, 0.39, &
+ 0.37, 0.35, 0.33, 0.31, 0.29, 0.27, 0.25, 0.23, 0.21, 0.19 /)
+
+CONTAINS
+
+
+!-----------------------------------------------------------------------
+ SUBROUTINE read_surface_data_single (fsrfdata, for_surface_build)
+
+ USE MOD_TimeManager
+ USE MOD_Grid
+ USE MOD_Block
+ USE MOD_NetCDFSerial
+ USE MOD_NetCDFPoint
+ USE MOD_Namelist
+ USE MOD_Utils
+ USE MOD_Vars_Global, only: PI
+ USE MOD_Const_LC
+ USE MOD_Const_PFT
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ USE MOD_LandPFT
+#endif
+ USE MOD_Mesh, only: numelm
+ USE MOD_LandElm
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: fsrfdata
+ logical, intent(in) :: for_surface_build
+
+ ! Local Variables
+ real(r8) :: lat_in, lon_in
+ real(r8) :: LAI, lakedepth, slp, asp, zenith_angle
+ integer :: i, isc, nsl, typ, a, z, arraysize
+ integer :: iyear, idate(3), simulation_lai_year_start, simulation_lai_year_end
+ integer :: start_year, end_year, ntime, itime
+
+ character(len=256) :: filename, dir_5x5, fmt_str
+ character(len=4) :: cyear, c
+
+ type(grid_type) :: gridpatch, gridcrop, gridpft, gridhtop, gridlai, gridlake, &
+ gridbright, gridsoil, gridrock, gridtopo, grid_topo_factor
+
+ integer, allocatable :: croptyp(:), pfttyp (:)
+ real(r8), allocatable :: pctcrop(:), pctpfts(:), pftLAI(:), pftSAI(:), tea_f(:), tea_b(:)
+
+ integer, parameter :: N_PFT_modis = 16
+ logical :: readflag
+
+ CALL Init_GlobalVars
+ CALL Init_LC_Const
+
+ IF (for_surface_build) THEN
+ write(*,*)
+ write(*,*) ' ---------------- Make Single Point Surface Data ---------------- '
+ ENDIF
+
+ IF (ncio_var_exist(fsrfdata, 'latitude')) THEN
+ CALL ncio_read_serial (fsrfdata, 'latitude', lat_in)
+ IF ((lat_in /= SITE_lat_location) .and. (SITE_lat_location /= -1.e36_r8)) THEN
+ write(*,*) 'Warning: Latitude mismatch: ', &
+ lat_in, ' in data file and ', SITE_lat_location, 'in namelist.'
+ ENDIF
+ SITE_lat_location = lat_in
+ ENDIF
+
+ IF (ncio_var_exist(fsrfdata, 'longitude')) THEN
+ CALL ncio_read_serial (fsrfdata, 'longitude', lon_in)
+ IF ((lon_in /= SITE_lon_location) .and. (SITE_lon_location /= -1.e36_r8)) THEN
+ write(*,*) 'Warning: Longitude mismatch: ', &
+ lon_in, ' in data file and ', SITE_lon_location, 'in namelist.'
+ ENDIF
+ SITE_lon_location = lon_in
+ ENDIF
+
+ CALL normalize_longitude (SITE_lon_location)
+
+ IF (.not. isgreenwich) THEN
+ LocalLongitude = SITE_lon_location
+ ENDIF
+
+ IF (for_surface_build) THEN
+ write(*,'(A,F8.2)') 'Latitude : ', SITE_lat_location
+ write(*,'(A,F8.2)') 'Longitude : ', SITE_lon_location
+ ENDIF
+
+
+ DEF_domain%edges = floor(SITE_lat_location)
+ DEF_domain%edgen = floor(SITE_lat_location) + 1.
+ DEF_domain%edgew = floor(SITE_lon_location)
+ DEF_domain%edgee = floor(SITE_lon_location) + 1.
+
+ CALL gblock%set ()
+ gblock%nblkme = 1
+ allocate(gblock%xblkme(1))
+ allocate(gblock%yblkme(1))
+ gblock%xblkme(1) = find_nearest_west (SITE_lon_location, gblock%nxblk, gblock%lon_w)
+ gblock%yblkme(1) = find_nearest_south (SITE_lat_location, gblock%nyblk, gblock%lat_s)
+
+
+ ! (1) build/read "land patch" by using land cover type data
+ numpatch = 1
+
+#ifdef LULC_USGS
+ u_site_landtype = (.not. for_surface_build) .or. (SITE_landtype >= 0) &
+ .or. (USE_SITE_landtype .and. ncio_var_exist(fsrfdata,'USGS_classification'))
+
+ IF (u_site_landtype) THEN
+ IF (SITE_landtype == -1) THEN
+ CALL ncio_read_serial (fsrfdata, 'USGS_classification', SITE_landtype)
+ ENDIF
+ ELSE
+ CALL gridpatch%define_by_name ('colm_1km')
+ filename = trim(DEF_dir_rawdata)//'/landtypes/landtype-usgs-update.nc'
+ CALL read_point_var_2d_int32 (gridpatch, filename, 'landtype', &
+ SITE_lon_location, SITE_lat_location, SITE_landtype)
+ ENDIF
+#else
+ u_site_landtype = (.not. for_surface_build) .or. (SITE_landtype >= 0) &
+ .or. (USE_SITE_landtype .and. ncio_var_exist(fsrfdata,'IGBP_classification'))
+
+ IF (u_site_landtype) THEN
+ IF (SITE_landtype == -1) THEN
+ CALL ncio_read_serial (fsrfdata, 'IGBP_classification', SITE_landtype)
+ ENDIF
+ ELSE
+ CALL gridpatch%define_by_name ('colm_500m')
+ write(cyear,'(i4.4)') DEF_LC_YEAR
+ filename = trim(DEF_dir_rawdata)//'landtypes/landtype-igbp-modis-'//trim(cyear)//'.nc'
+ CALL read_point_var_2d_int32 (gridpatch, filename, 'landtype', &
+ SITE_lon_location, SITE_lat_location, SITE_landtype)
+ ENDIF
+#endif
+
+ IF (SITE_landtype < 0) THEN
+ write(*,*) 'Error! Please set SITE_landtype in namelist file !'
+ CALL CoLM_stop()
+ ENDIF
+
+#ifdef URBAN_MODEL
+ IF (SITE_landtype /= URBAN) THEN
+ write(*,*) 'Error! Please set SITE_landtype to URBAN in namelist file !'
+ CALL CoLM_stop()
+ ENDIF
+#endif
+
+ IF (for_surface_build) THEN
+ write(*,'(A,A,3A)') 'Land cover type : ', trim(patchclassname(SITE_landtype)), &
+ ' (from ',trim(datasource(u_site_landtype)),')'
+ ENDIF
+
+ ! (2) build/read "land crop" by using crop data
+#ifdef CROP
+ IF (SITE_landtype == CROPLAND) THEN
+
+ readflag = ((.not. for_surface_build) .or. USE_SITE_pctcrop)
+ u_site_crop = readflag &
+ .and. ncio_var_exist(fsrfdata,'croptyp',readflag) .and. ncio_var_exist(fsrfdata,'pctcrop',readflag)
+
+ IF (u_site_crop) THEN
+ CALL ncio_read_serial (fsrfdata, 'croptyp', croptyp)
+ CALL ncio_read_serial (fsrfdata, 'pctcrop', pctcrop)
+ ELSE
+ allocate (croptyp (N_CFT))
+ croptyp = (/(i, i = 1, N_CFT)/)
+
+ filename = trim(DEF_dir_rawdata) // '/global_CFT_surface_data.nc'
+ CALL gridcrop%define_from_file (filename, 'lat', 'lon')
+ CALL read_point_var_3d_first_real8 (gridcrop, filename, 'PCT_CFT', &
+ SITE_lon_location, SITE_lat_location, N_CFT, pctcrop)
+ ENDIF
+
+ numpatch = count(pctcrop > 0.)
+
+ IF (numpatch == 0) THEN
+ write(*,*) 'There is no crop at this point!'
+ CALL CoLM_stop()
+ ENDIF
+
+ allocate (SITE_croptyp (numpatch))
+ allocate (SITE_pctcrop (numpatch))
+
+ SITE_croptyp = pack(croptyp, pctcrop > 0.)
+ SITE_pctcrop = pack(pctcrop, pctcrop > 0.) / sum(pctcrop)
+
+ IF (for_surface_build) THEN
+ write(c,'(I0)') numpatch
+ write(*,'(A,'//trim(c)//'I5,3A)') 'crop type : ', SITE_croptyp, ' (from ',trim(datasource(u_site_crop)),')'
+ write(*,'(A,'//trim(c)//'F5.2,3A)') 'crop frac : ', SITE_pctcrop, ' (from ',trim(datasource(u_site_crop)),')'
+ ENDIF
+
+ ENDIF
+#endif
+
+
+ ! (3) build/read "land pft" or "land pc" by using plant functional type data
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+#ifndef CROP
+ IF (patchtypes(SITE_landtype) == 0) THEN
+#else
+ IF (patchtypes(SITE_landtype) == 0 .and. SITE_landtype /= CROPLAND) THEN
+#endif
+ readflag = ((.not. for_surface_build) .or. USE_SITE_pctpfts)
+ u_site_pfts = readflag &
+ .and. ncio_var_exist(fsrfdata,'pfttyp',readflag) .and. ncio_var_exist(fsrfdata,'pctpfts',readflag)
+
+ IF (u_site_pfts) THEN
+ CALL ncio_read_serial (fsrfdata, 'pfttyp', pfttyp )
+ CALL ncio_read_serial (fsrfdata, 'pctpfts', pctpfts)
+ ELSE
+ allocate (pfttyp (N_PFT_modis))
+ pfttyp = (/(i, i = 0, N_PFT_modis-1)/)
+
+ CALL gridpft%define_by_name ('colm_500m')
+
+ dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s'
+ write(cyear,'(i4.4)') DEF_LC_YEAR
+ CALL read_point_5x5_var_3d_real8 (gridpft, dir_5x5, 'MOD'//trim(cyear), 'PCT_PFT', &
+ SITE_lon_location, SITE_lat_location, N_PFT_modis, pctpfts)
+ ENDIF
+
+ numpft = count(pctpfts > 0.)
+
+ allocate (SITE_pfttyp (numpft))
+ allocate (SITE_pctpfts (numpft))
+
+ SITE_pfttyp = pack(pfttyp, pctpfts > 0.)
+ SITE_pctpfts = pack(pctpfts, pctpfts > 0.) / sum(pctpfts)
+
+#ifdef CROP
+ ELSEIF (SITE_landtype == CROPLAND) THEN
+ u_site_pfts = .false.
+ numpft = numpatch
+ allocate (SITE_pfttyp (numpft))
+ allocate (SITE_pctpfts (numpft))
+ SITE_pfttyp = SITE_croptyp + N_PFT - 1
+ SITE_pctpfts = 1.
+#endif
+ ELSE
+ numpft = 0
+ ENDIF
+
+ IF ((patchtypes(SITE_landtype) == 0) .and. (numpft == 0)) THEN
+ write(*,*) 'Warning : There is no plant functional type at this site ! '
+ CALL CoLM_stop()
+ ENDIF
+
+ IF (for_surface_build) THEN
+ IF (numpft > 0) THEN
+ write(*,'(4A)') 'PFT type and fraction : ', ' (from ',trim(datasource(u_site_pfts)),')'
+ DO i = 1, numpft
+ write(*,'(A,F5.2)') ' '//trim(pftclassname(SITE_pfttyp(i))), SITE_pctpfts(i)
+ ENDDO
+ ENDIF
+ ENDIF
+
+#endif
+
+
+ ! (4) forest height
+ readflag = (.not. for_surface_build) .or. USE_SITE_htop
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (patchtypes(SITE_landtype) == 0) THEN
+ u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height_pfts',readflag)
+ ELSE
+ u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height',readflag)
+ ENDIF
+#else
+ u_site_htop = readflag .and. ncio_var_exist(fsrfdata,'canopy_height',readflag)
+#endif
+
+ IF (u_site_htop) THEN
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (patchtypes(SITE_landtype) == 0) THEN
+ CALL ncio_read_serial (fsrfdata, 'canopy_height_pfts', SITE_htop_pfts)
+ ELSE
+ CALL ncio_read_serial (fsrfdata, 'canopy_height', SITE_htop)
+ ENDIF
+#else
+ CALL ncio_read_serial (fsrfdata, 'canopy_height', SITE_htop)
+#endif
+ ELSE
+#ifdef LULC_USGS
+ CALL gridhtop%define_by_name ('colm_1km')
+ filename = trim(DEF_dir_rawdata)//'/Forest_Height.nc'
+ CALL read_point_var_2d_real8 (gridhtop, filename, 'forest_height', &
+ SITE_lon_location, SITE_lat_location, SITE_htop)
+#else
+
+ CALL gridhtop%define_by_name ('colm_500m')
+
+ dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s'
+ write(cyear,'(i4.4)') DEF_LC_YEAR
+ CALL read_point_5x5_var_2d_real8 (gridhtop, dir_5x5, 'MOD'//trim(cyear), 'HTOP', &
+ SITE_lon_location, SITE_lat_location, SITE_htop)
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (numpft > 0) THEN
+ allocate (SITE_htop_pfts (numpft))
+ SITE_htop_pfts(:) = SITE_htop
+ ENDIF
+#endif
+#endif
+ ENDIF
+
+ IF (for_surface_build) THEN
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (patchtypes(SITE_landtype) == 0) THEN
+ arraysize = size(SITE_htop_pfts)
+ write(fmt_str, '("(A,", I0, "F8.2,3A)")') arraysize
+ write(*,fmt_str) 'Forest height : ', SITE_htop_pfts, ' (from ',trim(datasource(u_site_htop)),')'
+ ELSE
+ write(*,'(A,F8.2,3A)') 'Forest height : ', SITE_htop, ' (from ',trim(datasource(u_site_htop)),')'
+ ENDIF
+#else
+ write(*,'(A,F8.2,3A)') 'Forest height : ', SITE_htop, ' (from ',trim(datasource(u_site_htop)),')'
+#endif
+ ENDIF
+
+
+ ! (5) LAI
+ readflag = ((.not. for_surface_build) .or. USE_SITE_LAI)
+ readflag = readflag .and. ncio_var_exist(fsrfdata,'LAI_year',readflag)
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (patchtypes(SITE_landtype) == 0) THEN
+ u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_pfts_monthly',readflag) &
+ .and. ncio_var_exist(fsrfdata,'SAI_pfts_monthly',readflag)
+ ELSE
+ u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_monthly',readflag) &
+ .and. ncio_var_exist(fsrfdata,'SAI_monthly',readflag)
+ ENDIF
+#else
+ IF (DEF_LAI_MONTHLY) THEN
+ u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_monthly',readflag) &
+ .and. ncio_var_exist(fsrfdata,'SAI_monthly',readflag)
+ ELSE
+ u_site_lai = readflag .and. ncio_var_exist(fsrfdata,'LAI_8day',readflag)
+ ENDIF
+#endif
+
+ IF (u_site_lai) THEN
+ CALL ncio_read_serial (fsrfdata, 'LAI_year', SITE_LAI_year)
+ start_year = 1
+ end_year = size(SITE_LAI_year)
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (patchtypes(SITE_landtype) == 0) THEN
+ CALL ncio_read_serial (fsrfdata, 'LAI_pfts_monthly', SITE_LAI_pfts_monthly)
+ CALL ncio_read_serial (fsrfdata, 'SAI_pfts_monthly', SITE_SAI_pfts_monthly)
+ ntime = size(SITE_LAI_pfts_monthly,2)
+ ELSE
+ CALL ncio_read_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly)
+ CALL ncio_read_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly)
+ ntime = size(SITE_LAI_monthly,1)
+ ENDIF
+#else
+ IF (DEF_LAI_MONTHLY) THEN
+ CALL ncio_read_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly)
+ CALL ncio_read_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly)
+ ntime = size(SITE_LAI_monthly,1)
+ ELSE
+ CALL ncio_read_serial (fsrfdata, 'LAI_8day', SITE_LAI_8day)
+ ntime = size(SITE_LAI_8day,1)
+ ENDIF
+#endif
+ ELSE
+
+ idate(1) = DEF_simulation_time%start_year
+ IF (.not. isgreenwich) THEN
+ idate(3) = DEF_simulation_time%start_sec
+ CALL monthday2julian (idate(1), &
+ DEF_simulation_time%start_month, DEF_simulation_time%start_day, idate(2))
+ CALL localtime2gmt(idate)
+ ENDIF
+
+ simulation_lai_year_start = idate(1)
+
+ idate(1) = DEF_simulation_time%end_year
+ IF (.not. isgreenwich) THEN
+ idate(3) = DEF_simulation_time%end_sec
+ CALL monthday2julian (idate(1), &
+ DEF_simulation_time%end_month, DEF_simulation_time%end_day, idate(2))
+ CALL localtime2gmt(idate)
+ ENDIF
+
+ simulation_lai_year_end = idate(1)
+
+ IF (DEF_LAI_CHANGE_YEARLY) THEN
+ start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR )
+ start_year = min(start_year, DEF_LAI_END_YEAR )
+ end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR )
+ end_year = max(end_year, DEF_LAI_START_YEAR )
+ ELSE
+ start_year = DEF_LC_YEAR
+ end_year = DEF_LC_YEAR
+ ENDIF
+
+ allocate (SITE_LAI_year (start_year:end_year))
+ SITE_LAI_year = (/(iyear, iyear = start_year, end_year)/)
+
+ IF (DEF_LAI_MONTHLY) THEN
+ ntime = 12
+ allocate (SITE_LAI_monthly (12,start_year:end_year))
+ allocate (SITE_SAI_monthly (12,start_year:end_year))
+ ELSE
+ ntime = 46
+ allocate (SITE_LAI_8day (46,start_year:end_year))
+ ENDIF
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (numpft > 0) THEN
+ allocate (SITE_LAI_pfts_monthly (numpft,12,start_year:end_year))
+ allocate (SITE_SAI_pfts_monthly (numpft,12,start_year:end_year))
+ ENDIF
+#endif
+
+ CALL gridlai%define_by_name ('colm_500m')
+
+ DO iyear = start_year, end_year
+
+ write(cyear,'(i4.4)') iyear
+
+ DO itime = 1, ntime
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+
+ dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s'
+ CALL read_point_5x5_var_3d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), 'MONTHLY_PFT_LAI', &
+ SITE_lon_location, SITE_lat_location, N_PFT_modis, itime, pftLAI)
+ CALL read_point_5x5_var_3d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), 'MONTHLY_PFT_SAI', &
+ SITE_lon_location, SITE_lat_location, N_PFT_modis, itime, pftSAI)
+
+#ifndef CROP
+ IF (patchtypes(SITE_landtype) == 0) THEN
+#else
+ IF (patchtypes(SITE_landtype) == 0 .and. SITE_landtype /= CROPLAND) THEN
+#endif
+ IF (allocated(pctpfts)) deallocate (pctpfts)
+ allocate(pctpfts (0:N_PFT_modis-1)); pctpfts(:) = 0.
+ pctpfts(SITE_pfttyp) = SITE_pctpfts
+
+ SITE_LAI_pfts_monthly(:,itime,iyear) = pack(pftLAI, pctpfts > 0.)
+ SITE_SAI_pfts_monthly(:,itime,iyear) = pack(pftSAI, pctpfts > 0.)
+#ifdef CROP
+ ELSEIF (SITE_landtype == CROPLAND) THEN
+ CALL read_point_5x5_var_3d_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), 'PCT_PFT', &
+ SITE_lon_location, SITE_lat_location, N_PFT_modis, pctpfts)
+ SITE_LAI_pfts_monthly(:,itime,iyear) = sum(pftLAI * pctpfts) / sum(pctpfts)
+ SITE_SAI_pfts_monthly(:,itime,iyear) = sum(pftSAI * pctpfts) / sum(pctpfts)
+#endif
+ ELSE
+ dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s'
+ CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), &
+ 'MONTHLY_LC_LAI', SITE_lon_location, SITE_lat_location, itime, &
+ SITE_LAI_monthly(itime,iyear))
+ CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), &
+ 'MONTHLY_LC_SAI', SITE_lon_location, SITE_lat_location, itime, &
+ SITE_SAI_monthly(itime,iyear))
+ ENDIF
+
+#else
+ IF (DEF_LAI_MONTHLY) THEN
+ dir_5x5 = trim(DEF_dir_rawdata) // '/plant_15s'
+ CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), &
+ 'MONTHLY_LC_LAI', SITE_lon_location, SITE_lat_location, itime, &
+ SITE_LAI_monthly(itime,iyear))
+ CALL read_point_5x5_var_2d_time_real8 (gridlai, dir_5x5, 'MOD'//trim(cyear), &
+ 'MONTHLY_LC_SAI', SITE_lon_location, SITE_lat_location, itime, &
+ SITE_SAI_monthly(itime,iyear))
+ ELSE
+ filename = trim(DEF_dir_rawdata)//'/lai_15s_8day/lai_8-day_15s_'//trim(cyear)//'.nc'
+ CALL read_point_var_2d_time_real8 (gridlai, filename, 'lai', &
+ SITE_lon_location, SITE_lat_location, itime, LAI)
+ SITE_LAI_8day(itime,iyear) = LAI * 0.1
+ ENDIF
+#endif
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF (for_surface_build) THEN
+ DO iyear = start_year, end_year
+ write(c,'(i2)') ntime
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (patchtypes(SITE_landtype) == 0) THEN
+ DO i = 1, numpft
+ write(*,'(A,I4,A,I2,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), &
+ ', pft ', SITE_pfttyp(i),') : ', SITE_LAI_pfts_monthly(i,:,iyear), &
+ ' (from ',trim(datasource(u_site_lai)),')'
+ write(*,'(A,I4,A,I2,A,'//trim(c)//'F8.2,4A)') 'SAI (year ', SITE_LAI_year(iyear), &
+ ', pft ', SITE_pfttyp(i),') : ', SITE_SAI_pfts_monthly(i,:,iyear), &
+ ' (from ',trim(datasource(u_site_lai)),')'
+ ENDDO
+ ELSE
+ write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), ') : ', &
+ SITE_LAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')'
+ write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'SAI (year ', SITE_LAI_year(iyear), ') : ', &
+ SITE_SAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')'
+ ENDIF
+#else
+ IF (DEF_LAI_MONTHLY) THEN
+ write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), ') : ', &
+ SITE_LAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')'
+ write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'SAI (year ', SITE_LAI_year(iyear), ') : ', &
+ SITE_SAI_monthly(:,iyear), ' (from ',trim(datasource(u_site_lai)),')'
+ ELSE
+ write(*,'(A,I4,A,'//trim(c)//'F8.2,4A)') 'LAI (year ', SITE_LAI_year(iyear), ') : ', &
+ SITE_LAI_8day(:,iyear), ' (from ',trim(datasource(u_site_lai)),')'
+ ENDIF
+#endif
+ ENDDO
+ ENDIF
+
+
+ ! (6) lake depth
+ readflag = ((.not. for_surface_build) .or. USE_SITE_lakedepth)
+ u_site_lakedepth = readflag .and. ncio_var_exist(fsrfdata,'lakedepth',readflag)
+
+ IF (u_site_lakedepth) THEN
+ CALL ncio_read_serial (fsrfdata, 'lakedepth', SITE_lakedepth)
+ ELSE
+ CALL gridlake%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/lake_depth.nc'
+ CALL read_point_var_2d_real8 (gridlake, filename, 'lake_depth', &
+ SITE_lon_location, SITE_lat_location, lakedepth)
+ SITE_lakedepth = lakedepth * 0.1
+ ENDIF
+
+ IF (for_surface_build) THEN
+ write(*,'(A,F8.2,3A)') 'Lake depth : ', SITE_lakedepth, ' (from ',trim(datasource(u_site_lakedepth)),')'
+ ENDIF
+
+
+ ! (7) soil brightness parameters
+ readflag = ((.not. for_surface_build) .or. USE_SITE_soilreflectance)
+ u_site_soil_bright = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_s_v_alb',readflag) &
+ .and. ncio_var_exist(fsrfdata,'soil_d_v_alb',readflag) &
+ .and. ncio_var_exist(fsrfdata,'soil_s_n_alb',readflag) &
+ .and. ncio_var_exist(fsrfdata,'soil_d_n_alb',readflag)
+
+ IF (u_site_soil_bright) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb)
+ CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb)
+ CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb)
+ CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb)
+ ELSE
+ SITE_soil_s_v_alb = spval
+ SITE_soil_d_v_alb = spval
+ SITE_soil_s_n_alb = spval
+ SITE_soil_d_n_alb = spval
+
+ CALL gridbright%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/soil_brightness.nc'
+ CALL read_point_var_2d_int32 (gridbright, filename, 'soil_brightness', &
+ SITE_lon_location, SITE_lat_location, isc)
+
+#ifdef LULC_USGS
+ IF(SITE_landtype /= 16 .and. SITE_landtype /= 24)THEN ! NOT WATER BODIES(16)/GLACIER and ICESHEET(24)
+#else
+ IF(SITE_landtype /= 17 .and. SITE_landtype /= 15)THEN ! NOT WATER BODIES(17)/GLACIER and ICE SHEET(15)
+#endif
+ IF ((isc >= 1) .and. (isc <= 20)) THEN
+ SITE_soil_s_v_alb = soil_s_v_refl( isc )
+ SITE_soil_d_v_alb = soil_d_v_refl( isc )
+ SITE_soil_s_n_alb = soil_s_n_refl( isc )
+ SITE_soil_d_n_alb = soil_d_n_refl( isc )
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (for_surface_build) THEN
+ write(*,'(A,F8.2,3A)') 'Soil brightness s_v : ', SITE_soil_s_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')'
+ write(*,'(A,F8.2,3A)') 'Soil brightness d_v : ', SITE_soil_d_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')'
+ write(*,'(A,F8.2,3A)') 'Soil brightness s_n : ', SITE_soil_s_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')'
+ write(*,'(A,F8.2,3A)') 'Soil brightness d_n : ', SITE_soil_d_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')'
+ ENDIF
+
+
+ ! (8) soil parameters
+
+ CALL gridsoil%define_by_name ('colm_500m')
+
+ readflag = ((.not. for_surface_build) .or. USE_SITE_soilparameters)
+ u_site_vf_quartz_mineral = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_vf_quartz_mineral',readflag)
+ IF (u_site_vf_quartz_mineral) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral)
+ ELSE
+ allocate (SITE_soil_vf_quartz_mineral (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_quartz_mineral_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_quartz_mineral_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_quartz_mineral(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_vf_gravels = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_vf_gravels',readflag)
+ IF (u_site_vf_gravels) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels)
+ ELSE
+ allocate (SITE_soil_vf_gravels (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_gravels_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_gravels_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_gravels(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_vf_sand = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_vf_sand',readflag)
+ IF (u_site_vf_sand) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand)
+ ELSE
+ allocate (SITE_soil_vf_sand (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_sand_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_sand_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_sand(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_vf_clay = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_vf_clay',readflag)
+ IF (u_site_vf_clay) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay)
+ ELSE
+ allocate (SITE_soil_vf_clay (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_clay_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_clay_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_clay(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_vf_om = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_vf_om',readflag)
+ IF (u_site_vf_om) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om)
+ ELSE
+ allocate (SITE_soil_vf_om (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_om_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_om_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_om(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_wf_gravels = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_wf_gravels',readflag)
+ IF (u_site_wf_gravels) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels)
+ ELSE
+ allocate (SITE_soil_wf_gravels (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/wf_gravels_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_gravels_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_wf_gravels(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_wf_sand = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_wf_sand',readflag)
+ IF (u_site_wf_sand) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand)
+ ELSE
+ allocate (SITE_soil_wf_sand (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/wf_sand_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_sand_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_wf_sand(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_wf_clay = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_wf_clay',readflag)
+ IF (u_site_wf_clay) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay)
+ ELSE
+ allocate (SITE_soil_wf_clay (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/wf_clay_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_clay_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_wf_clay(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_wf_om = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_wf_om',readflag)
+ IF (u_site_wf_om) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om)
+ ELSE
+ allocate (SITE_soil_wf_om (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/wf_om_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_om_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_wf_om(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_OM_density = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_OM_density',readflag)
+ IF (u_site_OM_density) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density)
+ ELSE
+ allocate (SITE_soil_OM_density (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/OM_density_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'OM_density_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_OM_density(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_BD_all = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_BD_all',readflag)
+ IF (u_site_BD_all) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all)
+ ELSE
+ allocate (SITE_soil_BD_all (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/BD_all_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'BD_all_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_BD_all(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_theta_s = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_theta_s',readflag)
+ IF (u_site_theta_s) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s)
+ ELSE
+ allocate (SITE_soil_theta_s (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/theta_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'theta_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_theta_s(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_k_s = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_k_s',readflag)
+ IF (u_site_k_s) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s)
+ ELSE
+ allocate (SITE_soil_k_s (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/k_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'k_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_k_s(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_csol = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_csol',readflag)
+ IF (u_site_csol) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_csol', SITE_soil_csol)
+ ELSE
+ allocate (SITE_soil_csol (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/csol.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'csol_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_csol(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_tksatu = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_tksatu',readflag)
+ IF (u_site_tksatu) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu)
+ ELSE
+ allocate (SITE_soil_tksatu (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/tksatu.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatu_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_tksatu(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_tksatf = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_tksatf',readflag)
+ IF (u_site_tksatf) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf)
+ ELSE
+ allocate (SITE_soil_tksatf (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/tksatf.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatf_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_tksatf(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_tkdry = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_tkdry',readflag)
+ IF (u_site_tkdry) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry)
+ ELSE
+ allocate (SITE_soil_tkdry (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/tkdry.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'tkdry_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_tkdry(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_k_solids = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_k_solids',readflag)
+ IF (u_site_k_solids) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids)
+ ELSE
+ allocate (SITE_soil_k_solids (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/k_solids.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'k_solids_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_k_solids(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_psi_s = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_psi_s',readflag)
+ IF (u_site_psi_s) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s)
+ ELSE
+ allocate (SITE_soil_psi_s (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/psi_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'psi_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_psi_s(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_lambda = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_lambda',readflag)
+ IF (u_site_lambda) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda)
+ ELSE
+ allocate (SITE_soil_lambda (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/lambda.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'lambda_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_lambda(nsl))
+ ENDDO
+ ENDIF
+
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ u_site_theta_r = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_theta_r',readflag)
+ IF (u_site_theta_r) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r)
+ ELSE
+ allocate (SITE_soil_theta_r (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/VGM_theta_r.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_theta_r_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_theta_r(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_alpha_vgm = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_alpha_vgm',readflag)
+ IF (u_site_alpha_vgm) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm)
+ ELSE
+ allocate (SITE_soil_alpha_vgm (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/VGM_alpha.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_alpha_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_alpha_vgm(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_L_vgm = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_L_vgm',readflag)
+ IF (u_site_L_vgm) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm)
+ ELSE
+ allocate (SITE_soil_L_vgm (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/VGM_L.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_L_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_L_vgm(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_n_vgm = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_n_vgm',readflag)
+ IF (u_site_n_vgm) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm)
+ ELSE
+ allocate (SITE_soil_n_vgm (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/VGM_n.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_n_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_n_vgm(nsl))
+ ENDDO
+ ENDIF
+#endif
+
+ u_site_BA_alpha = u_site_vf_gravels .and. u_site_vf_sand
+ u_site_BA_beta = u_site_vf_gravels .and. u_site_vf_sand
+ allocate (SITE_soil_BA_alpha (8))
+ allocate (SITE_soil_BA_beta (8))
+ DO nsl = 1, 8
+ IF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.4) THEN
+ SITE_soil_BA_alpha(nsl) = 0.38
+ SITE_soil_BA_beta (nsl) = 35.0
+ ELSEIF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.25) THEN
+ SITE_soil_BA_alpha(nsl) = 0.24
+ SITE_soil_BA_beta (nsl) = 26.0
+ ELSE
+ SITE_soil_BA_alpha(nsl) = 0.20
+ SITE_soil_BA_beta (nsl) = 10.0
+ ENDIF
+ ENDDO
+
+
+ IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC
+ u_site_soil_texture = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_texture',readflag)
+ IF (u_site_soil_texture) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_texture', SITE_soil_texture)
+ ELSE
+ filename = trim(DEF_dir_rawdata)//'/soil/soiltexture_0cm-60cm_mean.nc'
+ CALL read_point_var_2d_int32 (gridsoil, filename, 'soiltexture', &
+ SITE_lon_location, SITE_lat_location, SITE_soil_texture)
+ ENDIF
+ ENDIF
+
+ IF (for_surface_build) THEN
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_quartz_mineral : ', SITE_soil_vf_quartz_mineral(1:8), ' (from ',trim(datasource(u_site_vf_quartz_mineral)),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_gravels : ', SITE_soil_vf_gravels (1:8), ' (from ',trim(datasource(u_site_vf_gravels )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_sand : ', SITE_soil_vf_sand (1:8), ' (from ',trim(datasource(u_site_vf_sand )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_clay : ', SITE_soil_vf_clay (1:8), ' (from ',trim(datasource(u_site_vf_clay )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_om : ', SITE_soil_vf_om (1:8), ' (from ',trim(datasource(u_site_vf_om )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_wf_gravels : ', SITE_soil_wf_gravels (1:8), ' (from ',trim(datasource(u_site_wf_gravels )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_wf_sand : ', SITE_soil_wf_sand (1:8), ' (from ',trim(datasource(u_site_wf_sand )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_wf_clay : ', SITE_soil_wf_clay (1:8), ' (from ',trim(datasource(u_site_wf_clay )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_wf_om : ', SITE_soil_wf_om (1:8), ' (from ',trim(datasource(u_site_wf_om )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_OM_density : ', SITE_soil_OM_density (1:8), ' (from ',trim(datasource(u_site_OM_density )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_BD_all : ', SITE_soil_BD_all (1:8), ' (from ',trim(datasource(u_site_BD_all )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_theta_s : ', SITE_soil_theta_s (1:8), ' (from ',trim(datasource(u_site_theta_s )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_k_s : ', SITE_soil_k_s (1:8), ' (from ',trim(datasource(u_site_k_s )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_csol : ', SITE_soil_csol (1:8), ' (from ',trim(datasource(u_site_csol )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_tksatu : ', SITE_soil_tksatu (1:8), ' (from ',trim(datasource(u_site_tksatu )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_tksatf : ', SITE_soil_tksatf (1:8), ' (from ',trim(datasource(u_site_tksatf )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_tkdry : ', SITE_soil_tkdry (1:8), ' (from ',trim(datasource(u_site_tkdry )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_k_solids : ', SITE_soil_k_solids (1:8), ' (from ',trim(datasource(u_site_k_solids )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_psi_s : ', SITE_soil_psi_s (1:8), ' (from ',trim(datasource(u_site_psi_s )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_lambda : ', SITE_soil_lambda (1:8), ' (from ',trim(datasource(u_site_lambda )),')'
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ write(*,'(A,8ES10.2,3A)') 'soil_theta_r : ', SITE_soil_theta_r (1:8), ' (from ',trim(datasource(u_site_theta_r )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_alpha_vgm : ', SITE_soil_alpha_vgm (1:8), ' (from ',trim(datasource(u_site_alpha_vgm )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_L_vgm : ', SITE_soil_L_vgm (1:8), ' (from ',trim(datasource(u_site_L_vgm )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_n_vgm : ', SITE_soil_n_vgm (1:8), ' (from ',trim(datasource(u_site_n_vgm )),')'
+#endif
+ write(*,'(A,8ES10.2,3A)') 'soil_BA_alpha : ', SITE_soil_BA_alpha (1:8), ' (from ',trim(datasource(u_site_BA_alpha )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_BA_beta : ', SITE_soil_BA_beta (1:8), ' (from ',trim(datasource(u_site_BA_beta )),')'
+
+ IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC
+ write(*,'(A,I3,3A)') 'soil texture : ', SITE_soil_texture, ' (from ',trim(datasource(u_site_soil_texture)),')'
+ ENDIF
+ ENDIF
+
+
+ ! (9) depth to bedrock
+ IF (DEF_USE_BEDROCK) THEN
+ readflag = ((.not. for_surface_build) .or. USE_SITE_dbedrock)
+ u_site_dbedrock = readflag &
+ .and. ncio_var_exist (fsrfdata, 'depth_to_bedrock',readflag)
+ IF (u_site_dbedrock) THEN
+ CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock)
+ ELSE
+ CALL gridrock%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/bedrock.nc'
+ CALL read_point_var_2d_real8 (gridrock, filename, 'dbedrock', &
+ SITE_lon_location, SITE_lat_location, SITE_dbedrock)
+ ENDIF
+
+ IF (for_surface_build) THEN
+ write(*,'(A,F8.2,3A)') 'Depth to bedrock : ', SITE_dbedrock, ' (from ',trim(datasource(u_site_dbedrock)),')'
+ ENDIF
+
+ ENDIF
+
+ ! (10) topography
+ readflag = ((.not. for_surface_build) .or. USE_SITE_topography)
+
+ u_site_elevation = readflag &
+ .and. ncio_var_exist (fsrfdata, 'elevation',readflag)
+ IF (u_site_elevation) THEN
+ CALL ncio_read_serial (fsrfdata, 'elevation', SITE_elevation)
+ ELSE
+ CALL gridtopo%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/topography.nc'
+ CALL read_point_var_2d_real8 (gridtopo, filename, 'elevation', &
+ SITE_lon_location, SITE_lat_location, SITE_elevation)
+ ENDIF
+
+ u_site_elvstd = readflag &
+ .and. ncio_var_exist (fsrfdata, 'elvstd',readflag)
+ IF (u_site_elvstd) THEN
+ CALL ncio_read_serial (fsrfdata, 'elvstd', SITE_elvstd)
+ ELSE
+ CALL gridtopo%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/topography.nc'
+ CALL read_point_var_2d_real8 (gridtopo, filename, 'elvstd', &
+ SITE_lon_location, SITE_lat_location, SITE_elvstd)
+ ENDIF
+
+ u_site_sloperatio = readflag &
+ .and. ncio_var_exist (fsrfdata, 'sloperatio',readflag)
+ IF (u_site_sloperatio) THEN
+ CALL ncio_read_serial (fsrfdata, 'sloperatio', SITE_sloperatio)
+ ELSE
+ CALL gridtopo%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/topography.nc'
+ CALL read_point_var_2d_real8 (gridtopo, filename, 'slope', &
+ SITE_lon_location, SITE_lat_location, SITE_sloperatio)
+ ENDIF
+
+ IF (DEF_USE_Forcing_Downscaling) THEN
+
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc"
+ IF (ncio_var_exist(filename,'lat') .and. ncio_var_exist(filename,'lon')) THEN
+ CALL grid_topo_factor%define_from_file (filename, "lat", "lon")
+ ENDIF
+
+ u_site_svf = readflag &
+ .and. ncio_var_exist (fsrfdata, 'SITE_svf',readflag)
+ IF (u_site_svf) THEN
+ CALL ncio_read_serial (fsrfdata, 'SITE_svf' , SITE_svf)
+ ELSE
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/sky_view_factor.nc"
+ CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'svf', &
+ SITE_lon_location, SITE_lat_location, SITE_svf)
+ ENDIF
+
+ u_site_cur = readflag &
+ .and. ncio_var_exist (fsrfdata, 'SITE_cur',readflag)
+ IF (u_site_cur) THEN
+ CALL ncio_read_serial (fsrfdata, 'SITE_cur' , SITE_cur)
+ ELSE
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/curvature.nc"
+ CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'curvature', &
+ SITE_lon_location, SITE_lat_location, SITE_cur)
+ ENDIF
+
+ u_site_slp_type = readflag &
+ .and. ncio_var_exist (fsrfdata, 'SITE_slp_type', readflag) &
+ .and. ncio_var_exist (fsrfdata, 'SITE_asp_type', readflag) &
+ .and. ncio_var_exist (fsrfdata, 'SITE_area_type',readflag)
+ u_site_asp_type = u_site_slp_type
+ u_site_area_type = u_site_slp_type
+
+ IF (u_site_slp_type) THEN
+ CALL ncio_read_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type )
+ CALL ncio_read_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type )
+ CALL ncio_read_serial (fsrfdata, 'SITE_area_type', SITE_area_type )
+ ELSE
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc"
+ CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'slope', &
+ SITE_lon_location, SITE_lat_location, slp)
+
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/aspect.nc"
+ CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'aspect', &
+ SITE_lon_location, SITE_lat_location, asp)
+
+ allocate (SITE_slp_type (num_slope_type)); SITE_slp_type (:) = 0.
+ allocate (SITE_asp_type (num_slope_type)); SITE_asp_type (:) = 0.
+ allocate (SITE_area_type (num_slope_type)); SITE_area_type(:) = 0.
+
+ IF ((asp.ge.0 .and. asp.le.90*pi/180) .or. (asp.ge.270*pi/180 .and. asp.le.360*pi/180)) THEN
+ IF ((slp.ge.15*pi/180)) THEN ! north abrupt slope
+ typ = 1
+ ELSE ! north gentle slope
+ typ = 2
+ ENDIF
+ ELSE
+ IF ((slp.ge.15*pi/180)) THEN ! south abrupt slope
+ typ = 3
+ ELSE ! south gentle slope
+ typ = 4
+ ENDIF
+ ENDIF
+
+ SITE_slp_type (typ) = slp
+ SITE_asp_type (typ) = asp
+ SITE_area_type(typ) = 1.
+
+ ENDIF
+
+ u_site_sf_lut = readflag &
+ .and. ncio_var_exist (fsrfdata, 'SITE_sf_lut',readflag)
+ IF (u_site_sf_lut) THEN
+ CALL ncio_read_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut)
+ ELSE
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_front.nc"
+ CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_front', &
+ SITE_lon_location, SITE_lat_location, num_azimuth, tea_f)
+
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_back.nc"
+ CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_back', &
+ SITE_lon_location, SITE_lat_location, num_azimuth, tea_b)
+
+ allocate (SITE_sf_lut (num_azimuth, num_zenith))
+
+ DO a = 1, num_azimuth
+
+ tea_f(a) = asin(max(min(tea_f(a),1.),-1.))
+ tea_b(a) = asin(max(min(tea_b(a),1.),-1.))
+
+ IF (tea_f(a) <= tea_b(a)) tea_f(a) = tea_b(a) + 0.001
+
+ DO z = 1, num_zenith
+ zenith_angle = pi/(2*num_zenith)*(z-1)
+
+ IF (pi*0.5 - zenith_angle < tea_b(a)) THEN
+ SITE_sf_lut(a,z) = 0
+ ELSE IF (pi*0.5 - zenith_angle > tea_f(a)) THEN
+ SITE_sf_lut(a,z) = 1
+ ELSE
+ SITE_sf_lut(a,z) = (0.5*pi - zenith_angle - tea_b(a))/(tea_f(a) - tea_b(a))
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+ IF (for_surface_build) THEN
+ write(*,'(A,F8.2,3A)') 'Elevation : ', SITE_elevation , ' (from ',trim(datasource(u_site_elevation)),')'
+ write(*,'(A,F8.2,3A)') 'Elv std : ', SITE_elvstd , ' (from ',trim(datasource(u_site_elvstd)),')'
+ write(*,'(A,F8.2,3A)') 'SlopeRatio: ', SITE_sloperatio, ' (from ',trim(datasource(u_site_sloperatio)),')'
+
+ IF (DEF_USE_Forcing_Downscaling) THEN
+ write(*,'(A,F8.2,3A)') 'Sky view factor : ', SITE_svf, ' (from ',trim(datasource(u_site_svf)),')'
+ write(*,'(A,F8.2,3A)') 'Curvature : ', SITE_cur, ' (from ',trim(datasource(u_site_cur)),')'
+ write(c,'(I0)') num_slope_type
+ write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type : ', SITE_slp_type, ' (from ',trim(datasource(u_site_slp_type)),')'
+ write(*,'(A,'//trim(c)//'F8.2,3A)') 'Aspect type : ', SITE_asp_type, ' (from ',trim(datasource(u_site_slp_type)),')'
+ write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type area : ', SITE_area_type, ' (from ',trim(datasource(u_site_slp_type)),')'
+ write(c,'(I0)') num_azimuth*num_zenith
+ write(*,'(A,A,I3,A,I3,A,'//trim(c)//'F8.2,3A)') 'Shadow lookup table : ', &
+ '(', num_azimuth, ' in azimuth,', num_zenith, ' in zenith)', &
+ SITE_sf_lut , ' (from ',trim(datasource(u_site_sf_lut)),')'
+ ENDIF
+ ENDIF
+
+
+ IF (.not. for_surface_build) THEN
+
+ landpatch%nset = numpatch
+
+ allocate (landpatch%settyp (numpatch)); landpatch%settyp = SITE_landtype
+
+ landpatch%nblkgrp = 1
+ allocate (landpatch%xblkgrp(1)); landpatch%xblkgrp(1) = 1
+ allocate (landpatch%yblkgrp(1)); landpatch%yblkgrp(1) = 1
+
+ allocate (landpatch%vecgs%vlen(1,1)); landpatch%vecgs%vlen(1,1) = numpatch
+ allocate (landpatch%vecgs%vstt(1,1)); landpatch%vecgs%vstt(1,1) = 1
+ allocate (landpatch%vecgs%vend(1,1)); landpatch%vecgs%vend(1,1) = numpatch
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+
+ IF (numpft > 0) THEN
+
+ landpft%nset = numpft
+
+ allocate (landpft%settyp (numpft)); landpft%settyp = SITE_pfttyp
+
+ landpft%nblkgrp = 1
+ allocate (landpft%xblkgrp(1)); landpft%xblkgrp(1) = 1
+ allocate (landpft%yblkgrp(1)); landpft%yblkgrp(1) = 1
+
+ allocate (landpft%vecgs%vlen(1,1)); landpft%vecgs%vlen(1,1) = numpft
+ allocate (landpft%vecgs%vstt(1,1)); landpft%vecgs%vstt(1,1) = 1
+ allocate (landpft%vecgs%vend(1,1)); landpft%vecgs%vend(1,1) = numpft
+
+ allocate (patch_pft_s (numpatch))
+ allocate (patch_pft_e (numpatch))
+ allocate (pft2patch (numpft ))
+#ifdef CROP
+ IF (SITE_landtype == CROPLAND) THEN
+ patch_pft_s = (/(i, i = 1, numpatch)/)
+ patch_pft_e = (/(i, i = 1, numpatch)/)
+ pft2patch = (/(i, i = 1, numpatch)/)
+ ELSE
+ patch_pft_s = 1
+ patch_pft_e = numpft
+ pft2patch = 1
+ ENDIF
+#else
+ patch_pft_s = 1
+ patch_pft_e = numpft
+ pft2patch = 1
+#endif
+ ENDIF
+#endif
+
+ numelm = 1
+ allocate (landelm%settyp (1)); landelm%settyp (1) = 0
+ allocate (elm_patch%substt (1)); elm_patch%substt(1) = 1
+ allocate (elm_patch%subend (1)); elm_patch%subend(1) = numpatch
+
+ allocate (elm_patch%subfrc (numpatch)); elm_patch%subfrc = 1./numpatch
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+#ifdef CROP
+ elm_patch%subfrc = SITE_pctcrop
+#endif
+#endif
+
+ ENDIF
+
+ END SUBROUTINE read_surface_data_single
+
+!-----------------------------------------------------------------------
+ SUBROUTINE read_urban_surface_data_single (fsrfdata, for_surface_build, mkrun)
+
+ USE MOD_TimeManager
+ USE MOD_Grid
+ USE MOD_Block
+ USE MOD_NetCDFSerial
+ USE MOD_NetCDFPoint
+ USE MOD_Namelist
+ USE MOD_Utils
+ USE MOD_SPMD_Task
+ USE MOD_LandPatch
+ USE MOD_LandUrban
+ USE MOD_Urban_Const_LCZ
+ USE MOD_Vars_Global, only: PI, URBAN
+ USE MOD_Mesh, only: numelm
+ USE MOD_LandElm
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: fsrfdata
+ logical, intent(in) :: for_surface_build
+ logical, intent(in), optional :: mkrun
+
+ ! Local Variables
+ real(r8), allocatable, dimension(:,:) :: hwrbld_ncar , fgper_ncar , htroof_ncar , wtroof_ncar
+ real(r8), allocatable, dimension(:,:) :: emroof_ncar , emwall_ncar , emgimp_ncar , emgper_ncar
+ real(r8), allocatable, dimension(:,:) :: thkroof_ncar, thkwall_ncar, tbldmin_ncar, tbldmax_ncar
+ real(r8), allocatable, dimension(:,:,:) :: cvroof_ncar , cvwall_ncar , cvgimp_ncar , &
+ tkroof_ncar , tkwall_ncar , tkgimp_ncar
+ real(r8), allocatable, dimension(:,:,:,:) :: albroof_ncar, albwall_ncar, albgimp_ncar, albgper_ncar
+
+ real(r8) :: lat_in, lon_in
+ real(r8) :: LAI, lakedepth, slp, asp, zenith_angle
+ integer :: i, isc, nsl, typ, a, z, rid, utyp
+ integer :: iyear, idate(3), simulation_lai_year_start, simulation_lai_year_end
+ integer :: start_year, end_year, ntime, itime, pop_i
+ logical :: readflag
+
+ character(len=256) :: filename, dir_5x5
+ character(len=4) :: cyear, c, c5year
+
+ type(grid_type) :: gridupatch, gridhroof, gridfroof , gridhtopu, gridfvegu, gridflakeu, gridlaiu, &
+ gridpopu , gridlucy , gridbright, gridsoil , gridrock , gridtopo , gridlake, &
+ grid_topo_factor
+
+ real(r8), allocatable :: tea_f(:), tea_b(:)
+
+ u_site_froof = .false.; u_site_hroof = .false.; u_site_fgper = .false.; u_site_hlr = .false.;
+ u_site_fveg = .false.; u_site_htopu = .false.; u_site_urblai = .false.; u_site_urbsai = .false.;
+ u_site_flake = .false.;
+
+ u_site_albr = .false.; u_site_albw = .false.; u_site_albgimp = .false.; u_site_albgper = .false.;
+ u_site_emr = .false.; u_site_emw = .false.; u_site_emgimp = .false.; u_site_emgper = .false.;
+
+ u_site_cvr = .false.; u_site_cvw = .false.; u_site_cvgimp = .false.;
+ u_site_tkr = .false.; u_site_tkw = .false.; u_site_tkgimp = .false.;
+
+ u_site_tbmax = .false.; u_site_tbmin = .false.; u_site_thickr = .false.; u_site_thickw = .false.;
+ u_site_pop = .false.; u_site_lucy = .false.;
+
+ IF (for_surface_build) THEN
+ write(*,*)
+ write(*,*) ' ---------------- Make Single Point Surface Data ---------------- '
+ ENDIF
+
+ IF (ncio_var_exist(fsrfdata, 'latitude')) THEN
+ CALL ncio_read_serial (fsrfdata, 'latitude', lat_in)
+ IF (lat_in /= SITE_lat_location) THEN
+ write(*,*) 'Warning: Latitude mismatch: ', &
+ lat_in, ' in data file and ', SITE_lat_location, 'in namelist.'
+ ENDIF
+ SITE_lat_location = lat_in
+ ENDIF
+
+ IF (ncio_var_exist(fsrfdata, 'longitude')) THEN
+ CALL ncio_read_serial (fsrfdata, 'longitude', lon_in)
+ IF (lon_in /= SITE_lon_location) THEN
+ write(*,*) 'Warning: Longitude mismatch: ', &
+ lon_in, ' in data file and ', SITE_lon_location, 'in namelist.'
+ ENDIF
+ SITE_lon_location = lon_in
+ ENDIF
+
+ CALL normalize_longitude (SITE_lon_location)
+
+ IF (.not. isgreenwich) THEN
+ LocalLongitude = SITE_lon_location
+ ENDIF
+
+ IF (for_surface_build) THEN
+ write(*,'(A,F8.2)') 'Latitude : ', SITE_lat_location
+ write(*,'(A,F8.2)') 'Longitude : ', SITE_lon_location
+ ENDIF
+
+ DEF_domain%edges = floor(SITE_lat_location)
+ DEF_domain%edgen = floor(SITE_lat_location) + 1.
+ DEF_domain%edgew = floor(SITE_lon_location)
+ DEF_domain%edgee = floor(SITE_lon_location) + 1.
+
+ CALL gblock%set ()
+ gblock%nblkme = 1
+ allocate(gblock%xblkme(1))
+ allocate(gblock%yblkme(1))
+ gblock%xblkme(1) = find_nearest_west (SITE_lon_location, gblock%nxblk, gblock%lon_w)
+ gblock%yblkme(1) = find_nearest_south (SITE_lat_location, gblock%nyblk, gblock%lat_s)
+
+ ! (1) build/read "land patch" by using land cover type data
+ IF (trim(fsrfdata) /= 'null') THEN
+ SITE_landtype = URBAN
+ ELSEIF (SITE_landtype /= URBAN) THEN
+ write(*,*) 'Error! Please set SITE_landtype to URBAN in namelist file !'
+ CALL CoLM_stop()
+ ENDIF
+
+ numpatch = 1
+ numurban = 1
+ u_site_landtype = (SITE_landtype >= 0)
+ IF (for_surface_build) THEN
+ write(*,'(A,A,3A)') 'Land cover type : ', trim(patchclassname(SITE_landtype)), &
+ ' (from ',trim(datasource(u_site_landtype)),')'
+ ENDIF
+
+ IF (for_surface_build) THEN
+ ! (2) build/read "urban type" by using land cover type data
+IF (DEF_URBAN_type_scheme == 1) THEN
+ u_site_utype = ncio_var_exist(fsrfdata,'URBAN_DENSITY_CLASS')
+
+ IF ( u_site_utype ) THEN
+ CALL ncio_read_serial (fsrfdata, 'URBTYP' , SITE_ncar_rid)
+ CALL ncio_read_serial (fsrfdata, 'URBAN_DENSITY_CLASS', SITE_urbtyp )
+ ELSE
+ CALL gridupatch%define_by_name ('colm_500m')
+
+ dir_5x5 = trim(DEF_dir_rawdata) // '/urban_type/'
+ CALL read_point_5x5_var_2d_int32 (gridupatch, dir_5x5, 'URBTYP', 'REGION_ID', &
+ SITE_lon_location, SITE_lat_location, SITE_ncar_rid)
+
+ CALL read_point_5x5_var_2d_int32 (gridupatch, dir_5x5, 'URBTYP', 'URBAN_DENSITY_CLASS', &
+ SITE_lon_location, SITE_lat_location, SITE_urbtyp)
+
+ write(*,'(A,I0,A,I0,3A)') 'Urban type : NCAR ', SITE_urbtyp, ' of Region ', SITE_ncar_rid, &
+ ' (from ',trim(datasource(u_site_utype)),')'
+ ENDIF
+ELSE
+ u_site_utype = ncio_var_exist(fsrfdata,'LCZ_DOM')
+ IF ( u_site_utype ) THEN
+ CALL ncio_read_serial (fsrfdata, 'LCZ_DOM', SITE_urbtyp )
+ ELSE
+ CALL gridupatch%define_by_name ('colm_500m')
+
+ dir_5x5 = trim(DEF_dir_rawdata) // '/urban_type/'
+ CALL read_point_5x5_var_2d_int32 (gridupatch, dir_5x5, 'URBTYP', 'LCZ_DOM', &
+ SITE_lon_location, SITE_lat_location, SITE_urbtyp)
+ ENDIF
+ write(*,'(A,I0,3A)') 'Urban type : LCZ ', SITE_urbtyp, &
+ ' (from ',trim(datasource(u_site_utype)),')'
+ENDIF
+
+
+ ! (4) urban geometry
+ readflag = USE_SITE_urban_geometry
+ u_site_hroof = ncio_var_exist(fsrfdata,'building_mean_height',readflag)
+ IF ( u_site_hroof ) THEN
+ CALL ncio_read_serial (fsrfdata, 'building_mean_height', SITE_hroof )
+ ELSE
+ CALL gridhroof%define_by_name ('colm_500m')
+ dir_5x5 = trim(DEF_dir_rawdata) // '/urban/'
+ write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5
+
+IF (DEF_Urban_geom_data == 1) THEN
+ CALL read_point_5x5_var_2d_real8 (gridhroof, dir_5x5, 'URBSRF'//trim(c5year), 'HT_ROOF_GHSL', &
+ SITE_lon_location, SITE_lat_location, SITE_hroof)
+ELSE
+ CALL read_point_5x5_var_2d_real8 (gridhroof, dir_5x5, 'URBSRF'//trim(c5year), 'HT_ROOF_Li', &
+ SITE_lon_location, SITE_lat_location, SITE_hroof)
+ENDIF
+ ENDIF
+
+ u_site_froof = readflag .and. ncio_var_exist(fsrfdata,'roof_area_fraction',readflag)
+ IF ( u_site_froof ) THEN
+ CALL ncio_read_serial (fsrfdata, 'roof_area_fraction', SITE_froof )
+ ELSE
+ CALL gridfroof%define_by_name ('colm_500m')
+ dir_5x5 = trim(DEF_dir_rawdata) // '/urban/'
+ write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5
+IF (DEF_Urban_geom_data == 1) THEN
+ CALL read_point_5x5_var_2d_real8 (gridfroof, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_ROOF_GHSL', &
+ SITE_lon_location, SITE_lat_location, SITE_froof)
+ELSE
+ CALL read_point_5x5_var_2d_real8 (gridfroof, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_ROOF_Li', &
+ SITE_lon_location, SITE_lat_location, SITE_froof)
+ENDIF
+ ENDIF
+
+ u_site_fgper = readflag .and. ncio_var_exist(fsrfdata,'impervious_area_fraction',readflag)
+ IF ( u_site_fgper ) THEN
+ CALL ncio_read_serial (fsrfdata, 'impervious_area_fraction', SITE_fgimp )
+ ENDIF
+
+ u_site_thickr = readflag .and. ncio_var_exist(fsrfdata,'THICK_ROOF',readflag)
+ IF ( u_site_thickr ) THEN
+ CALL ncio_read_serial (fsrfdata, 'THICK_ROOF', SITE_thickroof )
+ ENDIF
+
+ u_site_thickw = readflag .and. ncio_var_exist(fsrfdata,'THICK_WALL',readflag)
+ IF ( u_site_thickw ) THEN
+ CALL ncio_read_serial (fsrfdata, 'THICK_WALL', SITE_thickwall )
+ ENDIF
+
+IF (DEF_USE_CANYON_HWR) THEN
+ u_site_hlr = readflag .and. ncio_var_exist(fsrfdata,'canyon_height_width_ratio',readflag)
+ IF ( u_site_hlr ) THEN
+ CALL ncio_read_serial (fsrfdata, 'canyon_height_width_ratio', SITE_hlr )
+ ENDIF
+ELSE
+ u_site_hlr = readflag .and. ncio_var_exist(fsrfdata,'wall_to_plan_area_ratio',readflag)
+ IF ( u_site_hlr ) THEN
+ CALL ncio_read_serial (fsrfdata, 'wall_to_plan_area_ratio', SITE_lambdaw )
+ SITE_hlr = SITE_lambdaw/4/SITE_froof
+ ENDIF
+ENDIF
+ ! (5) urban ecology
+ readflag = USE_SITE_urban_ecology
+ u_site_htopu = readflag .and. ncio_var_exist(fsrfdata,'tree_mean_height',readflag)
+ IF ( u_site_htopu ) THEN
+ CALL ncio_read_serial (fsrfdata, 'tree_mean_height', SITE_htop_urb )
+ ELSE
+ CALL gridhtopu%define_by_name ('colm_500m')
+ dir_5x5 = trim(DEF_dir_rawdata) // '/urban/'
+ write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5
+
+ CALL read_point_5x5_var_2d_real8 (gridhtopu, dir_5x5, 'URBSRF'//trim(c5year), 'HTOP', &
+ SITE_lon_location, SITE_lat_location, SITE_htop_urb)
+ ENDIF
+
+ u_site_flake = readflag .and. ncio_var_exist(fsrfdata,'water_area_fraction',readflag)
+ IF ( u_site_flake ) THEN
+ CALL ncio_read_serial (fsrfdata, 'water_area_fraction', SITE_flake_urb )
+ ELSE
+ CALL gridflakeu%define_by_name ('colm_500m')
+ dir_5x5 = trim(DEF_dir_rawdata) // '/urban/'
+ write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5
+
+ CALL read_point_5x5_var_2d_real8 (gridflakeu, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_Water', &
+ SITE_lon_location, SITE_lat_location, SITE_flake_urb)
+
+ SITE_flake_urb = SITE_flake_urb/100
+ ENDIF
+
+ u_site_fveg = readflag .and. ncio_var_exist(fsrfdata,'tree_area_fraction',readflag)
+ IF ( u_site_fveg ) THEN
+ CALL ncio_read_serial (fsrfdata, 'tree_area_fraction', SITE_fveg_urb )
+ ELSE
+ CALL gridfvegu%define_by_name ('colm_500m')
+ dir_5x5 = trim(DEF_dir_rawdata) // '/urban/'
+ write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5
+
+ CALL read_point_5x5_var_2d_real8 (gridfvegu, dir_5x5, 'URBSRF'//trim(c5year), 'PCT_Tree', &
+ SITE_lon_location, SITE_lat_location, SITE_fveg_urb)
+
+ SITE_fveg_urb = SITE_fveg_urb/100
+ ENDIF
+
+ u_site_urblai = readflag .and. ncio_var_exist(fsrfdata,'TREE_LAI',readflag)
+ IF ( u_site_urblai) THEN
+ CALL ncio_read_serial (fsrfdata, 'TREE_LAI', SITE_LAI_monthly )
+ CALL ncio_read_serial (fsrfdata, 'TREE_SAI', SITE_SAI_monthly )
+ ELSE
+
+ idate(1) = DEF_simulation_time%start_year
+ IF (.not. isgreenwich) THEN
+ idate(3) = DEF_simulation_time%start_sec
+ CALL monthday2julian (idate(1), &
+ DEF_simulation_time%start_month, DEF_simulation_time%start_day, idate(2))
+ CALL localtime2gmt(idate)
+ ENDIF
+ simulation_lai_year_start = idate(1)
+
+ idate(1) = DEF_simulation_time%end_year
+ IF (.not. isgreenwich) THEN
+ idate(3) = DEF_simulation_time%end_sec
+ CALL monthday2julian (idate(1), &
+ DEF_simulation_time%end_month, DEF_simulation_time%end_day, idate(2))
+ CALL localtime2gmt(idate)
+ ENDIF
+ simulation_lai_year_end = idate(1)
+
+ IF (DEF_LAI_CHANGE_YEARLY) THEN
+ start_year = max(simulation_lai_year_start, DEF_LAI_START_YEAR )
+ start_year = min(start_year, DEF_LAI_END_YEAR )
+ end_year = min(simulation_lai_year_end, DEF_LAI_END_YEAR )
+ end_year = max(end_year, DEF_LAI_START_YEAR )
+ ELSE
+ start_year = DEF_LC_YEAR
+ end_year = DEF_LC_YEAR
+ ENDIF
+
+ allocate (SITE_LAI_year (start_year:end_year))
+ SITE_LAI_year = (/(iyear, iyear = start_year, end_year)/)
+
+ ntime = 12
+ allocate (SITE_LAI_monthly (12,start_year:end_year))
+ allocate (SITE_SAI_monthly (12,start_year:end_year))
+
+ CALL gridlaiu%define_by_name ('colm_500m')
+ dir_5x5 = trim(DEF_dir_rawdata) // '/urban_lai_500m/'
+
+ DO iyear = start_year, end_year
+ write(cyear,'(i4.4)') iyear
+ DO itime = 1, ntime
+ CALL read_point_5x5_var_2d_time_real8 (gridlaiu, dir_5x5, 'URBLAI_'//trim(cyear), &
+ 'URBAN_TREE_LAI', SITE_lon_location, SITE_lat_location, itime, &
+ SITE_LAI_monthly(itime,iyear))
+
+ CALL read_point_5x5_var_2d_time_real8 (gridlaiu, dir_5x5, 'URBLAI_'//trim(cyear), &
+ 'URBAN_TREE_SAI', SITE_lon_location, SITE_lat_location, itime, &
+ SITE_SAI_monthly(itime,iyear))
+ ENDDO
+ ENDDO
+ ENDIF
+
+ ! (6) urban radiation
+ readflag = USE_SITE_urban_radiation
+ u_site_albr = readflag .and. ncio_var_exist(fsrfdata,'ALB_ROOF',readflag)
+ IF ( u_site_albr ) THEN
+ CALL ncio_read_serial (fsrfdata, 'ALB_ROOF', SITE_alb_roof )
+ ENDIF
+
+ u_site_albw = readflag .and. ncio_var_exist(fsrfdata,'ALB_WALL',readflag)
+ IF ( u_site_albw ) THEN
+ CALL ncio_read_serial (fsrfdata, 'ALB_WALL', SITE_alb_wall )
+ ENDIF
+
+ u_site_albgper = readflag .and. ncio_var_exist(fsrfdata,'ALB_GPER',readflag)
+ IF ( u_site_albgper ) THEN
+ CALL ncio_read_serial (fsrfdata, 'ALB_GPER', SITE_alb_gper )
+ ENDIF
+
+ u_site_albgimp = readflag .and. ncio_var_exist(fsrfdata,'ALB_GIMP',readflag)
+ IF ( u_site_albgimp ) THEN
+ CALL ncio_read_serial (fsrfdata, 'ALB_GIMP', SITE_alb_gimp )
+ ENDIF
+
+ u_site_emr = readflag .and. ncio_var_exist(fsrfdata,'EM_ROOF',readflag)
+ IF ( u_site_emr ) THEN
+ CALL ncio_read_serial (fsrfdata, 'EM_ROOF', SITE_em_roof )
+ ENDIF
+
+ u_site_emw = readflag .and. ncio_var_exist(fsrfdata,'EM_WALL',readflag)
+ IF ( u_site_emw ) THEN
+ CALL ncio_read_serial (fsrfdata, 'EM_WALL', SITE_em_wall )
+ ENDIF
+
+ u_site_emgper = readflag .and. ncio_var_exist(fsrfdata,'EM_GPER',readflag)
+ IF ( u_site_emgper ) THEN
+ CALL ncio_read_serial (fsrfdata, 'EM_GPER', SITE_em_gper )
+ ENDIF
+
+ u_site_emgimp = readflag .and. ncio_var_exist(fsrfdata,'EM_GIMP',readflag)
+ IF ( u_site_emgimp ) THEN
+ CALL ncio_read_serial (fsrfdata, 'EM_GIMP', SITE_em_gimp )
+ ENDIF
+
+ ! (6) urban thermal
+ readflag = USE_SITE_urban_thermal
+ u_site_cvr = readflag .and. ncio_var_exist(fsrfdata,'CV_ROOF',readflag)
+ IF ( u_site_cvr ) THEN
+ CALL ncio_read_serial (fsrfdata, 'CV_ROOF', SITE_cv_roof )
+ ENDIF
+
+ u_site_cvw = readflag .and. ncio_var_exist(fsrfdata,'CV_WALL',readflag)
+ IF ( u_site_cvw ) THEN
+ CALL ncio_read_serial (fsrfdata, 'CV_WALL', SITE_cv_wall )
+ ENDIF
+
+ u_site_cvgimp = readflag .and. ncio_var_exist(fsrfdata,'CV_GIMP',readflag)
+ IF ( u_site_cvgimp ) THEN
+ CALL ncio_read_serial (fsrfdata, 'CV_GIMP', SITE_cv_gimp )
+ ENDIF
+
+ u_site_tkr = readflag .and. ncio_var_exist(fsrfdata,'TK_ROOF',readflag)
+ IF ( u_site_tkr ) THEN
+ CALL ncio_read_serial (fsrfdata, 'TK_ROOF', SITE_tk_roof )
+ ENDIF
+
+ u_site_tkw = readflag .and. ncio_var_exist(fsrfdata,'TK_WALL',readflag)
+ IF ( u_site_tkw ) THEN
+ CALL ncio_read_serial (fsrfdata, 'TK_WALL', SITE_tk_wall )
+ ENDIF
+
+ u_site_tkgimp = readflag .and. ncio_var_exist(fsrfdata,'TK_GIMP',readflag)
+ IF ( u_site_tkgimp ) THEN
+ CALL ncio_read_serial (fsrfdata, 'TK_GIMP', SITE_tk_gimp )
+ ENDIF
+
+ ! (6) urban human
+ readflag = USE_SITE_urban_human
+ u_site_pop= readflag .and. ncio_var_exist(fsrfdata,'resident_population_density',readflag)
+ IF ( u_site_pop) THEN
+ CALL ncio_read_serial (fsrfdata, 'resident_population_density', SITE_popden )
+ ELSE
+ CALL gridpopu%define_by_name ('colm_500m')
+ dir_5x5 = trim(DEF_dir_rawdata) // '/urban/'
+ write(c5year, '(i4.4)') int(DEF_LC_YEAR/5)*5
+
+ IF (mod(DEF_LC_YEAR,5) == 0) THEN
+ pop_i = 1
+ ELSE
+ pop_i = 5 - (ceiling(DEF_LC_YEAR*1./5.)*5 - DEF_LC_YEAR) + 1
+ ENDIF
+
+ CALL read_point_5x5_var_2d_time_real8 (gridlaiu, dir_5x5, 'URBSRF'//trim(c5year), &
+ 'POP_DEN', SITE_lon_location, SITE_lat_location, pop_i, &
+ SITE_popden)
+ ENDIF
+
+ u_site_lucy= readflag .and. ncio_var_exist(fsrfdata,'LUCY_ID',readflag)
+ IF ( u_site_lucy) THEN
+ CALL ncio_read_serial (fsrfdata, 'LUCY_ID', SITE_lucyid )
+ ELSE
+ CALL gridlucy%define_by_name ('colm_5km')
+ filename = trim(DEF_dir_rawdata) // '/urban/LUCY_regionid.nc'
+
+ CALL read_point_var_2d_real8 (gridlucy, filename, 'LUCY_REGION_ID', &
+ SITE_lon_location, SITE_lat_location, SITE_lucyid)
+ ENDIF
+
+ u_site_tbmax= readflag .and. ncio_var_exist(fsrfdata,'T_BUILDING_MAX',readflag)
+ IF ( u_site_tbmax) THEN
+ CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax )
+ ENDIF
+
+ u_site_tbmin= readflag .and. ncio_var_exist(fsrfdata,'T_BUILDING_MIN',readflag)
+ IF ( u_site_tbmin) THEN
+ CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin )
+ ENDIF
+
+IF (DEF_URBAN_type_scheme == 1) THEN
+ filename = trim(DEF_dir_rawdata)//'urban/NCAR_urban_properties.nc'
+
+ CALL ncio_read_bcast_serial (filename, "WTLUNIT_ROOF" , wtroof_ncar )
+ CALL ncio_read_bcast_serial (filename, "HT_ROOF" , htroof_ncar )
+ CALL ncio_read_bcast_serial (filename, "CANYON_HWR" , hwrbld_ncar )
+ CALL ncio_read_bcast_serial (filename, "WTROAD_PERV" , fgper_ncar )
+ CALL ncio_read_bcast_serial (filename, "EM_ROOF" , emroof_ncar )
+ CALL ncio_read_bcast_serial (filename, "EM_WALL" , emwall_ncar )
+ CALL ncio_read_bcast_serial (filename, "EM_IMPROAD" , emgimp_ncar )
+ CALL ncio_read_bcast_serial (filename, "EM_PERROAD" , emgper_ncar )
+ CALL ncio_read_bcast_serial (filename, "ALB_ROOF" , albroof_ncar)
+ CALL ncio_read_bcast_serial (filename, "ALB_WALL" , albwall_ncar)
+ CALL ncio_read_bcast_serial (filename, "ALB_IMPROAD" , albgimp_ncar)
+ CALL ncio_read_bcast_serial (filename, "ALB_PERROAD" , albgper_ncar)
+ CALL ncio_read_bcast_serial (filename, "TK_ROOF" , tkroof_ncar )
+ CALL ncio_read_bcast_serial (filename, "TK_WALL" , tkwall_ncar )
+ CALL ncio_read_bcast_serial (filename, "TK_IMPROAD" , tkgimp_ncar )
+ CALL ncio_read_bcast_serial (filename, "CV_ROOF" , cvroof_ncar )
+ CALL ncio_read_bcast_serial (filename, "CV_WALL" , cvwall_ncar )
+ CALL ncio_read_bcast_serial (filename, "CV_IMPROAD" , cvgimp_ncar )
+ CALL ncio_read_bcast_serial (filename, "THICK_ROOF" , thkroof_ncar)
+ CALL ncio_read_bcast_serial (filename, "THICK_WALL" , thkwall_ncar)
+ CALL ncio_read_bcast_serial (filename, "T_BUILDING_MIN", tbldmin_ncar)
+ CALL ncio_read_bcast_serial (filename, "T_BUILDING_MAX", tbldmax_ncar)
+
+ rid = SITE_ncar_rid
+ utyp = SITE_urbtyp
+
+ IF (.not. u_site_emr ) SITE_em_roof = emroof_ncar(utyp, rid)
+ IF (.not. u_site_emw ) SITE_em_wall = emwall_ncar(utyp, rid)
+ IF (.not. u_site_emgimp ) SITE_em_gimp = emgimp_ncar(utyp, rid)
+ IF (.not. u_site_emgper ) SITE_em_gper = emgper_ncar(utyp, rid)
+
+ IF (.not. u_site_tbmax ) SITE_t_roommax = tbldmax_ncar (utyp, rid)
+ IF (.not. u_site_tbmin ) SITE_t_roommin = tbldmin_ncar (utyp, rid)
+
+ IF (.not. u_site_thickr ) SITE_thickroof = thkroof_ncar(utyp, rid)
+ IF (.not. u_site_thickw ) SITE_thickwall = thkwall_ncar(utyp, rid)
+
+ IF (.not. u_site_cvr ) THEN
+ allocate( SITE_cv_roof (nl_roof) )
+ SITE_cv_roof(:) = cvroof_ncar(utyp, rid, :)
+ ENDIF
+
+ IF (.not. u_site_cvw ) THEN
+ allocate( SITE_cv_wall (nl_wall) )
+ SITE_cv_wall(:) = cvwall_ncar(utyp, rid, :)
+ ENDIF
+
+ IF (.not. u_site_cvgimp) THEN
+ allocate( SITE_cv_gimp (nl_soil) )
+ SITE_cv_gimp(:) = cvgimp_ncar(utyp, rid, :)
+ ENDIF
+
+ IF (.not. u_site_tkr ) THEN
+ allocate( SITE_tk_roof (nl_roof) )
+ SITE_tk_roof(:) = tkroof_ncar(utyp, rid, :)
+ ENDIF
+
+ IF (.not. u_site_tkw ) THEN
+ allocate( SITE_tk_wall (nl_wall) )
+ SITE_tk_wall(:) = tkwall_ncar(utyp, rid, :)
+ ENDIF
+
+ IF (.not. u_site_tkgimp) THEN
+ allocate( SITE_tk_gimp (nl_soil) )
+ SITE_tk_gimp(:) = tkgimp_ncar(utyp, rid, :)
+ ENDIF
+
+ IF (.not. u_site_albr ) THEN
+ allocate( SITE_alb_roof (2, 2) )
+ SITE_alb_roof(:,:) = albroof_ncar(utyp, rid, :, :)
+ ENDIF
+
+ IF (.not. u_site_albw ) THEN
+ allocate( SITE_alb_wall (2, 2) )
+ SITE_alb_wall(:,:) = albwall_ncar(utyp, rid, :, :)
+ ENDIF
+
+ IF (.not. u_site_albgimp) THEN
+ allocate( SITE_alb_gimp (2, 2) )
+ SITE_alb_gimp(:,:) = albgimp_ncar(utyp, rid, :, :)
+ ENDIF
+
+ IF (.not. u_site_albgper) THEN
+ allocate( SITE_alb_gper (2, 2) )
+ SITE_alb_gper(:,:) = albgper_ncar(utyp, rid, :, :)
+ ENDIF
+
+ IF (.not. u_site_hlr ) SITE_hlr = hwrbld_ncar(utyp, rid)
+ IF (.not. u_site_fgper) SITE_fgimp = 1-fgper_ncar(utyp, rid)
+ELSE
+ utyp = SITE_urbtyp
+ IF (.not. u_site_emr ) SITE_em_roof = emroof_lcz(utyp)
+ IF (.not. u_site_emw ) SITE_em_wall = emwall_lcz(utyp)
+ IF (.not. u_site_emgimp) SITE_em_gimp = emgimp_lcz(utyp)
+ IF (.not. u_site_emgper) SITE_em_gper = emgper_lcz(utyp)
+
+ IF (.not. u_site_tbmax) SITE_t_roommax = tbldmax_lcz(utyp)
+ IF (.not. u_site_tbmin) SITE_t_roommin = tbldmin_lcz(utyp)
+
+ IF (.not. u_site_thickr) SITE_thickroof = thkroof_lcz(utyp)
+ IF (.not. u_site_thickw) SITE_thickwall = thkwall_lcz(utyp)
+
+ IF (.not. u_site_cvr ) THEN
+ allocate( SITE_cv_roof (nl_roof) )
+ SITE_cv_roof(:) = cvroof_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_cvw ) THEN
+ allocate( SITE_cv_wall (nl_wall) )
+ SITE_cv_wall(:) = cvwall_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_cvgimp) THEN
+ allocate( SITE_cv_gimp (nl_soil) )
+ SITE_cv_gimp(:) = cvgimp_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_tkr ) THEN
+ allocate( SITE_tk_roof (nl_roof) )
+ SITE_tk_roof(:) = tkroof_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_tkw ) THEN
+ allocate( SITE_tk_wall (nl_wall) )
+ SITE_tk_wall(:) = tkwall_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_tkgimp) THEN
+ allocate( SITE_tk_gimp (nl_soil) )
+ SITE_tk_gimp(:) = tkgimp_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_albr ) THEN
+ allocate( SITE_alb_roof (2, 2) )
+ SITE_alb_roof(:,:) = albroof_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_albw ) THEN
+ allocate( SITE_alb_wall (2, 2) )
+ SITE_alb_wall(:,:) = albwall_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_albgimp) THEN
+ allocate( SITE_alb_gimp (2, 2) )
+ SITE_alb_gimp(:,:) = albgimp_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_albgper) THEN
+ allocate( SITE_alb_gper (2, 2) )
+ SITE_alb_gper(:,:) = albgper_lcz(utyp)
+ ENDIF
+
+ IF (.not. u_site_hlr ) SITE_hlr = hwrbld_lcz(utyp)
+
+ IF (.not. u_site_fgper) SITE_fgimp = 1-fgper_lcz(utyp)/(1-SITE_froof)
+ENDIF
+
+IF (DEF_USE_CANYON_HWR) THEN
+ SITE_hlr =SITE_hlr*(1-sqrt(SITE_froof))/sqrt(SITE_froof)
+ENDIF
+
+ ! (6) lake depth
+ readflag = u_site_lakedepth
+ u_site_lakedepth = readflag .and. ncio_var_exist(fsrfdata,'lakedepth',readflag)
+ IF (u_site_lakedepth) THEN
+ CALL ncio_read_serial (fsrfdata, 'lakedepth', SITE_lakedepth)
+ ELSE
+ CALL gridlake%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/lake_depth.nc'
+ CALL read_point_var_2d_real8 (gridlake, filename, 'lake_depth', &
+ SITE_lon_location, SITE_lat_location, lakedepth)
+ SITE_lakedepth = lakedepth * 0.1
+ ENDIF
+
+ write(*,'(A,F8.2,3A)') 'Lake depth : ', SITE_lakedepth, ' (from ',datasource(u_site_lakedepth),')'
+
+ ! (7) soil brightness parameters
+ readflag = USE_SITE_soilreflectance
+ u_site_soil_bright = readflag &
+ .and. ncio_var_exist(fsrfdata,'soil_s_v_alb',readflag) &
+ .and. ncio_var_exist(fsrfdata,'soil_d_v_alb',readflag) &
+ .and. ncio_var_exist(fsrfdata,'soil_s_n_alb',readflag) &
+ .and. ncio_var_exist(fsrfdata,'soil_d_n_alb',readflag)
+
+ IF (u_site_soil_bright) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb)
+ CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb)
+ CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb)
+ CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb)
+ ELSE
+ SITE_soil_s_v_alb = spval
+ SITE_soil_d_v_alb = spval
+ SITE_soil_s_n_alb = spval
+ SITE_soil_d_n_alb = spval
+
+ CALL gridbright%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/soil_brightness.nc'
+ CALL read_point_var_2d_int32 (gridbright, filename, 'soil_brightness', &
+ SITE_lon_location, SITE_lat_location, isc)
+
+#ifdef LULC_USGS
+ IF(SITE_landtype /= 16 .and. SITE_landtype /= 24)THEN ! NOT WATER BODIES(16)/GLACIER and ICESHEET(24)
+#else
+ IF(SITE_landtype /= 17 .and. SITE_landtype /= 15)THEN ! NOT WATER BODIES(17)/GLACIER and ICE SHEET(15)
+#endif
+ IF ((isc >= 1) .and. (isc <= 20)) THEN
+ SITE_soil_s_v_alb = soil_s_v_refl( isc )
+ SITE_soil_d_v_alb = soil_d_v_refl( isc )
+ SITE_soil_s_n_alb = soil_s_n_refl( isc )
+ SITE_soil_d_n_alb = soil_d_n_refl( isc )
+ ENDIF
+ ENDIF
+ ENDIF
+
+ write(*,'(A,F8.2,3A)') 'Soil brightness s_v : ', SITE_soil_s_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')'
+ write(*,'(A,F8.2,3A)') 'Soil brightness d_v : ', SITE_soil_d_v_alb, ' (from ',trim(datasource(u_site_soil_bright)),')'
+ write(*,'(A,F8.2,3A)') 'Soil brightness s_n : ', SITE_soil_s_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')'
+ write(*,'(A,F8.2,3A)') 'Soil brightness d_n : ', SITE_soil_d_n_alb, ' (from ',trim(datasource(u_site_soil_bright)),')'
+
+ ! (8) soil parameters
+ CALL gridsoil%define_by_name ('colm_500m')
+
+ readflag = USE_SITE_soilparameters
+ u_site_vf_quartz_mineral = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_quartz_mineral',readflag)
+ IF (u_site_vf_quartz_mineral) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral)
+ ELSE
+ allocate (SITE_soil_vf_quartz_mineral (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_quartz_mineral_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_quartz_mineral_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_quartz_mineral(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_vf_gravels = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_gravels',readflag)
+ IF (u_site_vf_gravels) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels)
+ ELSE
+ allocate (SITE_soil_vf_gravels (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_gravels_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_gravels_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_gravels(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_vf_sand = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_sand',readflag)
+ IF (u_site_vf_sand) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand)
+ ELSE
+ allocate (SITE_soil_vf_sand (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_sand_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_sand_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_sand(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_vf_clay = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_clay',readflag)
+ IF (u_site_vf_clay) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay)
+ ELSE
+ allocate (SITE_soil_vf_clay (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_clay_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_clay_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_clay(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_vf_om = readflag .and. ncio_var_exist(fsrfdata,'soil_vf_om',readflag)
+ IF (u_site_vf_om) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om)
+ ELSE
+ allocate (SITE_soil_vf_om (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/vf_om_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'vf_om_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_vf_om(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_wf_gravels = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_gravels',readflag)
+ IF (u_site_wf_gravels) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels)
+ ELSE
+ allocate (SITE_soil_wf_gravels (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/wf_gravels_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_gravels_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_wf_gravels(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_wf_sand = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_sand',readflag)
+ IF (u_site_wf_sand) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand)
+ ELSE
+ allocate (SITE_soil_wf_sand (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/wf_sand_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_sand_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_wf_sand(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_wf_clay = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_clay',readflag)
+ IF (u_site_wf_clay) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay)
+ ELSE
+ allocate (SITE_soil_wf_clay (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/wf_clay_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_clay_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_wf_clay(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_wf_om = readflag .and. ncio_var_exist(fsrfdata,'soil_wf_om',readflag)
+ IF (u_site_wf_om) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om)
+ ELSE
+ allocate (SITE_soil_wf_om (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/wf_om_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'wf_om_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_wf_om(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_OM_density = readflag .and. ncio_var_exist(fsrfdata,'soil_OM_density',readflag)
+ IF (u_site_OM_density) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density)
+ ELSE
+ allocate (SITE_soil_OM_density (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/OM_density_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'OM_density_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_OM_density(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_BD_all = readflag .and. ncio_var_exist(fsrfdata,'soil_BD_all',readflag)
+ IF (u_site_BD_all) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all)
+ ELSE
+ allocate (SITE_soil_BD_all (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/BD_all_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'BD_all_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_BD_all(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_theta_s = readflag .and. ncio_var_exist(fsrfdata,'soil_theta_s',readflag)
+ IF (u_site_theta_s) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s)
+ ELSE
+ allocate (SITE_soil_theta_s (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/theta_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'theta_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_theta_s(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_k_s = readflag .and. ncio_var_exist(fsrfdata,'soil_k_s',readflag)
+ IF (u_site_k_s) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s)
+ ELSE
+ allocate (SITE_soil_k_s (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/k_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'k_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_k_s(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_csol = readflag .and. ncio_var_exist(fsrfdata,'soil_csol',readflag)
+ IF (u_site_csol) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_csol', SITE_soil_csol)
+ ELSE
+ allocate (SITE_soil_csol (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/csol.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'csol_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_csol(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_tksatu = readflag .and. ncio_var_exist(fsrfdata,'soil_tksatu',readflag)
+ IF (u_site_tksatu) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu)
+ ELSE
+ allocate (SITE_soil_tksatu (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/tksatu.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatu_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_tksatu(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_tksatf = readflag .and. ncio_var_exist(fsrfdata,'soil_tksatf',readflag)
+ IF (u_site_tksatf) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf)
+ ELSE
+ allocate (SITE_soil_tksatf (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/tksatf.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'tksatf_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_tksatf(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_tkdry = readflag .and. ncio_var_exist(fsrfdata,'soil_tkdry',readflag)
+ IF (u_site_tkdry) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry)
+ ELSE
+ allocate (SITE_soil_tkdry (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/tkdry.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'tkdry_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_tkdry(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_k_solids = readflag .and. ncio_var_exist(fsrfdata,'soil_k_solids',readflag)
+ IF (u_site_k_solids) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids)
+ ELSE
+ allocate (SITE_soil_k_solids (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/k_solids.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'k_solids_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_k_solids(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_psi_s = readflag .and. ncio_var_exist(fsrfdata,'soil_psi_s',readflag)
+ IF (u_site_psi_s) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s)
+ ELSE
+ allocate (SITE_soil_psi_s (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/psi_s.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'psi_s_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_psi_s(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_lambda = readflag .and. ncio_var_exist(fsrfdata,'soil_lambda',readflag)
+ IF (u_site_lambda) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda)
+ ELSE
+ allocate (SITE_soil_lambda (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/lambda.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'lambda_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_lambda(nsl))
+ ENDDO
+ ENDIF
+
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ u_site_theta_r = readflag .and. ncio_var_exist(fsrfdata,'soil_theta_r',readflag)
+ IF (u_site_theta_r) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r)
+ ELSE
+ allocate (SITE_soil_theta_r (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/VGM_theta_r.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_theta_r_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_theta_r(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_alpha_vgm = readflag .and. ncio_var_exist(fsrfdata,'soil_alpha_vgm',readflag)
+ IF (u_site_alpha_vgm) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm)
+ ELSE
+ allocate (SITE_soil_alpha_vgm (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/VGM_alpha.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_alpha_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_alpha_vgm(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_L_vgm = readflag .and. ncio_var_exist(fsrfdata,'soil_L_vgm',readflag)
+ IF (u_site_L_vgm) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm)
+ ELSE
+ allocate (SITE_soil_L_vgm (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/VGM_L.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_L_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_L_vgm(nsl))
+ ENDDO
+ ENDIF
+
+ u_site_n_vgm = readflag .and. ncio_var_exist(fsrfdata,'soil_n_vgm',readflag)
+ IF (u_site_n_vgm) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm)
+ ELSE
+ allocate (SITE_soil_n_vgm (8))
+ DO nsl = 1, 8
+ write(c,'(i1)') nsl
+ filename = trim(DEF_dir_rawdata)//'/soil/VGM_n.nc'
+ CALL read_point_var_2d_real8 (gridsoil, filename, 'VGM_n_l'//trim(c), &
+ SITE_lon_location, SITE_lat_location, SITE_soil_n_vgm(nsl))
+ ENDDO
+ ENDIF
+#endif
+
+ u_site_BA_alpha = .false.
+ u_site_BA_beta = .false.
+ allocate (SITE_soil_BA_alpha (8))
+ allocate (SITE_soil_BA_beta (8))
+ DO nsl = 1, 8
+ IF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.4) THEN
+ SITE_soil_BA_alpha(nsl) = 0.38
+ SITE_soil_BA_beta (nsl) = 35.0
+ ELSEIF (SITE_soil_vf_gravels(nsl) + SITE_soil_vf_sand(nsl) > 0.25) THEN
+ SITE_soil_BA_alpha(nsl) = 0.24
+ SITE_soil_BA_beta (nsl) = 26.0
+ ELSE
+ SITE_soil_BA_alpha(nsl) = 0.20
+ SITE_soil_BA_beta (nsl) = 10.0
+ ENDIF
+ ENDDO
+
+ IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC
+ u_site_soil_texture = readflag .and. ncio_var_exist(fsrfdata,'soil_texture',readflag)
+ IF (u_site_soil_texture) THEN
+ CALL ncio_read_serial (fsrfdata, 'soil_texture', SITE_soil_texture)
+ ELSE
+ filename = trim(DEF_dir_rawdata)//'/soil/soiltexture_0cm-60cm_mean.nc'
+ CALL read_point_var_2d_int32 (gridsoil, filename, 'soiltexture', &
+ SITE_lon_location, SITE_lat_location, SITE_soil_texture)
+ ENDIF
+ ENDIF
+
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_quartz_mineral : ', SITE_soil_vf_quartz_mineral(1:8), ' (from ',trim(datasource(u_site_vf_quartz_mineral)),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_gravels : ', SITE_soil_vf_gravels (1:8), ' (from ',trim(datasource(u_site_vf_gravels )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_sand : ', SITE_soil_vf_sand (1:8), ' (from ',trim(datasource(u_site_vf_sand )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_clay : ', SITE_soil_vf_clay (1:8), ' (from ',trim(datasource(u_site_vf_clay )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_vf_om : ', SITE_soil_vf_om (1:8), ' (from ',trim(datasource(u_site_vf_om )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_wf_gravels : ', SITE_soil_wf_gravels (1:8), ' (from ',trim(datasource(u_site_wf_gravels )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_wf_sand : ', SITE_soil_wf_sand (1:8), ' (from ',trim(datasource(u_site_wf_sand )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_wf_clay : ', SITE_soil_wf_clay (1:8), ' (from ',trim(datasource(u_site_wf_clay )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_wf_om : ', SITE_soil_wf_om (1:8), ' (from ',trim(datasource(u_site_wf_om )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_OM_density : ', SITE_soil_OM_density (1:8), ' (from ',trim(datasource(u_site_OM_density )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_BD_all : ', SITE_soil_BD_all (1:8), ' (from ',trim(datasource(u_site_BD_all )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_theta_s : ', SITE_soil_theta_s (1:8), ' (from ',trim(datasource(u_site_theta_s )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_k_s : ', SITE_soil_k_s (1:8), ' (from ',trim(datasource(u_site_k_s )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_csol : ', SITE_soil_csol (1:8), ' (from ',trim(datasource(u_site_csol )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_tksatu : ', SITE_soil_tksatu (1:8), ' (from ',trim(datasource(u_site_tksatu )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_tksatf : ', SITE_soil_tksatf (1:8), ' (from ',trim(datasource(u_site_tksatf )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_tkdry : ', SITE_soil_tkdry (1:8), ' (from ',trim(datasource(u_site_tkdry )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_k_solids : ', SITE_soil_k_solids (1:8), ' (from ',trim(datasource(u_site_k_solids )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_psi_s : ', SITE_soil_psi_s (1:8), ' (from ',trim(datasource(u_site_psi_s )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_lambda : ', SITE_soil_lambda (1:8), ' (from ',trim(datasource(u_site_lambda )),')'
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ write(*,'(A,8ES10.2,3A)') 'soil_theta_r : ', SITE_soil_theta_r (1:8), ' (from ',trim(datasource(u_site_theta_r )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_alpha_vgm : ', SITE_soil_alpha_vgm (1:8), ' (from ',trim(datasource(u_site_alpha_vgm )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_L_vgm : ', SITE_soil_L_vgm (1:8), ' (from ',trim(datasource(u_site_L_vgm )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_n_vgm : ', SITE_soil_n_vgm (1:8), ' (from ',trim(datasource(u_site_n_vgm )),')'
+#endif
+ write(*,'(A,8ES10.2,3A)') 'soil_BA_alpha : ', SITE_soil_BA_alpha (1:8), ' (from ',trim(datasource(u_site_BA_alpha )),')'
+ write(*,'(A,8ES10.2,3A)') 'soil_BA_beta : ', SITE_soil_BA_beta (1:8), ' (from ',trim(datasource(u_site_BA_beta )),')'
+
+ IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC
+ write(*,'(A,I3,3A)') 'soil texture : ', SITE_soil_texture, ' (from ',trim(datasource(u_site_soil_texture)),')'
+ ENDIF
+
+ ! (9) depth to bedrock
+ IF (DEF_USE_BEDROCK) THEN
+ readflag = USE_SITE_dbedrock
+ u_site_dbedrock = readflag .and. ncio_var_exist (fsrfdata, 'depth_to_bedrock',readflag)
+ IF (u_site_dbedrock) THEN
+ CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock)
+ ELSE
+ CALL gridrock%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/bedrock.nc'
+ CALL read_point_var_2d_real8 (gridrock, filename, 'dbedrock', &
+ SITE_lon_location, SITE_lat_location, SITE_dbedrock)
+ ENDIF
+
+ write(*,'(A,F8.2,3A)') 'Depth to bedrock : ', SITE_dbedrock, ' (from ',datasource(u_site_dbedrock),')'
+ ENDIF
+
+ ! (10) topography
+ readflag = USE_SITE_topography
+
+ u_site_elevation = readflag .and. ncio_var_exist (fsrfdata, 'elevation',readflag)
+ IF (u_site_elevation) THEN
+ CALL ncio_read_serial (fsrfdata, 'elevation', SITE_elevation)
+ ELSE
+ CALL gridtopo%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/elevation.nc'
+ CALL read_point_var_2d_real8 (gridtopo, filename, 'elevation', &
+ SITE_lon_location, SITE_lat_location, SITE_elevation)
+ ENDIF
+
+ u_site_elvstd = readflag &
+ .and. ncio_var_exist (fsrfdata, 'elvstd',readflag)
+ IF (u_site_elvstd) THEN
+ CALL ncio_read_serial (fsrfdata, 'elvstd', SITE_elvstd)
+ ELSE
+ CALL gridtopo%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/topography.nc'
+ CALL read_point_var_2d_real8 (gridtopo, filename, 'elvstd', &
+ SITE_lon_location, SITE_lat_location, SITE_elvstd)
+ ENDIF
+
+ u_site_sloperatio = readflag &
+ .and. ncio_var_exist (fsrfdata, 'sloperatio',readflag)
+ IF (u_site_sloperatio) THEN
+ CALL ncio_read_serial (fsrfdata, 'sloperatio', SITE_sloperatio)
+ ELSE
+ CALL gridtopo%define_by_name ('colm_500m')
+ filename = trim(DEF_dir_rawdata)//'/topography.nc'
+ CALL read_point_var_2d_real8 (gridtopo, filename, 'slope', &
+ SITE_lon_location, SITE_lat_location, SITE_sloperatio)
+ ENDIF
+
+ IF (DEF_USE_Forcing_Downscaling) THEN
+
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc"
+ IF (ncio_var_exist(filename,'lat') .and. ncio_var_exist(filename,'lon')) THEN
+ CALL grid_topo_factor%define_from_file (filename, "lat", "lon")
+ ENDIF
+
+ u_site_svf = readflag .and. ncio_var_exist (fsrfdata, 'SITE_svf',readflag)
+ IF (u_site_svf) THEN
+ CALL ncio_read_serial (fsrfdata, 'SITE_svf' , SITE_svf)
+ ELSE
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/sky_view_factor.nc"
+ CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'svf', &
+ SITE_lon_location, SITE_lat_location, SITE_svf)
+ ENDIF
+
+ u_site_cur = readflag .and. ncio_var_exist (fsrfdata, 'SITE_cur',readflag)
+ IF (u_site_cur) THEN
+ CALL ncio_read_serial (fsrfdata, 'SITE_cur' , SITE_cur)
+ ELSE
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/curvature.nc"
+ CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'curvature', &
+ SITE_lon_location, SITE_lat_location, SITE_cur)
+ ENDIF
+
+ u_site_slp_type = readflag &
+ .and. ncio_var_exist (fsrfdata, 'SITE_slp_type' ,readflag) &
+ .and. ncio_var_exist (fsrfdata, 'SITE_asp_type' ,readflag) &
+ .and. ncio_var_exist (fsrfdata, 'SITE_area_type',readflag)
+ u_site_asp_type = u_site_slp_type
+ u_site_area_type = u_site_slp_type
+
+ IF (u_site_slp_type) THEN
+ CALL ncio_read_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type )
+ CALL ncio_read_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type )
+ CALL ncio_read_serial (fsrfdata, 'SITE_area_type', SITE_area_type )
+ ELSE
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/slope.nc"
+ CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'slope', &
+ SITE_lon_location, SITE_lat_location, slp)
+
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/aspect.nc"
+ CALL read_point_var_2d_real8 (grid_topo_factor, filename, 'aspect', &
+ SITE_lon_location, SITE_lat_location, asp)
+
+ allocate (SITE_slp_type (num_slope_type)); SITE_slp_type (:) = 0.
+ allocate (SITE_asp_type (num_slope_type)); SITE_asp_type (:) = 0.
+ allocate (SITE_area_type (num_slope_type)); SITE_area_type(:) = 0.
+
+ IF ((asp.ge.0 .and. asp.le.90*pi/180) .or. (asp.ge.270*pi/180 .and. asp.le.360*pi/180)) THEN
+ IF ((slp.ge.15*pi/180)) THEN ! north abrupt slope
+ typ = 1
+ ELSE ! north gentle slope
+ typ = 2
+ ENDIF
+ ELSE
+ IF ((slp.ge.15*pi/180)) THEN ! south abrupt slope
+ typ = 3
+ ELSE ! south gentle slope
+ typ = 4
+ ENDIF
+ ENDIF
+
+ SITE_slp_type (typ) = slp
+ SITE_asp_type (typ) = asp
+ SITE_area_type(typ) = 1.
+
+ ENDIF
+
+ u_site_sf_lut = readflag .and. ncio_var_exist (fsrfdata, 'SITE_sf_lut',readflag)
+ IF (u_site_sf_lut) THEN
+ CALL ncio_read_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut)
+ ELSE
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_front.nc"
+ CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_front', &
+ SITE_lon_location, SITE_lat_location, num_azimuth, tea_f)
+
+ filename = trim(DEF_DS_HiresTopographyDataDir)//"/terrain_elev_angle_back.nc"
+ CALL read_point_var_3d_first_real8 (grid_topo_factor, filename, 'tea_back', &
+ SITE_lon_location, SITE_lat_location, num_azimuth, tea_b)
+
+ allocate (SITE_sf_lut (num_azimuth, num_zenith))
+
+ DO a = 1, num_azimuth
+
+ tea_f(a) = asin(max(min(tea_f(a),1.),-1.))
+ tea_b(a) = asin(max(min(tea_b(a),1.),-1.))
+
+ IF (tea_f(a) <= tea_b(a)) tea_f(a) = tea_b(a) + 0.001
+
+ DO z = 1, num_zenith
+ zenith_angle = pi/(2*num_zenith)*(z-1)
+
+ IF (pi*0.5 - zenith_angle < tea_b(a)) THEN
+ SITE_sf_lut(a,z) = 0
+ ELSE IF (pi*0.5 - zenith_angle > tea_f(a)) THEN
+ SITE_sf_lut(a,z) = 1
+ ELSE
+ SITE_sf_lut(a,z) = (0.5*pi - zenith_angle - tea_b(a))/(tea_f(a) - tea_b(a))
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+ write(*,'(A,F8.2,3A)') 'Elevation : ', SITE_elevation, ' (from ',datasource(u_site_elevation),')'
+ write(*,'(A,F8.2,3A)') 'Elv std : ', SITE_elvstd, ' (from ',datasource(u_site_elvstd),')'
+ write(*,'(A,F8.2,3A)') 'SlopeRatio: ', SITE_sloperatio,' (from ',datasource(u_site_sloperatio),')'
+
+ IF (DEF_USE_Forcing_Downscaling) THEN
+ write(*,'(A,F8.2,3A)') 'Sky view factor : ', SITE_svf, ' (from ',datasource(u_site_svf),')'
+ write(*,'(A,F8.2,3A)') 'Curvature : ', SITE_cur, ' (from ',datasource(u_site_cur),')'
+ write(c,'(I0)') num_slope_type
+ write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type : ', SITE_slp_type, ' (from ',datasource(u_site_slp_type),')'
+ write(*,'(A,'//trim(c)//'F8.2,3A)') 'Aspect type : ', SITE_asp_type, ' (from ',datasource(u_site_slp_type),')'
+ write(*,'(A,'//trim(c)//'F8.2,3A)') 'Slope type area : ', SITE_area_type, ' (from ',datasource(u_site_slp_type),')'
+ write(c,'(I0)') num_azimuth*num_zenith
+ write(*,'(A,A,I3,A,I3,A,'//trim(c)//'F8.2,3A)') 'Shadow lookup table : ', &
+ '(', num_azimuth, ' in azimuth,', num_zenith, ' in zenith)', &
+ SITE_sf_lut , ' (from ',datasource(u_site_sf_lut),')'
+ ENDIF
+
+ ELSE
+ CALL ncio_read_serial (fsrfdata, 'LAI_year' , SITE_LAI_year )
+ CALL ncio_read_serial (fsrfdata, 'TREE_LAI' , SITE_LAI_monthly)
+ CALL ncio_read_serial (fsrfdata, 'TREE_SAI' , SITE_SAI_monthly)
+
+ CALL ncio_read_serial (fsrfdata, 'URBAN_TYPE' , SITE_urbtyp )
+ CALL ncio_read_serial (fsrfdata, 'LUCY_id' , SITE_lucyid )
+ CALL ncio_read_serial (fsrfdata, 'PCT_Tree' , SITE_fveg_urb )
+ CALL ncio_read_serial (fsrfdata, 'URBAN_TREE_TOP', SITE_htop_urb )
+ CALL ncio_read_serial (fsrfdata, 'PCT_Water' , SITE_flake_urb )
+ CALL ncio_read_serial (fsrfdata, 'WT_ROOF' , SITE_froof )
+ CALL ncio_read_serial (fsrfdata, 'HT_ROOF' , SITE_hroof )
+ CALL ncio_read_serial (fsrfdata, 'WTROAD_PERV' , SITE_fgper )
+ CALL ncio_read_serial (fsrfdata, 'BUILDING_HLR' , SITE_hlr )
+ CALL ncio_read_serial (fsrfdata, 'POP_DEN' , SITE_popden )
+
+ CALL ncio_read_serial (fsrfdata, 'EM_ROOF' , SITE_em_roof )
+ CALL ncio_read_serial (fsrfdata, 'EM_WALL' , SITE_em_wall )
+ CALL ncio_read_serial (fsrfdata, 'EM_IMPROAD' , SITE_em_gimp )
+ CALL ncio_read_serial (fsrfdata, 'EM_PERROAD' , SITE_em_gper )
+ CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax )
+ CALL ncio_read_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin )
+ CALL ncio_read_serial (fsrfdata, 'THICK_ROOF' , SITE_thickroof )
+ CALL ncio_read_serial (fsrfdata, 'THICK_WALL' , SITE_thickwall )
+
+ CALL ncio_read_serial (fsrfdata, 'ALB_ROOF' , SITE_alb_roof )
+ CALL ncio_read_serial (fsrfdata, 'ALB_WALL' , SITE_alb_wall )
+ CALL ncio_read_serial (fsrfdata, 'ALB_IMPROAD' , SITE_alb_gimp )
+ CALL ncio_read_serial (fsrfdata, 'ALB_PERROAD' , SITE_alb_gper )
+
+ CALL ncio_read_serial (fsrfdata, 'CV_ROOF' , SITE_cv_roof )
+ CALL ncio_read_serial (fsrfdata, 'CV_WALL' , SITE_cv_wall )
+ CALL ncio_read_serial (fsrfdata, 'CV_IMPROAD' , SITE_cv_gimp )
+ CALL ncio_read_serial (fsrfdata, 'TK_ROOF' , SITE_tk_roof )
+ CALL ncio_read_serial (fsrfdata, 'TK_WALL' , SITE_tk_wall )
+ CALL ncio_read_serial (fsrfdata, 'TK_IMPROAD' , SITE_tk_gimp )
+
+ CALL ncio_read_serial (fsrfdata, 'lakedepth' , SITE_lakedepth )
+
+ CALL ncio_read_serial (fsrfdata, 'soil_s_v_alb' , SITE_soil_s_v_alb)
+ CALL ncio_read_serial (fsrfdata, 'soil_d_v_alb' , SITE_soil_d_v_alb)
+ CALL ncio_read_serial (fsrfdata, 'soil_s_n_alb' , SITE_soil_s_n_alb)
+ CALL ncio_read_serial (fsrfdata, 'soil_d_n_alb' , SITE_soil_d_n_alb)
+
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral)
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_gravels' , SITE_soil_vf_gravels )
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_sand' , SITE_soil_vf_sand )
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_clay' , SITE_soil_vf_clay )
+ CALL ncio_read_serial (fsrfdata, 'soil_vf_om' , SITE_soil_vf_om )
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_gravels' , SITE_soil_wf_gravels )
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_sand' , SITE_soil_wf_sand )
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_clay' , SITE_soil_wf_clay )
+ CALL ncio_read_serial (fsrfdata, 'soil_wf_om' , SITE_soil_wf_om )
+
+ CALL ncio_read_serial (fsrfdata, 'soil_OM_density' , SITE_soil_OM_density)
+ CALL ncio_read_serial (fsrfdata, 'soil_BD_all' , SITE_soil_BD_all )
+ CALL ncio_read_serial (fsrfdata, 'soil_theta_s' , SITE_soil_theta_s )
+ CALL ncio_read_serial (fsrfdata, 'soil_k_s' , SITE_soil_k_s )
+ CALL ncio_read_serial (fsrfdata, 'soil_csol' , SITE_soil_csol )
+ CALL ncio_read_serial (fsrfdata, 'soil_tksatu' , SITE_soil_tksatu )
+ CALL ncio_read_serial (fsrfdata, 'soil_tksatf' , SITE_soil_tksatf )
+ CALL ncio_read_serial (fsrfdata, 'soil_tkdry' , SITE_soil_tkdry )
+ CALL ncio_read_serial (fsrfdata, 'soil_k_solids' , SITE_soil_k_solids )
+ CALL ncio_read_serial (fsrfdata, 'soil_lambda' , SITE_soil_lambda )
+ CALL ncio_read_serial (fsrfdata, 'soil_psi_s' , SITE_soil_psi_s )
+
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ CALL ncio_read_serial (fsrfdata, 'soil_theta_r' , SITE_soil_theta_r )
+ CALL ncio_read_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm)
+ CALL ncio_read_serial (fsrfdata, 'soil_L_vgm' , SITE_soil_L_vgm )
+ CALL ncio_read_serial (fsrfdata, 'soil_n_vgm' , SITE_soil_n_vgm )
+#endif
+
+ CALL ncio_read_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha)
+ CALL ncio_read_serial (fsrfdata, 'soil_BA_beta' , SITE_soil_BA_beta )
+
+ IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC
+ CALL ncio_read_serial (fsrfdata, 'soil_texture', SITE_soil_texture)
+ ENDIF
+
+ IF(DEF_USE_BEDROCK)THEN
+ CALL ncio_read_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock)
+ ENDIF
+
+ CALL ncio_read_serial (fsrfdata, 'elevation' , SITE_elevation )
+ CALL ncio_read_serial (fsrfdata, 'elvstd' , SITE_elvstd )
+ CALL ncio_read_serial (fsrfdata, 'sloperatio', SITE_sloperatio)
+
+ ! used for downscaling
+ IF (DEF_USE_Forcing_Downscaling) THEN
+ CALL ncio_read_serial (fsrfdata, 'SITE_svf' , SITE_svf )
+ CALL ncio_read_serial (fsrfdata, 'SITE_cur' , SITE_cur )
+ CALL ncio_read_serial (fsrfdata, 'SITE_sf_lut' , SITE_sf_lut )
+ CALL ncio_read_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type )
+ CALL ncio_read_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type )
+ CALL ncio_read_serial (fsrfdata, 'SITE_area_type', SITE_area_type)
+ ENDIF
+ ENDIF
+
+ IF (.not. for_surface_build) THEN
+
+ landpatch%nset = numpatch
+
+ allocate (landpatch%settyp (numpatch)); landpatch%settyp = SITE_landtype
+
+ landpatch%nblkgrp = 1
+ allocate (landpatch%xblkgrp(1)); landpatch%xblkgrp(1) = 1
+ allocate (landpatch%yblkgrp(1)); landpatch%yblkgrp(1) = 1
+
+ allocate (landpatch%vecgs%vlen(1,1)); landpatch%vecgs%vlen(1,1) = numpatch
+ allocate (landpatch%vecgs%vstt(1,1)); landpatch%vecgs%vstt(1,1) = 1
+ allocate (landpatch%vecgs%vend(1,1)); landpatch%vecgs%vend(1,1) = numpatch
+
+ landurban%nset = numurban
+
+ allocate (landurban%settyp (numurban)); landurban%settyp = SITE_urbtyp
+
+ landurban%nblkgrp = 1
+ allocate (landurban%xblkgrp(1)); landurban%xblkgrp(1) = 1
+ allocate (landurban%yblkgrp(1)); landurban%yblkgrp(1) = 1
+
+ allocate (landurban%vecgs%vlen(1,1)); landurban%vecgs%vlen(1,1) = numurban
+ allocate (landurban%vecgs%vstt(1,1)); landurban%vecgs%vstt(1,1) = 1
+ allocate (landurban%vecgs%vend(1,1)); landurban%vecgs%vend(1,1) = numurban
+
+ allocate (patch2urban (numurban)); patch2urban(1) = 1
+ allocate (urban2patch (numurban)); urban2patch(1) = 1
+
+ numelm = 1
+ allocate (landelm%settyp (1)); landelm%settyp (1) = 0
+ allocate (elm_patch%substt (1)); elm_patch%substt(1) = 1
+ allocate (elm_patch%subend (1)); elm_patch%subend(1) = numpatch
+ allocate (elm_patch%subfrc (numpatch)); elm_patch%subfrc = 1./numpatch
+
+ ENDIF
+
+ END SUBROUTINE read_urban_surface_data_single
+
+
+!-----------------------------------------------------------------------
+ SUBROUTINE write_surface_data_single (numpatch, numpft)
+
+ USE MOD_NetCDFSerial
+ USE MOD_Namelist
+ USE MOD_Const_LC
+ IMPLICIT NONE
+
+ integer, intent(in) :: numpatch
+ integer, intent(in), optional :: numpft
+
+ ! Local Variables
+ character(len=256) :: fsrfdata
+ integer :: ipft, iyear, itime
+ character(len=18) :: source
+
+ fsrfdata = trim(DEF_dir_landdata) // '/srfdata.nc'
+
+ CALL ncio_create_file (fsrfdata)
+
+ CALL ncio_define_dimension (fsrfdata, 'patch', numpatch)
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (numpft > 0) THEN
+ CALL ncio_define_dimension (fsrfdata, 'pft', numpft)
+ ENDIF
+#endif
+
+ CALL ncio_define_dimension (fsrfdata, 'LAI_year', size(SITE_LAI_year))
+ IF (DEF_LAI_MONTHLY) THEN
+ CALL ncio_define_dimension (fsrfdata, 'month', 12)
+ ELSE
+ CALL ncio_define_dimension (fsrfdata, 'J8day', 46)
+ ENDIF
+
+ CALL ncio_define_dimension (fsrfdata, 'soil', 8)
+
+ IF (DEF_USE_Forcing_Downscaling) THEN
+ CALL ncio_define_dimension (fsrfdata, 'slope_type', num_slope_type)
+ CALL ncio_define_dimension (fsrfdata, 'azi', num_azimuth)
+ CALL ncio_define_dimension (fsrfdata, 'zen', num_zenith)
+ ENDIF
+
+
+ CALL ncio_write_serial (fsrfdata, 'latitude', SITE_lat_location)
+ CALL ncio_put_attr (fsrfdata, 'latitude', 'units', 'degrees_north')
+
+ CALL ncio_write_serial (fsrfdata, 'longitude', SITE_lon_location)
+ CALL ncio_put_attr (fsrfdata, 'longitude','units', 'degrees_east')
+
+#ifdef LULC_USGS
+ CALL ncio_write_serial (fsrfdata, 'USGS_classification', SITE_landtype)
+ CALL ncio_put_attr (fsrfdata, 'USGS_classification', 'source', trim(datasource(u_site_landtype)))
+ CALL ncio_put_attr (fsrfdata, 'USGS_classification', 'long_name', 'GLCC USGS Land Use/Land Cover')
+#else
+ CALL ncio_write_serial (fsrfdata, 'IGBP_classification', SITE_landtype)
+ CALL ncio_put_attr (fsrfdata, 'IGBP_classification', 'source', trim(datasource(u_site_landtype)))
+ CALL ncio_put_attr (fsrfdata, 'IGBP_classification', 'long_name', 'MODIS IGBP Land Use/Land Cover')
+#endif
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (numpft > 0) THEN
+ CALL ncio_write_serial (fsrfdata, 'pfttyp', SITE_pfttyp, 'pft')
+ CALL ncio_put_attr (fsrfdata, 'pfttyp', 'source', trim(datasource(u_site_pfts)))
+ CALL ncio_put_attr (fsrfdata, 'pfttyp', 'long_name', 'plant functional type')
+
+ CALL ncio_write_serial (fsrfdata, 'pctpfts', SITE_pctpfts, 'pft')
+ CALL ncio_put_attr (fsrfdata, 'pctpfts', 'source', trim(datasource(u_site_pfts)))
+ CALL ncio_put_attr (fsrfdata, 'pctpfts', 'long_name', 'fraction of plant functional type')
+ ENDIF
+#endif
+#if (defined CROP)
+ IF (SITE_landtype == CROPLAND) THEN
+ CALL ncio_write_serial (fsrfdata, 'croptyp', SITE_croptyp, 'patch')
+ CALL ncio_put_attr (fsrfdata, 'croptyp', 'source', trim(datasource(u_site_crop)))
+ CALL ncio_put_attr (fsrfdata, 'croptyp', 'long_name', 'crop type')
+
+ CALL ncio_write_serial (fsrfdata, 'pctcrop', SITE_pctcrop, 'patch')
+ CALL ncio_put_attr (fsrfdata, 'pctcrop', 'source', trim(datasource(u_site_crop)))
+ CALL ncio_put_attr (fsrfdata, 'pctcrop', 'long_name', 'fraction of crop type')
+ ENDIF
+#endif
+
+ CALL ncio_write_serial (fsrfdata, 'canopy_height', SITE_htop)
+ CALL ncio_put_attr (fsrfdata, 'canopy_height', 'source', trim(datasource(u_site_htop)))
+ CALL ncio_put_attr (fsrfdata, 'canopy_height', 'long_name', 'canopy height')
+ CALL ncio_put_attr (fsrfdata, 'canopy_height', 'units', 'm')
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (numpft > 0) THEN
+ CALL ncio_write_serial (fsrfdata, 'canopy_height_pfts', SITE_htop_pfts, 'pft')
+ CALL ncio_put_attr (fsrfdata, 'canopy_height_pfts', 'source', trim(datasource(u_site_htop)))
+ CALL ncio_put_attr (fsrfdata, 'canopy_height_pfts', 'long_name', 'canopy height')
+ CALL ncio_put_attr (fsrfdata, 'canopy_height_pfts', 'units', 'm')
+ ENDIF
+#endif
+
+ source = trim(datasource(u_site_lai))
+ CALL ncio_write_serial (fsrfdata, 'LAI_year', SITE_LAI_year, 'LAI_year')
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (numpft > 0) THEN
+ CALL ncio_write_serial (fsrfdata, 'LAI_pfts_monthly', SITE_LAI_pfts_monthly, 'pft', 'month', 'LAI_year')
+ CALL ncio_put_attr (fsrfdata, 'LAI_pfts_monthly', 'source', source)
+ CALL ncio_put_attr (fsrfdata, 'LAI_pfts_monthly', 'long_name', 'monthly leaf area index associated with PFT')
+
+ CALL ncio_write_serial (fsrfdata, 'SAI_pfts_monthly', SITE_SAI_pfts_monthly, 'pft', 'month', 'LAI_year')
+ CALL ncio_put_attr (fsrfdata, 'SAI_pfts_monthly', 'source', source)
+ CALL ncio_put_attr (fsrfdata, 'SAI_pfts_monthly', 'long_name', 'monthly stem area index associated with PFT')
+ ELSE
+ CALL ncio_write_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly, 'month', 'LAI_year')
+ CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'source', source)
+ CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'long_name', 'monthly leaf area index')
+
+ CALL ncio_write_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly, 'month', 'LAI_year')
+ CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'source', source)
+ CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'long_name', 'monthly stem area index')
+ ENDIF
+#else
+ IF (DEF_LAI_MONTHLY) THEN
+ CALL ncio_write_serial (fsrfdata, 'LAI_monthly', SITE_LAI_monthly, 'month', 'LAI_year')
+ CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'source', source)
+ CALL ncio_put_attr (fsrfdata, 'LAI_monthly', 'long_name', 'monthly leaf area index')
+
+ CALL ncio_write_serial (fsrfdata, 'SAI_monthly', SITE_SAI_monthly, 'month', 'LAI_year')
+ CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'source', source)
+ CALL ncio_put_attr (fsrfdata, 'SAI_monthly', 'long_name', 'monthly stem area index')
+ ELSE
+ CALL ncio_write_serial (fsrfdata, 'LAI_8day', SITE_LAI_8day, 'J8day', 'LAI_year')
+ CALL ncio_put_attr (fsrfdata, 'LAI_8day', 'source', source)
+ CALL ncio_put_attr (fsrfdata, 'LAI_8day', 'long_name', '8-day leaf area index')
+ ENDIF
+#endif
+
+ CALL ncio_write_serial (fsrfdata, 'lakedepth', SITE_lakedepth)
+ CALL ncio_put_attr (fsrfdata, 'lakedepth', 'source', trim(datasource(u_site_lakedepth)))
+ CALL ncio_put_attr (fsrfdata, 'lakedepth', 'long_name', 'lake depth')
+ CALL ncio_put_attr (fsrfdata, 'lakedepth', 'units', 'm')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb)
+ CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'source', trim(datasource(u_site_soil_bright)))
+ CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'long_name', 'albedo of visible of the saturated soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb)
+ CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'source', trim(datasource(u_site_soil_bright)))
+ CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'long_name', 'albedo of visible of the dry soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb)
+ CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'source', trim(datasource(u_site_soil_bright)))
+ CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'long_name', 'albedo of near infrared of the saturated soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb)
+ CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'source', trim(datasource(u_site_soil_bright)))
+ CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'long_name', 'albedo of near infrared of the dry soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'source', trim(datasource(u_site_vf_quartz_mineral)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'long_name', 'volumetric fraction of quartz within mineral soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'source', trim(datasource(u_site_vf_gravels)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'long_name', 'volumetric fraction of gravels')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'source', trim(datasource(u_site_vf_sand)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'long_name', 'volumetric fraction of sand')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'source', trim(datasource(u_site_vf_clay)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'long_name', 'volumetric fraction of clay')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'source', trim(datasource(u_site_vf_om)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'long_name', 'volumetric fraction of organic matter')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'source', trim(datasource(u_site_wf_gravels)))
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'long_name', 'gravimetric fraction of gravels')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'source', trim(datasource(u_site_wf_sand)))
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'long_name', 'gravimetric fraction of sand')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'source', trim(datasource(u_site_wf_clay)))
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'long_name', 'gravimetric fraction of clay')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'source', trim(datasource(u_site_wf_om)))
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'long_name', 'gravimetric fraction of om')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'source', trim(datasource(u_site_OM_density)))
+ CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'long_name', 'OM density')
+ CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'units', 'kg/m3')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'source', trim(datasource(u_site_BD_all)))
+ CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'long_name', 'bulk density of soil (GRAVELS + OM + mineral soils)')
+ CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'units', 'kg/m3')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'source', trim(datasource(u_site_theta_s)))
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'long_name', 'saturated water content')
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'units', 'cm3/cm3')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'source', trim(datasource(u_site_k_s)))
+ CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'long_name', 'saturated hydraulic conductivity')
+ CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'units', 'cm/day')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_csol', SITE_soil_csol(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_csol', 'source', trim(datasource(u_site_csol)))
+ CALL ncio_put_attr (fsrfdata, 'soil_csol', 'long_name', 'heat capacity of soil solids')
+ CALL ncio_put_attr (fsrfdata, 'soil_csol', 'units', 'J/(m3 K)')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'source', trim(datasource(u_site_tksatu)))
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'long_name', 'thermal conductivity of saturated unfrozen soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'units', 'W/m-K')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'source', trim(datasource(u_site_tksatf)))
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'long_name', 'thermal conductivity of saturated frozen soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'units', 'W/m-K')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'source', trim(datasource(u_site_tkdry)))
+ CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'long_name', 'thermal conductivity for dry soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'units', 'W/(m-K)')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'source', trim(datasource(u_site_k_solids)))
+ CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'long_name', 'thermal conductivity of minerals soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'units', 'W/m-K')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'source', trim(datasource(u_site_lambda)))
+ CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'long_name', 'pore size distribution index (dimensionless)')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'source', trim(datasource(u_site_psi_s)))
+ CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'long_name', 'matric potential at saturation')
+ CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'units', 'cm')
+
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ CALL ncio_write_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'source', trim(datasource(u_site_theta_r)))
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'long_name', 'residual water content')
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'units', 'cm3/cm3')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'source', trim(datasource(u_site_alpha_vgm)))
+ CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'long_name', 'a parameter corresponding approximately to the inverse of the air-entry value')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'source', trim(datasource(u_site_L_vgm)))
+ CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'long_name', 'pore-connectivity parameter [dimensionless]')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'source', trim(datasource(u_site_n_vgm)))
+ CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'long_name', 'a shape parameter [dimensionless]')
+
+#endif
+
+ CALL ncio_write_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'source', trim(datasource(u_site_BA_alpha)))
+ CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'long_name', 'alpha in Balland and Arp(2005) thermal conductivity scheme')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_BA_beta', SITE_soil_BA_beta(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'source', trim(datasource(u_site_BA_beta)))
+ CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'long_name', 'beta in Balland and Arp(2005) thermal conductivity scheme')
+
+ IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC
+ CALL ncio_write_serial (fsrfdata, 'soil_texture ', SITE_soil_texture)
+ CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'source', trim(datasource(u_site_soil_texture)))
+ CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'long_name', 'USDA soil texture')
+ ENDIF
+
+ IF(DEF_USE_BEDROCK)THEN
+ CALL ncio_write_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock)
+ CALL ncio_put_attr (fsrfdata, 'depth_to_bedrock', 'source', trim(datasource(u_site_dbedrock)))
+ ENDIF
+
+ CALL ncio_write_serial (fsrfdata, 'elevation', SITE_elevation)
+ CALL ncio_put_attr (fsrfdata, 'elevation', 'source', trim(datasource(u_site_elevation)))
+
+ CALL ncio_write_serial (fsrfdata, 'elvstd', SITE_elvstd)
+ CALL ncio_put_attr (fsrfdata, 'elvstd', 'source', trim(datasource(u_site_elvstd)))
+ CALL ncio_put_attr (fsrfdata, 'elvstd', 'long_name', 'standard deviation of elevation')
+
+ CALL ncio_write_serial (fsrfdata, 'sloperatio', SITE_sloperatio)
+ CALL ncio_put_attr (fsrfdata, 'sloperatio', 'source', trim(datasource(u_site_sloperatio)))
+ CALL ncio_put_attr (fsrfdata, 'sloperatio', 'long_name', 'slope ratio')
+
+ ! used for downscaling
+ IF (DEF_USE_Forcing_Downscaling) THEN
+ CALL ncio_write_serial (fsrfdata, 'SITE_svf', SITE_svf)
+ CALL ncio_put_attr (fsrfdata, 'SITE_svf','source', trim(datasource(u_site_svf)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_svf','long_name', 'sky view factor')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_cur', SITE_cur)
+ CALL ncio_put_attr (fsrfdata, 'SITE_cur','source', trim(datasource(u_site_cur)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_cur','long_name', 'curvature')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut, 'azi', 'zen')
+ CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','source', trim(datasource(u_site_sf_lut)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','long_name', 'look up table of shadow factor')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type , 'type')
+ CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','source', trim(datasource(u_site_slp_type)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','long_name', 'topographic slope of each character')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type , 'type')
+ CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','source', trim(datasource(u_site_asp_type)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','long_name', 'topographic aspect of each character')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_area_type', SITE_area_type, 'type')
+ CALL ncio_put_attr (fsrfdata, 'SITE_area_type','source', trim(datasource(u_site_area_type)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_area_type','long_name', 'area percentage of each character')
+ ENDIF
+
+ END SUBROUTINE write_surface_data_single
+
+
+!-----------------------------------------------------------------------
+ SUBROUTINE write_urban_surface_data_single (numurban)
+
+ USE MOD_NetCDFSerial
+ USE MOD_Namelist
+ USE MOD_Const_LC
+ IMPLICIT NONE
+
+ integer, intent(in) :: numurban
+
+ ! Local Variables
+ character(len=256) :: fsrfdata
+ integer :: iyear, itime
+ character(len=8) :: source
+
+ fsrfdata = trim(DEF_dir_landdata) // '/srfdata.nc'
+
+ SITE_fgper = 1 - (SITE_fgimp-SITE_froof)/(1-SITE_froof-SITE_flake_urb)
+ SITE_froof = SITE_froof/(1-SITE_flake_urb)
+ SITE_fveg_urb = SITE_fveg_urb * 100
+ SITE_flake_urb = SITE_flake_urb * 100
+
+ CALL ncio_create_file (fsrfdata)
+
+ CALL ncio_define_dimension (fsrfdata, 'soil', 8)
+
+ CALL ncio_define_dimension (fsrfdata, 'azi', num_azimuth)
+ CALL ncio_define_dimension (fsrfdata, 'zen', num_zenith)
+ CALL ncio_define_dimension (fsrfdata, 'slope_type', num_slope_type)
+
+ CALL ncio_define_dimension (fsrfdata, 'patch', numurban)
+
+ CALL ncio_define_dimension (fsrfdata, 'LAI_year', size(SITE_LAI_year))
+ CALL ncio_define_dimension (fsrfdata, 'month', 12)
+
+ CALL ncio_define_dimension (fsrfdata, 'ulev' , 10)
+ CALL ncio_define_dimension (fsrfdata, 'numsolar', 2 )
+ CALL ncio_define_dimension (fsrfdata, 'numrad' , 2 )
+
+ CALL ncio_write_serial (fsrfdata, 'latitude' , SITE_lat_location)
+ CALL ncio_write_serial (fsrfdata, 'longitude', SITE_lon_location)
+
+ CALL ncio_write_serial (fsrfdata, 'LAI_year', SITE_LAI_year, 'LAI_year')
+ CALL ncio_write_serial (fsrfdata, 'TREE_LAI', SITE_LAI_monthly, 'month', 'LAI_year')
+ CALL ncio_write_serial (fsrfdata, 'TREE_SAI', SITE_SAI_monthly, 'month', 'LAI_year')
+ CALL ncio_put_attr (fsrfdata, 'TREE_LAI', 'source', trim(datasource(u_site_urblai)))
+ CALL ncio_put_attr (fsrfdata, 'TREE_SAI', 'source', trim(datasource(u_site_urbsai)))
+
+ CALL ncio_write_serial (fsrfdata, 'URBAN_TYPE' , SITE_urbtyp )
+ CALL ncio_write_serial (fsrfdata, 'LUCY_id' , SITE_lucyid )
+ CALL ncio_write_serial (fsrfdata, 'PCT_Tree' , SITE_fveg_urb )
+ CALL ncio_write_serial (fsrfdata, 'URBAN_TREE_TOP', SITE_htop_urb )
+ CALL ncio_write_serial (fsrfdata, 'PCT_Water' , SITE_flake_urb )
+ CALL ncio_write_serial (fsrfdata, 'WT_ROOF' , SITE_froof )
+ CALL ncio_write_serial (fsrfdata, 'HT_ROOF' , SITE_hroof )
+ CALL ncio_write_serial (fsrfdata, 'WTROAD_PERV' , SITE_fgper )
+ CALL ncio_write_serial (fsrfdata, 'BUILDING_HLR' , SITE_hlr )
+ CALL ncio_write_serial (fsrfdata, 'POP_DEN' , SITE_popden )
+
+ CALL ncio_put_attr (fsrfdata, 'PCT_Tree' , 'source', trim(datasource(u_site_fveg )))
+ CALL ncio_put_attr (fsrfdata, 'URBAN_TREE_TOP', 'source', trim(datasource(u_site_htopu)))
+ CALL ncio_put_attr (fsrfdata, 'PCT_Water' , 'source', trim(datasource(u_site_flake)))
+ CALL ncio_put_attr (fsrfdata, 'WT_ROOF' , 'source', trim(datasource(u_site_froof)))
+ CALL ncio_put_attr (fsrfdata, 'HT_ROOF' , 'source', trim(datasource(u_site_hroof)))
+ CALL ncio_put_attr (fsrfdata, 'WTROAD_PERV' , 'source', trim(datasource(u_site_fgper)))
+ CALL ncio_put_attr (fsrfdata, 'BUILDING_HLR' , 'source', trim(datasource(u_site_hlr )))
+ CALL ncio_put_attr (fsrfdata, 'POP_DEN' , 'source', trim(datasource(u_site_pop )))
+
+ CALL ncio_write_serial (fsrfdata, 'EM_ROOF' , SITE_em_roof )
+ CALL ncio_write_serial (fsrfdata, 'EM_WALL' , SITE_em_wall )
+ CALL ncio_write_serial (fsrfdata, 'EM_IMPROAD' , SITE_em_gimp )
+ CALL ncio_write_serial (fsrfdata, 'EM_PERROAD' , SITE_em_gper )
+ CALL ncio_write_serial (fsrfdata, 'T_BUILDING_MAX', SITE_t_roommax )
+ CALL ncio_write_serial (fsrfdata, 'T_BUILDING_MIN', SITE_t_roommin )
+ CALL ncio_write_serial (fsrfdata, 'THICK_ROOF' , SITE_thickroof )
+ CALL ncio_write_serial (fsrfdata, 'THICK_WALL' , SITE_thickwall )
+
+ CALL ncio_put_attr (fsrfdata, 'EM_ROOF' , 'source', trim(datasource(u_site_emr )))
+ CALL ncio_put_attr (fsrfdata, 'EM_WALL' , 'source', trim(datasource(u_site_emw )))
+ CALL ncio_put_attr (fsrfdata, 'EM_IMPROAD' , 'source', trim(datasource(u_site_emgimp)))
+ CALL ncio_put_attr (fsrfdata, 'EM_PERROAD' , 'source', trim(datasource(u_site_emgper)))
+ CALL ncio_put_attr (fsrfdata, 'T_BUILDING_MAX', 'source', trim(datasource(u_site_tbmax )))
+ CALL ncio_put_attr (fsrfdata, 'T_BUILDING_MIN', 'source', trim(datasource(u_site_tbmin )))
+ CALL ncio_put_attr (fsrfdata, 'THICK_ROOF' , 'source', trim(datasource(u_site_thickr)))
+ CALL ncio_put_attr (fsrfdata, 'THICK_WALL' , 'source', trim(datasource(u_site_thickw)))
+
+ CALL ncio_write_serial (fsrfdata, 'ALB_ROOF' , SITE_alb_roof , 'numrad', 'numsolar')
+ CALL ncio_write_serial (fsrfdata, 'ALB_WALL' , SITE_alb_wall , 'numrad', 'numsolar')
+ CALL ncio_write_serial (fsrfdata, 'ALB_IMPROAD' , SITE_alb_gimp , 'numrad', 'numsolar')
+ CALL ncio_write_serial (fsrfdata, 'ALB_PERROAD' , SITE_alb_gper , 'numrad', 'numsolar')
+
+ CALL ncio_put_attr (fsrfdata, 'ALB_ROOF' , 'source', trim(datasource(u_site_albr )))
+ CALL ncio_put_attr (fsrfdata, 'ALB_WALL' , 'source', trim(datasource(u_site_albw )))
+ CALL ncio_put_attr (fsrfdata, 'ALB_IMPROAD' , 'source', trim(datasource(u_site_albgimp)))
+ CALL ncio_put_attr (fsrfdata, 'ALB_PERROAD' , 'source', trim(datasource(u_site_albgper)))
+
+ CALL ncio_write_serial (fsrfdata, 'CV_ROOF' , SITE_cv_roof , 'ulev')
+ CALL ncio_write_serial (fsrfdata, 'CV_WALL' , SITE_cv_wall , 'ulev')
+ CALL ncio_write_serial (fsrfdata, 'CV_IMPROAD' , SITE_cv_gimp , 'ulev')
+ CALL ncio_write_serial (fsrfdata, 'TK_ROOF' , SITE_tk_roof , 'ulev')
+ CALL ncio_write_serial (fsrfdata, 'TK_WALL' , SITE_tk_wall , 'ulev')
+ CALL ncio_write_serial (fsrfdata, 'TK_IMPROAD' , SITE_tk_gimp , 'ulev')
+
+ CALL ncio_put_attr (fsrfdata, 'CV_ROOF' , 'source', trim(datasource(u_site_cvr )))
+ CALL ncio_put_attr (fsrfdata, 'CV_WALL' , 'source', trim(datasource(u_site_cvw )))
+ CALL ncio_put_attr (fsrfdata, 'CV_IMPROAD' , 'source', trim(datasource(u_site_cvgimp)))
+ CALL ncio_put_attr (fsrfdata, 'TK_ROOF' , 'source', trim(datasource(u_site_tkr )))
+ CALL ncio_put_attr (fsrfdata, 'TK_WALL' , 'source', trim(datasource(u_site_tkw )))
+ CALL ncio_put_attr (fsrfdata, 'TK_IMPROAD' , 'source', trim(datasource(u_site_tkgimp)))
+
+ CALL ncio_write_serial (fsrfdata, 'lakedepth', SITE_lakedepth)
+ CALL ncio_put_attr (fsrfdata, 'lakedepth', 'source', trim(datasource(u_site_lakedepth)))
+ CALL ncio_put_attr (fsrfdata, 'lakedepth', 'long_name', 'lake depth')
+ CALL ncio_put_attr (fsrfdata, 'lakedepth', 'units', 'm')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_s_v_alb', SITE_soil_s_v_alb)
+ CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'source', trim(datasource(u_site_soil_bright)))
+ CALL ncio_put_attr (fsrfdata, 'soil_s_v_alb', 'long_name', 'albedo of visible of the saturated soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_d_v_alb', SITE_soil_d_v_alb)
+ CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'source', trim(datasource(u_site_soil_bright)))
+ CALL ncio_put_attr (fsrfdata, 'soil_d_v_alb', 'long_name', 'albedo of visible of the dry soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_s_n_alb', SITE_soil_s_n_alb)
+ CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'source', trim(datasource(u_site_soil_bright)))
+ CALL ncio_put_attr (fsrfdata, 'soil_s_n_alb', 'long_name', 'albedo of near infrared of the saturated soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_d_n_alb', SITE_soil_d_n_alb)
+ CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'source', trim(datasource(u_site_soil_bright)))
+ CALL ncio_put_attr (fsrfdata, 'soil_d_n_alb', 'long_name', 'albedo of near infrared of the dry soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_quartz_mineral', SITE_soil_vf_quartz_mineral(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'source', trim(datasource(u_site_vf_quartz_mineral)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_quartz_mineral', 'long_name', 'volumetric fraction of quartz within mineral soil')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_gravels', SITE_soil_vf_gravels(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'source', trim(datasource(u_site_vf_gravels)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_gravels', 'long_name', 'volumetric fraction of gravels')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_sand', SITE_soil_vf_sand(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'source', trim(datasource(u_site_vf_sand)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_sand', 'long_name', 'volumetric fraction of sand')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_clay', SITE_soil_vf_clay(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'source', trim(datasource(u_site_vf_clay)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_clay', 'long_name', 'volumetric fraction of clay')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_vf_om', SITE_soil_vf_om(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'source', trim(datasource(u_site_vf_om)))
+ CALL ncio_put_attr (fsrfdata, 'soil_vf_om', 'long_name', 'volumetric fraction of organic matter')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_wf_gravels', SITE_soil_wf_gravels(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'source', trim(datasource(u_site_wf_gravels)))
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_gravels', 'long_name', 'gravimetric fraction of gravels')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_wf_sand', SITE_soil_wf_sand(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'source', trim(datasource(u_site_wf_sand)))
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_sand', 'long_name', 'gravimetric fraction of sand')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_wf_clay', SITE_soil_wf_clay(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'source', trim(datasource(u_site_wf_clay)))
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_clay', 'long_name', 'gravimetric fraction of clay')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_wf_om', SITE_soil_wf_om(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'source', trim(datasource(u_site_wf_om)))
+ CALL ncio_put_attr (fsrfdata, 'soil_wf_om', 'long_name', 'gravimetric fraction of om')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_OM_density', SITE_soil_OM_density(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'source', trim(datasource(u_site_OM_density)))
+ CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'long_name', 'OM density')
+ CALL ncio_put_attr (fsrfdata, 'soil_OM_density', 'units', 'kg/m3')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_BD_all', SITE_soil_BD_all(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'source', trim(datasource(u_site_BD_all)))
+ CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'long_name', 'bulk density of soil (GRAVELS + OM + mineral soils)')
+ CALL ncio_put_attr (fsrfdata, 'soil_BD_all', 'units', 'kg/m3')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_theta_s', SITE_soil_theta_s(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'source', trim(datasource(u_site_theta_s)))
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'long_name', 'saturated water content')
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_s', 'units', 'cm3/cm3')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_k_s', SITE_soil_k_s(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'source', trim(datasource(u_site_k_s)))
+ CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'long_name', 'saturated hydraulic conductivity')
+ CALL ncio_put_attr (fsrfdata, 'soil_k_s', 'units', 'cm/day')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_csol', SITE_soil_csol(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_csol', 'source', trim(datasource(u_site_csol)))
+ CALL ncio_put_attr (fsrfdata, 'soil_csol', 'long_name', 'heat capacity of soil solids')
+ CALL ncio_put_attr (fsrfdata, 'soil_csol', 'units', 'J/(m3 K)')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_tksatu', SITE_soil_tksatu(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'source', trim(datasource(u_site_tksatu)))
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'long_name', 'thermal conductivity of saturated unfrozen soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatu', 'units', 'W/m-K')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_tksatf', SITE_soil_tksatf(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'source', trim(datasource(u_site_tksatf)))
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'long_name', 'thermal conductivity of saturated frozen soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tksatf', 'units', 'W/m-K')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_tkdry', SITE_soil_tkdry(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'source', trim(datasource(u_site_tkdry)))
+ CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'long_name', 'thermal conductivity for dry soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_tkdry', 'units', 'W/(m-K)')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_k_solids', SITE_soil_k_solids(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'source', trim(datasource(u_site_k_solids)))
+ CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'long_name', 'thermal conductivity of minerals soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_k_solids', 'units', 'W/m-K')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_lambda', SITE_soil_lambda(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'source', trim(datasource(u_site_lambda)))
+ CALL ncio_put_attr (fsrfdata, 'soil_lambda', 'long_name', 'pore size distribution index (dimensionless)')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_psi_s', SITE_soil_psi_s(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'source', trim(datasource(u_site_psi_s)))
+ CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'long_name', 'matric potential at saturation')
+ CALL ncio_put_attr (fsrfdata, 'soil_psi_s ', 'units', 'cm')
+
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ CALL ncio_write_serial (fsrfdata, 'soil_theta_r', SITE_soil_theta_r(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'source', trim(datasource(u_site_theta_r)))
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'long_name', 'residual water content')
+ CALL ncio_put_attr (fsrfdata, 'soil_theta_r', 'units', 'cm3/cm3')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_alpha_vgm', SITE_soil_alpha_vgm(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'source', trim(datasource(u_site_alpha_vgm)))
+ CALL ncio_put_attr (fsrfdata, 'soil_alpha_vgm', 'long_name', 'a parameter corresponding approximately to the inverse of the air-entry value')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_L_vgm', SITE_soil_L_vgm(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'source', trim(datasource(u_site_L_vgm)))
+ CALL ncio_put_attr (fsrfdata, 'soil_L_vgm', 'long_name', 'pore-connectivity parameter [dimensionless]')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_n_vgm', SITE_soil_n_vgm(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'source', trim(datasource(u_site_n_vgm)))
+ CALL ncio_put_attr (fsrfdata, 'soil_n_vgm', 'long_name', 'a shape parameter [dimensionless]')
+
+#endif
+
+ CALL ncio_write_serial (fsrfdata, 'soil_BA_alpha', SITE_soil_BA_alpha(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'source', trim(datasource(u_site_BA_alpha)))
+ CALL ncio_put_attr (fsrfdata, 'soil_BA_alpha', 'long_name', 'alpha in Balland and Arp(2005) thermal conductivity scheme')
+
+ CALL ncio_write_serial (fsrfdata, 'soil_BA_beta', SITE_soil_BA_beta(1:8), 'soil')
+ CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'source', trim(datasource(u_site_BA_beta)))
+ CALL ncio_put_attr (fsrfdata, 'soil_BA_beta', 'long_name', 'beta in Balland and Arp(2005) thermal conductivity scheme')
+
+ IF (DEF_Runoff_SCHEME == 3) THEN ! for Simple VIC
+ CALL ncio_write_serial (fsrfdata, 'soil_texture ', SITE_soil_texture)
+ CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'source', trim(datasource(u_site_soil_texture)))
+ CALL ncio_put_attr (fsrfdata, 'soil_texture ', 'long_name', 'USDA soil texture')
+ ENDIF
+
+ IF(DEF_USE_BEDROCK)THEN
+ CALL ncio_write_serial (fsrfdata, 'depth_to_bedrock', SITE_dbedrock)
+ CALL ncio_put_attr (fsrfdata, 'depth_to_bedrock', 'source', trim(datasource(u_site_dbedrock)))
+ ENDIF
+
+ CALL ncio_write_serial (fsrfdata, 'elevation', SITE_elevation)
+ CALL ncio_put_attr (fsrfdata, 'elevation', 'source', trim(datasource(u_site_elevation)))
+
+ CALL ncio_write_serial (fsrfdata, 'elvstd', SITE_elvstd)
+ CALL ncio_put_attr (fsrfdata, 'elvstd', 'source', trim(datasource(u_site_elvstd)))
+ CALL ncio_put_attr (fsrfdata, 'elvstd', 'long_name', 'standard deviation of elevation')
+
+ CALL ncio_write_serial (fsrfdata, 'sloperatio', SITE_sloperatio)
+ CALL ncio_put_attr (fsrfdata, 'sloperatio', 'source', trim(datasource(u_site_sloperatio)))
+ CALL ncio_put_attr (fsrfdata, 'sloperatio', 'long_name', 'slope ratio')
+
+ ! used for downscaling
+ IF (DEF_USE_Forcing_Downscaling) THEN
+ CALL ncio_write_serial (fsrfdata, 'SITE_svf', SITE_svf)
+ CALL ncio_put_attr (fsrfdata, 'SITE_svf','source', trim(datasource(u_site_svf)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_svf','long_name', 'sky view factor')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_cur', SITE_cur)
+ CALL ncio_put_attr (fsrfdata, 'SITE_cur','source', trim(datasource(u_site_cur)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_cur','long_name', 'curvature')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_sf_lut', SITE_sf_lut, 'azi', 'zen')
+ CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','source', trim(datasource(u_site_sf_lut)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_sf_lut','long_name', 'look up table of shadow factor')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_slp_type' , SITE_slp_type , 'type')
+ CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','source', trim(datasource(u_site_slp_type)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_slp_type','long_name', 'topographic slope of each character')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_asp_type' , SITE_asp_type , 'type')
+ CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','source', trim(datasource(u_site_asp_type)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_asp_type','long_name', 'topographic aspect of each character')
+
+ CALL ncio_write_serial (fsrfdata, 'SITE_area_type', SITE_area_type, 'type')
+ CALL ncio_put_attr (fsrfdata, 'SITE_area_type','source', trim(datasource(u_site_area_type)))
+ CALL ncio_put_attr (fsrfdata, 'SITE_area_type','long_name', 'area percentage of each character')
+ ENDIF
+
+ END SUBROUTINE write_urban_surface_data_single
+
+
+!-----------------------------------------------------------------------
+ character(len=18) FUNCTION datasource (is_site)
+
+ IMPLICIT NONE
+ logical, intent(in) :: is_site
+
+ IF (is_site) THEN
+ datasource = 'SITE'
+ ELSE
+ datasource = 'CoLM 2024 raw data'
+ ENDIF
+
+ END FUNCTION datasource
+
+
+!-----------------------------------------------------------------------
+ SUBROUTINE single_srfdata_final ()
+
+ IMPLICIT NONE
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (allocated(SITE_pfttyp )) deallocate(SITE_pfttyp )
+ IF (allocated(SITE_pctpfts)) deallocate(SITE_pctpfts)
+#endif
+
+#ifdef CROP
+ IF (allocated(SITE_croptyp)) deallocate(SITE_croptyp)
+ IF (allocated(SITE_pctcrop)) deallocate(SITE_pctcrop)
+#endif
+
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (allocated(SITE_htop_pfts)) deallocate(SITE_htop_pfts)
+#endif
+
+ IF (allocated(SITE_LAI_monthly)) deallocate(SITE_LAI_monthly)
+ IF (allocated(SITE_SAI_monthly)) deallocate(SITE_SAI_monthly)
+#if (defined LULC_IGBP_PFT || defined LULC_IGBP_PC)
+ IF (allocated(SITE_LAI_pfts_monthly)) deallocate(SITE_LAI_pfts_monthly)
+ IF (allocated(SITE_SAI_pfts_monthly)) deallocate(SITE_SAI_pfts_monthly)
+#endif
+
+ IF (allocated(SITE_LAI_year)) deallocate(SITE_LAI_year)
+ IF (allocated(SITE_LAI_8day)) deallocate(SITE_LAI_8day)
+
+ IF (allocated(SITE_soil_vf_quartz_mineral)) deallocate(SITE_soil_vf_quartz_mineral)
+ IF (allocated(SITE_soil_vf_gravels )) deallocate(SITE_soil_vf_gravels )
+ IF (allocated(SITE_soil_vf_sand )) deallocate(SITE_soil_vf_sand )
+ IF (allocated(SITE_soil_vf_clay )) deallocate(SITE_soil_vf_clay )
+ IF (allocated(SITE_soil_vf_om )) deallocate(SITE_soil_vf_om )
+ IF (allocated(SITE_soil_wf_gravels )) deallocate(SITE_soil_wf_gravels )
+ IF (allocated(SITE_soil_wf_sand )) deallocate(SITE_soil_wf_sand )
+ IF (allocated(SITE_soil_wf_clay )) deallocate(SITE_soil_wf_clay )
+ IF (allocated(SITE_soil_wf_om )) deallocate(SITE_soil_wf_om )
+ IF (allocated(SITE_soil_OM_density )) deallocate(SITE_soil_OM_density )
+ IF (allocated(SITE_soil_BD_all )) deallocate(SITE_soil_BD_all )
+ IF (allocated(SITE_soil_theta_s )) deallocate(SITE_soil_theta_s )
+ IF (allocated(SITE_soil_k_s )) deallocate(SITE_soil_k_s )
+ IF (allocated(SITE_soil_csol )) deallocate(SITE_soil_csol )
+ IF (allocated(SITE_soil_tksatu )) deallocate(SITE_soil_tksatu )
+ IF (allocated(SITE_soil_tksatf )) deallocate(SITE_soil_tksatf )
+ IF (allocated(SITE_soil_tkdry )) deallocate(SITE_soil_tkdry )
+ IF (allocated(SITE_soil_k_solids )) deallocate(SITE_soil_k_solids )
+ IF (allocated(SITE_soil_psi_s )) deallocate(SITE_soil_psi_s )
+ IF (allocated(SITE_soil_lambda )) deallocate(SITE_soil_lambda )
+ IF (allocated(SITE_soil_theta_r )) deallocate(SITE_soil_theta_r )
+#ifdef vanGenuchten_Mualem_SOIL_MODEL
+ IF (allocated(SITE_soil_alpha_vgm )) deallocate(SITE_soil_alpha_vgm )
+ IF (allocated(SITE_soil_L_vgm )) deallocate(SITE_soil_L_vgm )
+ IF (allocated(SITE_soil_n_vgm )) deallocate(SITE_soil_n_vgm )
+#endif
+ IF (allocated(SITE_soil_BA_alpha )) deallocate(SITE_soil_BA_alpha )
+ IF (allocated(SITE_soil_BA_beta )) deallocate(SITE_soil_BA_beta )
+
+ IF (allocated(SITE_sf_lut )) deallocate(SITE_sf_lut )
+ IF (allocated(SITE_slp_type )) deallocate(SITE_slp_type )
+ IF (allocated(SITE_asp_type )) deallocate(SITE_asp_type )
+ IF (allocated(SITE_area_type )) deallocate(SITE_area_type )
+
+ END SUBROUTINE single_srfdata_final
+
+END MODULE MOD_SingleSrfdata
+#endif
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..a47fa6e21c
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SpatialMapping.F90
@@ -0,0 +1,2887 @@
+#include
+
+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_SPMD_Task
+ 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
+
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_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 (p_is_compute) 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)
+
+ 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 (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_list1 ( &
+ ix, ng_lat(iy), list_lat(iy)%val, iloc)
+
+ IF (ng_lat(iy) == size(list_lat(iy)%val)) THEN
+ CALL expand_list (list_lat(iy)%val, 0.2_r8)
+ ENDIF
+
+ 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)
+
+#ifdef USEMPI
+ allocate (ipt (ng_all))
+ allocate (msk (ng_all))
+ DO ig = 1, ng_all
+ xblk = fgrid%xblk(xlist(ig))
+ yblk = fgrid%yblk(ylist(ig))
+ ipt(ig) = gblock%pio(xblk,yblk)
+ ENDDO
+#endif
+
+ allocate (this%glist (0:p_np_active-1))
+ DO iproc = 0, p_np_active-1
+#ifdef USEMPI
+ msk = (ipt == p_address_active(iproc))
+ ng = count(msk)
+#else
+ ng = ng_all
+#endif
+
+ this%glist(iproc)%ng = ng
+
+ IF (ng > 0) THEN
+ allocate (this%glist(iproc)%ilat (ng))
+ allocate (this%glist(iproc)%ilon (ng))
+
+#ifdef USEMPI
+ this%glist(iproc)%ilon = pack(xlist, msk)
+ this%glist(iproc)%ilat = pack(ylist, msk)
+#else
+ this%glist(iproc)%ilon = xlist
+ this%glist(iproc)%ilat = ylist
+#endif
+ ENDIF
+ ENDDO
+
+#ifdef USEMPI
+ deallocate (ipt)
+ deallocate (msk)
+#endif
+
+ 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)
+
+#ifdef USEMPI
+ iproc = p_itis_active(gblock%pio(xblk,yblk))
+#else
+ iproc = 0
+#endif
+
+ 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 defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ IF (p_is_compute) THEN
+
+ DO iproc = 0, p_np_active-1
+ idest = p_address_active(iproc)
+ smesg = (/p_iam_glb, this%glist(iproc)%ng/)
+
+ CALL mpi_send (smesg, 2, MPI_INTEGER, &
+ idest, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (this%glist(iproc)%ng > 0) THEN
+ CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (p_is_active) THEN
+
+ allocate (this%glist (0:p_np_compute-1))
+
+ DO irank = 0, p_np_compute-1
+
+ CALL mpi_recv (rmesg, 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = rmesg(1)
+ nrecv = rmesg(2)
+ iproc = p_itis_compute(isrc)
+
+ this%glist(iproc)%ng = nrecv
+
+ IF (nrecv > 0) THEN
+ allocate (this%glist(iproc)%ilon (nrecv))
+ allocate (this%glist(iproc)%ilat (nrecv))
+
+ CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+ ENDDO
+
+ ENDIF
+#endif
+
+ IF (p_is_compute) 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
+
+ IF (p_is_active) CALL allocate_block_data (fgrid, this%areagrid)
+ IF (p_is_compute) 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)
+
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#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_SPMD_Task
+ 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
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_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 (p_is_compute) 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
+
+#ifdef USEMPI
+ allocate (ipt (nglist))
+ allocate (msk (nglist))
+ DO ig = 1, nglist
+ xblk = this%grid%xblk(xlist(ig))
+ yblk = this%grid%yblk(ylist(ig))
+ ipt(ig) = gblock%pio(xblk,yblk)
+ ENDDO
+#endif
+
+ allocate (this%glist (0:p_np_active-1))
+ DO iproc = 0, p_np_active-1
+#ifdef USEMPI
+ msk = (ipt == p_address_active(iproc))
+ ng = count(msk)
+#else
+ ng = nglist
+#endif
+
+ this%glist(iproc)%ng = ng
+
+ IF (ng > 0) THEN
+ allocate (this%glist(iproc)%ilat (ng))
+ allocate (this%glist(iproc)%ilon (ng))
+
+#ifdef USEMPI
+ this%glist(iproc)%ilon = pack(xlist(1:nglist), msk)
+ this%glist(iproc)%ilat = pack(ylist(1:nglist), msk)
+#else
+ this%glist(iproc)%ilon = xlist(1:nglist)
+ this%glist(iproc)%ilat = ylist(1:nglist)
+#endif
+ ENDIF
+
+ ENDDO
+
+ deallocate (xlist)
+ deallocate (ylist)
+
+#ifdef USEMPI
+ deallocate (ipt)
+ deallocate (msk)
+#endif
+ ENDIF
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ IF (p_is_compute) THEN
+ DO iproc = 0, p_np_active-1
+ idest = p_address_active(iproc)
+ smesg = (/p_iam_glb, this%glist(iproc)%ng/)
+
+ CALL mpi_send (smesg, 2, MPI_INTEGER, &
+ idest, mpi_tag_mesg, p_comm_glb, p_err)
+
+ IF (this%glist(iproc)%ng > 0) THEN
+ CALL mpi_send (this%glist(iproc)%ilon, this%glist(iproc)%ng, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ CALL mpi_send (this%glist(iproc)%ilat, this%glist(iproc)%ng, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (p_is_active) THEN
+
+ allocate (this%glist (0:p_np_compute-1))
+
+ DO irank = 0, p_np_compute-1
+
+ CALL mpi_recv (rmesg, 2, MPI_INTEGER, &
+ MPI_ANY_SOURCE, mpi_tag_mesg, p_comm_glb, p_stat, p_err)
+
+ isrc = rmesg(1)
+ nrecv = rmesg(2)
+ iproc = p_itis_compute(isrc)
+
+ this%glist(iproc)%ng = nrecv
+
+ IF (nrecv > 0) THEN
+ allocate (this%glist(iproc)%ilon (nrecv))
+ allocate (this%glist(iproc)%ilat (nrecv))
+
+ CALL mpi_recv (this%glist(iproc)%ilon, nrecv, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ CALL mpi_recv (this%glist(iproc)%ilat, nrecv, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_compute) 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);
+#ifdef USEMPI
+ xblk = this%grid%xblk(ix)
+ yblk = this%grid%yblk(iy)
+ iproc = p_itis_active(gblock%pio(xblk,yblk))
+#else
+ iproc = 0
+#endif
+ 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);
+#ifdef USEMPI
+ xblk = this%grid%xblk(ix)
+ yblk = this%grid%yblk(iy)
+ iproc = p_itis_active(gblock%pio(xblk,yblk))
+#else
+ iproc = 0
+#endif
+ 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);
+#ifdef USEMPI
+ xblk = this%grid%xblk(ix)
+ yblk = this%grid%yblk(iy)
+ iproc = p_itis_active(gblock%pio(xblk,yblk))
+#else
+ iproc = 0
+#endif
+ 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);
+#ifdef USEMPI
+ xblk = this%grid%xblk(ix)
+ yblk = this%grid%yblk(iy)
+ iproc = p_itis_active(gblock%pio(xblk,yblk))
+#else
+ iproc = 0
+#endif
+ 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 (p_is_compute) 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
+
+ IF (p_is_active) CALL allocate_block_data (fgrid, this%areagrid)
+ IF (p_is_compute) 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(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)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ 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_SPMD_Task
+ 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 (p_is_active) THEN
+
+ DO iproc = 0, p_np_compute-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
+
+#ifdef USEMPI
+ idest = p_address_compute(iproc)
+ CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (gbuff)
+#endif
+ 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 (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (pbuff(iproc)%val (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_active(iproc)
+ CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ pbuff(0)%val = gbuff
+ deallocate (gbuff)
+#endif
+ 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, p_np_active-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_SPMD_Task
+ 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 (p_is_compute) THEN
+
+ inmode = 'average'
+ IF (present(input_mode)) inmode = trim(input_mode)
+
+ allocate (pbuff (0:p_np_active-1))
+
+ DO iproc = 0, p_np_active-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
+
+#ifdef USEMPI
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+ idest = p_address_active(iproc)
+ CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDDO
+#endif
+
+ ENDIF
+
+ IF (p_is_active) THEN
+
+ IF (present(spv)) THEN
+ CALL flush_block_data (gdata, spv)
+ ELSE
+ CALL flush_block_data (gdata, 0.0_r8)
+ ENDIF
+
+ DO iproc = 0, p_np_compute-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (gbuff (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_compute(iproc)
+ CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ gbuff = pbuff(0)%val
+#endif
+
+ 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 (p_is_compute) THEN
+ DO iproc = 0, p_np_active-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_SPMD_Task
+ 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 (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+
+ lb1 = lbound(pdata,1)
+ ub1 = ubound(pdata,1)
+
+ DO iproc = 0, p_np_active-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
+
+#ifdef USEMPI
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+ idest = p_address_active(iproc)
+ CALL mpi_send (pbuff(iproc)%val, &
+ (ub1-lb1+1) * this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ ENDIF
+ ENDDO
+#endif
+
+ ENDIF
+
+ IF (p_is_active) 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, p_np_compute-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (gbuff (lb1:ub1, this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_compute(iproc)
+ CALL mpi_recv (gbuff, &
+ (ub1-lb1+1) * this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ gbuff = pbuff(0)%val
+#endif
+
+ 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 (p_is_compute) THEN
+ DO iproc = 0, p_np_active-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_SPMD_Task
+ 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 (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-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, p_np_active-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
+
+#ifdef USEMPI
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+ idest = p_address_active(iproc)
+ CALL mpi_send (pbuff(iproc)%val, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDDO
+#endif
+
+ ENDIF
+
+ IF (p_is_active) 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, p_np_compute-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (gbuff (lb1:ub1, lb2:ub2, this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_compute(iproc)
+ CALL mpi_recv (gbuff, ndim1 * ndim2 * this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ gbuff = pbuff(0)%val
+#endif
+
+ 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 (p_is_compute) THEN
+ DO iproc = 0, p_np_active-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_SPMD_Task
+ 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 (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+
+ DO iproc = 0, p_np_active-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
+
+#ifdef USEMPI
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+ idest = p_address_active(iproc)
+ CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDDO
+#endif
+
+ ENDIF
+
+ IF (p_is_active) THEN
+
+ CALL flush_block_data (gdata, spval)
+
+ DO iproc = 0, p_np_compute-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (gbuff (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_compute(iproc)
+ CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ gbuff = pbuff(0)%val
+#endif
+
+ 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 (p_is_compute) THEN
+ DO iproc = 0, p_np_active-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_SPMD_Task
+ 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 (p_is_compute) THEN
+ allocate (pbuff (0:p_np_active-1))
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+ allocate (pbuff(iproc)%val (this%glist(iproc)%ng))
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF (p_is_active) THEN
+ CALL flush_block_data (gdata, spv)
+ ENDIF
+
+ ntyps = size(typidx)
+
+ DO ityp = 1, ntyps
+
+ IF (p_is_compute) THEN
+
+ DO iproc = 0, p_np_active-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
+
+#ifdef USEMPI
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+ idest = p_address_active(iproc)
+ CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDDO
+#endif
+
+ ENDIF
+
+ IF (p_is_active) THEN
+
+ DO iproc = 0, p_np_compute-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (gbuff (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_compute(iproc)
+ CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ gbuff = pbuff(0)%val
+#endif
+
+ 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
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+ ENDDO
+
+ IF (p_is_compute) THEN
+ DO iproc = 0, p_np_active-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_SPMD_Task
+ 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 (p_is_active) CALL flush_block_data (sumarea, 0.0_r8)
+
+ IF (p_is_compute) 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 (p_address_active(iproc) /= p_iam_glb) 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 (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+
+ DO iproc = 0, p_np_active-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
+
+#ifdef USEMPI
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+ idest = p_address_active(iproc)
+ CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDDO
+#endif
+
+ ENDIF
+
+ IF (p_is_active) THEN
+
+ CALL flush_block_data (sumarea, 0.0_r8)
+
+ DO iproc = 0, p_np_compute-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (gbuff (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_compute(iproc)
+ CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ gbuff = pbuff(0)%val
+#endif
+
+ 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 (p_is_compute) THEN
+ DO iproc = 0, p_np_active-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_SPMD_Task
+ 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 (p_is_active) THEN
+
+ DO iproc = 0, p_np_compute-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
+
+#ifdef USEMPI
+ idest = p_address_compute(iproc)
+ CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (gbuff)
+#endif
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (pbuff(iproc)%val (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_active(iproc)
+ CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ pbuff(0)%val = gbuff
+ deallocate (gbuff)
+#endif
+ 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, p_np_active-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_SPMD_Task
+ 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 (p_is_active) THEN
+
+ DO iproc = 0, p_np_compute-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
+
+#ifdef USEMPI
+ idest = p_address_compute(iproc)
+ CALL mpi_send (gbuff, ndim1 * this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (gbuff)
+#endif
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (pbuff(iproc)%val (ndim1, this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_active(iproc)
+ CALL mpi_recv (pbuff(iproc)%val, ndim1 * this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ pbuff(0)%val = gbuff
+ deallocate (gbuff)
+#endif
+ 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, p_np_active-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_SPMD_Task
+ 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 (p_is_active) THEN
+
+ DO iproc = 0, p_np_compute-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
+
+#ifdef USEMPI
+ idest = p_address_compute(iproc)
+ CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_INTEGER, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (gbuff)
+#endif
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (pbuff(iproc)%val (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_active(iproc)
+ CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_INTEGER, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ pbuff(0)%val = gbuff
+ deallocate (gbuff)
+#endif
+ 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, p_np_active-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_SPMD_Task
+ 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 (p_is_active) THEN
+
+ DO iproc = 0, p_np_compute-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
+
+#ifdef USEMPI
+ idest = p_address_compute(iproc)
+ CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (gbuff)
+#endif
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+ allocate (pdata_tem (size(pdata)))
+
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (pbuff(iproc)%val (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_active(iproc)
+ CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ pbuff(0)%val = gbuff
+ deallocate (gbuff)
+#endif
+ 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, p_np_active-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_SPMD_Task
+ 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 (p_is_active) THEN
+
+ DO iproc = 0, p_np_compute-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
+
+#ifdef USEMPI
+ idest = p_address_compute(iproc)
+ CALL mpi_send (gbuff, this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+
+ deallocate (gbuff)
+#endif
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (pbuff(iproc)%val (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_active(iproc)
+ CALL mpi_recv (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ pbuff(0)%val = gbuff
+ deallocate (gbuff)
+#endif
+ 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, p_np_active-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_SPMD_Task
+ 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 (p_is_compute) THEN
+
+ allocate (pbuff (0:p_np_active-1))
+
+ DO iproc = 0, p_np_active-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
+
+#ifdef USEMPI
+ DO iproc = 0, p_np_active-1
+ IF (this%glist(iproc)%ng > 0) THEN
+ idest = p_address_active(iproc)
+ CALL mpi_send (pbuff(iproc)%val, this%glist(iproc)%ng, MPI_REAL8, &
+ idest, mpi_tag_data, p_comm_glb, p_err)
+ ENDIF
+ ENDDO
+#endif
+
+ ENDIF
+
+ IF (p_is_active) THEN
+
+ CALL flush_block_data (gdata, 0.0_r8)
+
+ DO iproc = 0, p_np_compute-1
+ IF (this%glist(iproc)%ng > 0) THEN
+
+ allocate (gbuff (this%glist(iproc)%ng))
+
+#ifdef USEMPI
+ isrc = p_address_compute(iproc)
+ CALL mpi_recv (gbuff, this%glist(iproc)%ng, MPI_REAL8, &
+ isrc, mpi_tag_data, p_comm_glb, p_stat, p_err)
+#else
+ gbuff = pbuff(0)%val
+#endif
+
+ 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 (p_is_compute) THEN
+ DO iproc = 0, p_np_active-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_SPMD_Task
+ 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 (p_is_active) CALL allocate_block_data (this%grid, sumdata)
+ IF (p_is_compute) CALL this%allocate_part (scaldata)
+
+ CALL this%part2grid (sdata, sumdata)
+
+ IF (p_is_active) 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 (p_is_compute) 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 (p_is_compute) 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_SPMD_Task
+ 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 (p_is_compute) 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_SPMD_Task
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ class (spatial_mapping_type) :: this
+
+ type(pointer_real8_1d), allocatable :: datapart (:)
+
+ ! Local variables
+ integer :: iset
+
+ IF (p_is_compute) 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_SPMD_Task
+ USE MOD_DataType
+ IMPLICIT NONE
+
+ class (spatial_mapping_type) :: this
+
+ type(pointer_real8_1d), allocatable :: datapart (:)
+
+ ! Local variables
+ integer :: iset
+
+ IF (p_is_compute) 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_SPMD_Task
+ 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 (p_is_compute) 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_SPMD_Task
+ 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 (p_is_compute) 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..f56f51a1f0
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_SrfdataRestart.F90
@@ -0,0 +1,837 @@
+#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_save_to_file
+ PUBLIC :: mesh_load_from_file
+
+ PUBLIC :: pixelset_save_to_file
+ PUBLIC :: pixelset_load_from_file
+
+CONTAINS
+
+ ! -----------------------
+ SUBROUTINE mesh_save_to_file (dir_landdata, lc_year)
+
+ USE MOD_SPMD_Task
+ USE MOD_NetCDFSerial
+ USE MOD_Mesh
+ USE MOD_Block
+ USE MOD_Utils
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: dir_landdata
+ integer , intent(in) :: lc_year
+
+ ! Local variables
+ character(len=256) :: filename, fileblock, cyear
+ integer :: ie, je, nelm, totlen, tothis, iblk, jblk, owner_rank, i
+ integer, allocatable :: nelm_rank(:), ndsp_rank(:)
+ integer*8, allocatable :: elmindx(:)
+ integer, allocatable :: npxlall(:)
+ integer, allocatable :: elmpixels(:,:)
+ real(r8), allocatable :: lon(:), lat(:)
+
+ integer :: nsend, nrecv, ndone, ndsp
+
+#ifdef MPAS_EMBEDDED_COLM
+ CALL CoLM_stop('MPAS embedded CoLM does not support standalone mesh_save_to_file.')
+#endif
+
+ ! add parameter input for time year
+ write(cyear,'(i4.4)') lc_year
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+ IF (p_is_root) THEN
+ write(*,*) 'Saving land elements ...'
+ CALL system('mkdir -p ' // trim(dir_landdata) // '/mesh/' // trim(cyear))
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ filename = trim(dir_landdata) // '/mesh/' //trim(cyear) // '/mesh.nc'
+
+ DO jblk = 1, gblock%nyblk
+ DO iblk = 1, gblock%nxblk
+
+#ifdef USEMPI
+ IF (p_is_compute) THEN
+ IF (gblock%pio(iblk,jblk) == p_address_active(p_my_group)) THEN
+#endif
+ nelm = 0
+ totlen = 0
+ DO ie = 1, numelm
+ IF ((mesh(ie)%xblk == iblk) .and. (mesh(ie)%yblk == jblk)) THEN
+ nelm = nelm + 1
+ totlen = totlen + mesh(ie)%npxl
+ ENDIF
+ ENDDO
+
+ IF (nelm > 0) THEN
+
+ allocate (elmindx (nelm))
+ allocate (npxlall (nelm))
+ allocate (elmpixels (2,totlen))
+
+ je = 0
+ ndsp = 0
+ DO ie = 1, numelm
+ IF ((mesh(ie)%xblk == iblk) .and. (mesh(ie)%yblk == jblk)) THEN
+ je = je + 1
+ elmindx(je) = mesh(ie)%indx
+ npxlall(je) = mesh(ie)%npxl
+
+ elmpixels(1,ndsp+1:ndsp+npxlall(je)) = mesh(ie)%ilon
+ elmpixels(2,ndsp+1:ndsp+npxlall(je)) = mesh(ie)%ilat
+
+ ndsp = ndsp + npxlall(je)
+ ENDIF
+ ENDDO
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_gather (nelm, 1, MPI_INTEGER, &
+ MPI_INULL_P, 1, MPI_INTEGER, p_root, p_comm_group, p_err)
+
+ CALL mpi_gatherv (elmindx, nelm, MPI_INTEGER8, &
+ MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER8, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ CALL mpi_gatherv (npxlall, nelm, MPI_INTEGER, &
+ MPI_INULL_P, MPI_INULL_P, MPI_INULL_P, MPI_INTEGER, & ! unused on non-root ranks
+ p_root, p_comm_group, p_err)
+
+ ndone = 0
+ DO WHILE (ndone < totlen)
+ nsend = max(min(totlen-ndone, MesgMaxSize/8), 1)
+ CALL mpi_send (nsend, 1, &
+ MPI_INTEGER, p_root, mpi_tag_size, p_comm_group, p_err)
+ CALL mpi_send (elmpixels(:,ndone+1:ndone+nsend), 2*nsend, &
+ MPI_INTEGER, p_root, mpi_tag_data, p_comm_group, p_err)
+ ndone = ndone + nsend
+ ENDDO
+ ENDIF
+ ENDIF
+#endif
+
+#ifdef USEMPI
+ IF (p_is_active) THEN
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+
+ allocate (nelm_rank (0:p_np_group-1))
+ nelm_rank(0) = 0
+ CALL mpi_gather (MPI_IN_PLACE, 0, MPI_INTEGER, &
+ nelm_rank, 1, MPI_INTEGER, p_root, p_comm_group, p_err)
+
+ nelm = sum(nelm_rank)
+
+ allocate (ndsp_rank(0:p_np_group-1))
+ ndsp_rank(0) = 0
+ DO owner_rank = 1, p_np_group-1
+ ndsp_rank(owner_rank) = ndsp_rank(owner_rank-1) + nelm_rank(owner_rank-1)
+ ENDDO
+
+ allocate (elmindx (nelm))
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER8, &
+ elmindx, nelm_rank(0:), ndsp_rank(0:), MPI_INTEGER8, &
+ p_root, p_comm_group, p_err)
+
+ allocate (npxlall (nelm))
+ CALL mpi_gatherv (MPI_IN_PLACE, 0, MPI_INTEGER, &
+ npxlall, nelm_rank(0:), ndsp_rank(0:), MPI_INTEGER, &
+ p_root, p_comm_group, p_err)
+
+ totlen = sum(npxlall)
+ allocate (elmpixels (2, totlen))
+
+ ndone = 0
+ DO owner_rank = 1, p_np_group-1
+
+ ndsp = ndsp_rank(owner_rank)
+ tothis = ndone + sum(npxlall(ndsp+1:ndsp+nelm_rank(owner_rank)))
+
+ DO WHILE (ndone < tothis)
+
+ CALL mpi_recv (nrecv, 1, &
+ MPI_INTEGER, owner_rank, mpi_tag_size, p_comm_group, p_stat, p_err)
+ CALL mpi_recv (elmpixels(:,ndone+1:ndone+nrecv), 2*nrecv, &
+ MPI_INTEGER, owner_rank, mpi_tag_data, p_comm_group, p_stat, p_err)
+
+ ndone = ndone + nrecv
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+#endif
+
+ IF (p_is_active) THEN
+ IF (gblock%pio(iblk,jblk) == p_iam_glb) THEN
+ IF (nelm > 0) THEN
+ CALL get_filename_block (filename, iblk, jblk, fileblock)
+ CALL ncio_create_file (fileblock)
+
+ CALL ncio_define_dimension (fileblock, 'element',nelm)
+ CALL ncio_define_dimension (fileblock, 'ncoor', 2 )
+ CALL ncio_define_dimension (fileblock, 'pixel', totlen)
+
+ CALL ncio_write_serial (fileblock, 'elmindex', elmindx, 'element')
+ CALL ncio_write_serial (fileblock, 'elmnpxl', npxlall, 'element')
+ CALL ncio_write_serial (fileblock, 'elmpixels', elmpixels, &
+ 'ncoor', 'pixel', compress = 1)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF (allocated (elmindx)) deallocate(elmindx)
+ IF (allocated (npxlall)) deallocate(npxlall)
+ IF (allocated (elmpixels)) deallocate(elmpixels)
+
+ IF (allocated (nelm_rank)) deallocate(nelm_rank)
+ IF (allocated (ndsp_rank)) deallocate(ndsp_rank)
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_group, p_err)
+#endif
+ ENDDO
+ ENDDO
+
+ IF (p_is_root) THEN
+
+ CALL ncio_create_file (filename)
+
+ CALL ncio_define_dimension (filename, 'xblk', gblock%nxblk)
+ CALL ncio_define_dimension (filename, 'yblk', gblock%nyblk)
+ CALL ncio_write_serial (filename, 'nelm_blk', nelm_blk, 'xblk', 'yblk')
+
+ CALL ncio_define_dimension (filename, 'longitude', gridmesh%nlon)
+ CALL ncio_define_dimension (filename, 'latitude' , gridmesh%nlat)
+
+ allocate (lon (gridmesh%nlon))
+ allocate (lat (gridmesh%nlat))
+
+ DO i = 1, gridmesh%nlon
+ lon(i) = (gridmesh%lon_w(i) + gridmesh%lon_e(i)) * 0.5
+ IF (gridmesh%lon_w(i) > gridmesh%lon_e(i)) THEN
+ lon(i) = lon(i) + 180.0
+ CALL normalize_longitude (lon(i))
+ ENDIF
+ ENDDO
+ CALL ncio_write_serial (filename, 'longitude', lon, 'longitude')
+
+ DO i = 1, gridmesh%nlat
+ lat(i) = (gridmesh%lat_s(i) + gridmesh%lat_n(i)) * 0.5
+ ENDDO
+ CALL ncio_write_serial (filename, 'latitude', lat, 'latitude')
+
+#ifdef GRIDBASED
+ CALL ncio_write_serial (filename, 'lat_s', gridmesh%lat_s, 'latitude' )
+ CALL ncio_write_serial (filename, 'lat_n', gridmesh%lat_n, 'latitude' )
+ CALL ncio_write_serial (filename, 'lon_w', gridmesh%lon_w, 'longitude')
+ CALL ncio_write_serial (filename, 'lon_e', gridmesh%lon_e, 'longitude')
+#endif
+
+ deallocate (lon)
+ deallocate (lat)
+
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_root) write(*,*) 'SAVE land elements done.'
+
+ END SUBROUTINE mesh_save_to_file
+
+ !------------------------------------
+ SUBROUTINE prepare_subset_eindex(subset_eindex, sorted_subset)
+
+ USE MOD_Utils, only: quicksort
+ 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)
+ 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_SPMD_Task
+ 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 USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_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'
+ 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 (p_is_active) THEN
+
+ CALL mesh_free_mem()
+ numelm = sum(nelm_blk, mask = gblock%pio == p_iam_glb)
+
+ 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 (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)
+ ELSE
+ CALL ncio_read_serial (fileblock, 'elmpixels', pixels)
+ 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
+ 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
+
+ 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 (p_is_active) write(*,'(I10,A,I4)') numelm, ' elements on group ', p_iam_active
+#endif
+
+#ifdef USEMPI
+#ifndef MPAS_EMBEDDED_COLM
+ CALL scatter_mesh_legacy_roles
+#endif
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_root) THEN
+ write(*,*) 'Loading land elements done.'
+ ENDIF
+
+ END SUBROUTINE mesh_load_from_file
+
+ !------------------------------------------------
+ SUBROUTINE pixelset_save_to_file (dir_landdata, psetname, pixelset, lc_year)
+
+ USE MOD_Namelist
+ USE MOD_SPMD_Task
+ USE MOD_Block
+ USE MOD_NetCDFVector
+ USE MOD_Pixelset
+ IMPLICIT NONE
+
+ character(len=*), intent(in) :: dir_landdata
+ character(len=*), intent(in) :: psetname
+ type(pixelset_type), intent(in) :: pixelset
+ integer , intent(in) :: lc_year
+
+ ! Local variables
+ character(len=256) :: filename, cyear
+
+#ifdef MPAS_EMBEDDED_COLM
+ CALL CoLM_stop('MPAS embedded CoLM does not support standalone pixelset_save_to_file.')
+#endif
+
+ write(cyear,'(i4.4)') lc_year
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+ IF (p_is_root) THEN
+ write(*,*) 'Saving Pixel Sets ' // trim(psetname) // ' ...'
+ CALL system('mkdir -p ' // trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear))
+ ENDIF
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ filename = trim(dir_landdata) // '/' // trim(psetname) // '/' // trim(cyear) // '/' // trim(psetname) // '.nc'
+
+ CALL ncio_create_file_vector (filename, pixelset)
+ CALL ncio_define_dimension_vector (filename, pixelset, trim(psetname))
+
+ CALL ncio_write_vector (filename, 'eindex', trim(psetname), pixelset, pixelset%eindex, DEF_Srfdata_CompressLevel)
+ CALL ncio_write_vector (filename, 'ipxstt', trim(psetname), pixelset, pixelset%ipxstt, DEF_Srfdata_CompressLevel)
+ CALL ncio_write_vector (filename, 'ipxend', trim(psetname), pixelset, pixelset%ipxend, DEF_Srfdata_CompressLevel)
+ CALL ncio_write_vector (filename, 'settyp', trim(psetname), pixelset, pixelset%settyp, DEF_Srfdata_CompressLevel)
+
+ IF (pixelset%has_shared) THEN
+ CALL ncio_write_vector (filename, 'pctshared', trim(psetname), pixelset, pixelset%pctshared, DEF_Srfdata_CompressLevel)
+ ENDIF
+
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ IF (p_is_root) write(*,*) 'SAVE Pixel Sets ' // trim(psetname) // ' done.'
+
+ END SUBROUTINE pixelset_save_to_file
+
+
+ !---------------------------
+ SUBROUTINE pixelset_load_from_file (dir_landdata, psetname, pixelset, numset, lc_year, subset_eindex)
+
+ USE MOD_SPMD_Task
+ USE MOD_Block
+ USE MOD_NetCDFSerial
+ USE MOD_NetCDFVector
+ USE MOD_Mesh
+ USE MOD_Pixelset
+ 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, blockname, cyear
+ integer :: iset, nset, nset_file, ndsp, iblkme, iblk, jblk, ie, je, nave, nres, left, iproc, ipos
+ integer :: nsend, nrecv
+ integer*8, allocatable :: rbuff(:), sbuff(:)
+ integer*8, allocatable :: subset_sorted(:)
+ integer, allocatable :: owner_rank(:)
+ logical, allocatable :: msk(:)
+ logical, allocatable :: keep_set(:)
+ logical :: fexists, fexists_any
+ logical :: use_subset
+
+ write(cyear,'(i4.4)') lc_year
+#ifdef USEMPI
+ CALL mpi_barrier (p_comm_glb, p_err)
+#endif
+
+ use_subset = present(subset_eindex)
+ IF (use_subset) CALL prepare_subset_eindex(subset_eindex, subset_sorted)
+
+ IF (p_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 (p_is_active) 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 USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, fexists_any, 1, MPI_LOGICAL, MPI_LOR, p_comm_active, p_err)
+#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 (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 (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
+ ENDIF
+ ENDIF
+
+
+#if defined(USEMPI) && !defined(MPAS_EMBEDDED_COLM)
+ IF (p_is_active) THEN
+ IF (pixelset%nset > 0) THEN
+ allocate (owner_rank (pixelset%nset))
+ allocate (msk (pixelset%nset))
+
+ ie = 1
+ je = 1
+ iblk = mesh(ie)%xblk
+ jblk = mesh(ie)%yblk
+ DO iset = 1, pixelset%nset
+ DO WHILE (pixelset%eindex(iset) /= mesh(ie)%indx)
+ ie = ie + 1
+ je = je + 1
+ IF ((mesh(ie)%xblk /= iblk) .or. (mesh(ie)%yblk /= jblk)) THEN
+ je = 1
+ iblk = mesh(ie)%xblk
+ jblk = mesh(ie)%yblk
+ ENDIF
+ ENDDO
+
+ nave = nelm_blk(iblk,jblk) / (p_np_group-1)
+ nres = mod(nelm_blk(iblk,jblk), p_np_group-1)
+ left = (nave+1) * nres
+ IF (je <= left) THEN
+ owner_rank(iset) = (je-1) / (nave+1) + 1
+ ELSE
+ owner_rank(iset) = (je-left-1) / nave + 1 + nres
+ ENDIF
+ ENDDO
+
+ DO iproc = 1, p_np_group-1
+ msk = (owner_rank == iproc)
+ nsend = count(msk)
+ CALL mpi_send (nsend, 1, MPI_INTEGER, iproc, mpi_tag_size, p_comm_group, p_err)
+
+ IF (nsend > 0) THEN
+ allocate (sbuff(nsend))
+ sbuff = pack(pixelset%eindex, msk)
+ CALL mpi_send (sbuff, nsend, MPI_INTEGER8, iproc, mpi_tag_data, p_comm_group, p_err)
+ deallocate (sbuff)
+ ENDIF
+ ENDDO
+ ELSE
+ DO iproc = 1, p_np_group-1
+ nsend = 0
+ CALL mpi_send (nsend, 1, MPI_INTEGER, iproc, mpi_tag_size, p_comm_group, p_err)
+ ENDDO
+ ENDIF
+
+ ENDIF
+
+ IF (p_is_compute) THEN
+
+ CALL mpi_recv (nrecv, 1, MPI_INTEGER, p_root, mpi_tag_size, p_comm_group, p_stat, p_err)
+
+ pixelset%nset = nrecv
+ IF (nrecv > 0) THEN
+ allocate (pixelset%eindex (nrecv))
+ CALL mpi_recv (pixelset%eindex, nrecv, MPI_INTEGER8, &
+ p_root, mpi_tag_data, p_comm_group, p_stat, p_err)
+ ENDIF
+ ENDIF
+#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 (p_is_compute) THEN
+ IF (pixelset%nset > 0) THEN
+
+ allocate (pixelset%ielm (pixelset%nset))
+ ie = 1
+ DO iset = 1, pixelset%nset
+ DO WHILE (pixelset%eindex(iset) /= mesh(ie)%indx)
+ ie = ie + 1
+ ENDDO
+ pixelset%ielm(iset) = ie
+ ENDDO
+
+ ELSE
+ write(*,*) 'Warning: 0 ',trim(psetname), ' on rank :', p_iam_glb
+ ENDIF
+ ENDIF
+
+ numset = pixelset%nset
+
+ pixelset%has_shared = .false.
+ IF (p_is_compute) 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 USEMPI
+ CALL mpi_allreduce (MPI_IN_PLACE, pixelset%has_shared, 1, MPI_LOGICAL, &
+ MPI_LOR, p_comm_glb, p_err)
+#endif
+
+ IF (pixelset%has_shared) THEN
+ CALL ncio_read_vector (filename, 'pctshared', pixelset, pixelset%pctshared)
+ ENDIF
+
+#ifdef CoLMDEBUG
+ IF (p_is_active) write(*,*) numset, trim(psetname), ' on group', p_iam_active
+#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..0b1b63cf2d
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_TimeManager.F90
@@ -0,0 +1,711 @@
+#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) THEN
+
+ 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
+ ENDIF
+
+ 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)
+ IF (idate(3) > 86400) THEN
+
+ 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
+ ENDIF
+
+ 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..4f22b5b0b5
--- /dev/null
+++ b/src/core_atmosphere/physics/physics_colm2024/share/MOD_Utils.F90
@@ -0,0 +1,2615 @@
+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
+
+ 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 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.